c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  action.i  --  total number of each energy term computed  ##
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     nebt    number of stretch-torsion energy terms computed
c     nett    number of torsion-torsion energy terms computed
c     nev     number of van der Waals 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     new     number of Ewald summation energy terms computed
c     ner     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
      integer neb,nea,neba,neub
      integer neaa,neopb,neopd
      integer neid,neit,net,nebt
      integer nett,nev,nec,necd
      integer ned,nem,nep,new,ner
      integer nes,nelf,neg,nex
      common /action/ neb,nea,neba,neub,neaa,neopb,neopd,neid,neit,
     &                net,nebt,nett,nev,nec,necd,ned,nem,nep,new,
     &                ner,nes,nelf,neg,nex
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  align.i  --  information for superposition of structures  ##
c     ##                                                            ##
c     ################################################################
c
c
c     wfit    weights assigned to atom pairs during superposition
c     nfit    number of atoms to use in superimposing two structures
c     ifit    atom numbers of pairs of atoms to be superimposed
c
c
      integer nfit,ifit
      real*8 wfit
      common /align/ wfit(maxatm),nfit,ifit(2,maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  analyz.i  --  energy components partitioned over atoms  ##
c     ##                                                          ##
c     ##############################################################
c
c
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     aebt    stretch-torsion energy partitioned over atoms
c     aett    torsion-torsion energy partitioned over atoms
c     aev     van der Waals 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     aer     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
      real*8 aeb,aea,aeba,aeub
      real*8 aeaa,aeopb,aeopd
      real*8 aeid,aeit,aet,aebt
      real*8 aett,aev,aec,aecd
      real*8 aed,aem,aep,aer
      real*8 aes,aelf,aeg,aex
      common /analyz/ aeb(maxatm),aea(maxatm),aeba(maxatm),
     &                aeub(maxatm),aeaa(maxatm),aeopb(maxatm),
     &                aeopd(maxatm),aeid(maxatm),aeit(maxatm),
     &                aet(maxatm),aebt(maxatm),aett(maxatm),
     &                aev(maxatm),aec(maxatm),aecd(maxatm),
     &                aed(maxatm),aem(maxatm),aep(maxatm),
     &                aer(maxatm),aes(maxatm),aelf(maxatm),
     &                aeg(maxatm),aex(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  angang.i  --  angle-angle terms in current structure  ##
c     ##                                                        ##
c     ############################################################
c
c
c     kaa       force constant for angle-angle cross terms
c     nangang   total number of angle-angle interactions
c     iaa       angle numbers used in each angle-angle term
c
c
      integer nangang,iaa
      real*8 kaa
      common /angang/ kaa(maxtors),nangang,iaa(2,maxtors)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  angle.i  --  bond angles within the current structure  ##
c     ##                                                         ##
c     #############################################################
c
c
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 bond angle term
c     nangle   total number of bond angles in the system
c     iang     numbers of the atoms in each bond angle
c     angtyp   potential energy function type for each bond angle
c
c
      integer nangle,iang
      real*8 ak,anat,afld
      character*8 angtyp
      common /angle/ ak(maxang),anat(maxang),afld(maxang),nangle,
     &               iang(4,maxang),angtyp(maxang)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  angpot.i  --  specifics of bond angle functional forms  ##
c     ##                                                          ##
c     ##############################################################
c
c
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     angunit    convert angle force constant to kcal/mole/deg**2
c     stbnunit   convert str-bend constant to kcal/mole/deg-Ang**2
c     aaunit     convert angle-angle constant to kcal/mole/deg**2
c     opbunit    convert out-of-plane bend force to kcal/mole/deg**2
c     opdunit    convert out-of-plane distance to kcal/mole/Ang**2
c     mm2stbn    logical flag governing use of MM2-style stretch-bend
c
c
      real*8 cang,qang,pang,sang
      real*8 angunit,stbnunit,aaunit
      real*8 opbunit,opdunit
      logical mm2stbn
      common /angpot/ cang,qang,pang,sang,angunit,stbnunit,aaunit,
     &                opbunit,opdunit,mm2stbn
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  argue.i  --  command line arguments at program startup  ##
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
      integer maxarg
      parameter (maxarg=20)
      integer narg
      logical listarg
      character*60 arg
      common /argue/ narg,listarg(0:maxarg),arg(0:maxarg)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  atmlst.i  --  local geometry terms involving each atom  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     bndlist   list of the bond numbers involving each atom
c     anglist   list of the angle numbers centered on each atom
c
c
      integer bndlist,anglist
      common /atmlst/ bndlist(maxval,maxatm),
     &                anglist(maxval*(maxval-1)/2,maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  atmtyp.i  --  atomic properties for each current atom  ##
c     ##                                                         ##
c     #############################################################
c
c
c     mass      atomic weight for each atom in the system
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     valence   valence number for each atom in the system
c     name      atom name for each atom in the system
c     story     descriptive type for each atom in system
c
c
      integer tag,class
      integer atomic,valence
      real*8 mass
      character*3 name
      character*20 story
      common /atmtyp/ mass(maxatm),tag(maxatm),class(maxatm),
     &                atomic(maxatm),valence(maxatm),name(maxatm),
     &                story(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  atoms.i  --  number, position and type of current atoms  ##
c     ##                                                           ##
c     ###############################################################
c
c
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     n       total number of atoms in the current system
c     type    atom type number for each atom in the system
c
c
      integer n,type
      real*8 x,y,z
      common /atoms/ x(maxatm),y(maxatm),z(maxatm),n,type(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  bath.i  --  temperature and pressure control parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     kelvin      target value for the system temperature (K)
c     atmsph      target value for the system pressure (atm)
c     tautemp     time constant in psec for temperature bath coupling
c     taupres     time constant in psec for pressure bath coupling
c     compress    isothermal compressibility of medium (atm-1)
c     collide     collision frequency for Andersen thermostat
c     isothermal  logical flag geverning use of temperature bath
c     isobaric    logical flag governing use of pressure bath
c     thermostat  type of thermostat, either Berendsen or Andersen
c
c
      real*8 kelvin,atmsph
      real*8 tautemp,taupres
      real*8 compress,collide
      logical isothermal,isobaric
      character*9 thermostat
      common /bath/ kelvin,atmsph,tautemp,taupres,compress,collide,
     &              isothermal,isobaric,thermostat
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  bndpot.i  --  specifics of bond stretch functional forms  ##
c     ##                                                            ##
c     ################################################################
c
c
c     cbnd      cubic coefficient in bond stretch potential
c     qbnd      quartic coefficient in bond stretch potential
c     bndunit   convert bond force constant to kcal/mole/Ang**2
c     bndtyp    type of bond stretch potential energy function
c
c
      real*8 cbnd,qbnd
      real*8 bndunit
      character*8 bndtyp
      common /bndpot/ cbnd,qbnd,bndunit,bndtyp
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  bond.i  --  covalent bonds in the current structure  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     bk      bond stretch force constants (kcal/mole/Ang**2)
c     bl      ideal bond length values in Angstroms
c     nbond   total number of bond stretches in the system
c     ibnd    numbers of the atoms in each bond stretch
c
c
      integer nbond,ibnd
      real*8 bk,bl
      common /bond/ bk(maxbnd),bl(maxbnd),nbond,ibnd(2,maxbnd)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  border.i  --  bond orders for a conjugated pisystem  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     pbpl   pi-bond orders for bonds in "planar" pisystem
c     pnpl   pi-bond orders for bonds in "nonplanar" pisystem
c
c
      real*8 pbpl,pnpl
      common /border/ pbpl(maxpib),pnpl(maxpib)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  bound.i  --  control of periodic boundary conditions  ##
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_image     flag to use images for periodic system
c     use_replica   flag to use replicates for periodic system
c     use_polymer   flag to mark presence of infinite polymer
c
c
      real*8 polycut,polycut2
      logical use_bounds,use_image
      logical use_replica,use_polymer
      common /bound/ polycut,polycut2,use_bounds,use_image,use_replica,
     &               use_polymer
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  boxes.i  --  parameters for periodic boundary conditions  ##
c     ##                                                            ##
c     ################################################################
c
c
c     xbox        length in Angs of a-axis of periodic box
c     ybox        length in Angs of b-axis of periodic box
c     zbox        length in Angs of c-axis of periodic box
c     alpha       angle in degrees between b- and c-axes of box
c     beta        angle in degrees between a- and c-axes of box
c     gamma       angle in degrees between a- and b-axes of box
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     recip       reciprocal lattice vectors as matrix columns
c     volbox      volume in Ang**3 of the periodic box
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     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     spacegrp    space group symbol for the unitcell type
c
c
      real*8 xbox,ybox,zbox
      real*8 alpha,beta,gamma
      real*8 xbox2,ybox2,zbox2
      real*8 box34,volbox,recip
      real*8 beta_sin,beta_cos
      real*8 gamma_sin,gamma_cos
      real*8 beta_term,gamma_term
      logical orthogonal,monoclinic
      logical triclinic,octahedron
      character*10 spacegrp
      common /boxes/ xbox,ybox,zbox,alpha,beta,gamma,xbox2,ybox2,
     &               zbox2,box34,recip(3,3),volbox,beta_sin,beta_cos,
     &               gamma_sin,gamma_cos,beta_term,gamma_term,
     &               orthogonal,monoclinic,triclinic,octahedron,
     &               spacegrp
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  cell.i  --  periodic boundaries using replicated cells  ##
c     ##                                                          ##
c     ##############################################################
c
c
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     ncell    total number of cell replicates for periodic boundaries
c     icell    offset along axes for each replicate periodic cell
c
c
      integer ncell,icell
      real*8 xcell,ycell,zcell
      real*8 xcell2,ycell2,zcell2
      common /cell/ xcell,ycell,zcell,xcell2,ycell2,zcell2,ncell,
     &              icell(3,maxcell)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  centre.i  --  atom coordinates relative to center of mass  ##
c     ##                                                             ##
c     #################################################################
c
c
c     xcm   offset of each atom from center of mass x-coordinate
c     ycm   offset of each atom from center of mass y-coordinate
c     zcm   offset of each atom from center of mass z-coordinate
c
c
      real*8 xcm,ycm,zcm
      common /centre/ xcm(maxatm),ycm(maxatm),zcm(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  charge.i  --  partial charges for the current structure  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     pchg      magnitude of the partial charges (e-)
c     nion      total number of partial charges in system
c     iion      number of the atom site for each partial charge
c     jion      neighbor generation site for each partial charge
c     kion      cutoff switching site for each partial charge
c     chglist   partial charge site for each atom (0=no charge)
c
c
      integer nion,iion
      integer jion,kion
      integer chglist
      real*8 pchg
      common /charge/ pchg(maxatm),nion,iion(maxatm),jion(maxatm),
     &                kion(maxatm),chglist(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  chgpot.i  --  specifics of charge-charge functional form  ##
c     ##                                                            ##
c     ################################################################
c
c
c     dielec    dielectric constant for electrostatic interactions
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
      real*8 dielec
      real*8 c2scale,c3scale
      real*8 c4scale,c5scale
      logical neutnbr,neutcut
      common /chgpot/ dielec,c2scale,c3scale,c4scale,c5scale,neutnbr,
     &                neutcut
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  chrono.i  --  timing statistics for the current program  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     cputim   elapsed cpu time in seconds since start of program
c
c
      real*8 cputim
      common /chrono/ cputim
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  couple.i  --  near-neighbor atom connectivity lists   ##
c     ##                                                        ##
c     ############################################################
c
c
c     maxn13   maximum number of atoms 1-3 connected to an atom
c     maxn14   maximum number of atoms 1-4 connected to an atom
c     maxn15   maximum number of atoms 1-5 connected to an atom
c
c     n12      number of atoms directly bonded to each atom
c     i12      atom numbers of atoms 1-2 connected to each atom
c     n13      number of atoms in a 1-3 relation to each atom
c     i13      atom numbers of atoms 1-3 connected to each atom
c     n14      number of atoms in a 1-4 relation to each atom
c     i14      atom numbers of atoms 1-4 connected to each atom
c     n15      number of atoms in a 1-5 relation to each atom
c     i15      atom numbers of atoms 1-5 connected to each atom
c
c
      integer maxn13,maxn14,maxn15
      parameter (maxn13=3*maxval)
      parameter (maxn14=9*maxval)
      parameter (maxn15=27*maxval)
      integer n12,i12,n13,i13
      integer n14,i14,n15,i15
      common /couple/ n12(maxatm),i12(maxval,maxatm),n13(maxatm),
     &                i13(maxn13,maxatm),n14(maxatm),i14(maxn14,maxatm),
     &                n15(maxatm),i15(maxn15,maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  cutoff.i  --  cutoff distances for energy interactions  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     vdwcut      cutoff distance for van der Waals 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     vdwtaper    distance at which van der Waals 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     ewaldcut    cutoff distance for direct space Ewald summation
c     use_ewald   logical flag governing use of Ewald summation term
c     use_lights  logical flag to use method of lights neighbors
c
c
      real*8 vdwcut,chgcut
      real*8 dplcut,mpolecut
      real*8 vdwtaper,chgtaper
      real*8 dpltaper,mpoletaper
      real*8 ewaldcut
      logical use_ewald,use_lights
      common /cutoff/ vdwcut,chgcut,dplcut,mpolecut,vdwtaper,chgtaper,
     &                dpltaper,mpoletaper,ewaldcut,use_ewald,use_lights
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  deriv.i  --  Cartesian coordinate derivative components  ##
c     ##                                                           ##
c     ###############################################################
c
c
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     debt    stretch-torsion Cartesian coordinate derivatives
c     dett    torsion-torsion Cartesian coordinate derivatives
c     dev     van der Waals 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     der     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
      real*8 deb,dea,deba,deub
      real*8 deaa,deopb,deopd
      real*8 deid,det,deit,debt
      real*8 dett,dev,dec,decd
      real*8 ded,dem,dep,der
      real*8 des,delf,deg,dex
      common /deriv/ deb(3,maxatm),dea(3,maxatm),deba(3,maxatm),
     &               deub(3,maxatm),deaa(3,maxatm),deopb(3,maxatm),
     &               deopd(3,maxatm),deid(3,maxatm),deit(3,maxatm),
     &               det(3,maxatm),debt(3,maxatm),dett(3,maxatm),
     &               dev(3,maxatm),dec(3,maxatm),decd(3,maxatm),
     &               ded(3,maxatm),dem(3,maxatm),dep(3,maxatm),
     &               der(3,maxatm),des(3,maxatm),delf(3,maxatm),
     &               deg(3,maxatm),dex(3,maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  dipole.i  --  atom & bond dipoles for current structure  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     bdpl      magnitude of each of the dipoles (Debyes)
c     sdpl      position of each dipole between defining atoms
c     ndipole   total number of dipoles in the system
c     idpl      numbers of atoms that define each dipole
c
c
      integer ndipole,idpl
      real*8 bdpl,sdpl
      common /dipole/ bdpl(maxbnd),sdpl(maxbnd),ndipole,idpl(2,maxbnd)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  disgeo.i  --  distance geometry bounds and parameters  ##
c     ##                                                         ##
c     #############################################################
c
c
c     bnd         distance geometry upper and lower bounds matrix
c     vdwrad      hard sphere radii for distance geometry atoms
c     vchir       signed volume values for chirality constraints
c     compact     index of local distance compaction on embedding
c     pathmax     maximum value of upper bound after smoothing
c     vdwmax      maximum value of hard sphere sum for an atom pair
c     nchir       total number of chirality constraints
c     ichir       numbers of atoms in each chirality constraint
c     use_invert  flag to use enantiomer closest to input structure
c     use_anneal  flag to use simulated annealing refinement
c
c
      integer nchir,ichir
      real*8 bnd,vdwrad,vchir
      real*8 compact,pathmax,vdwmax
      logical use_invert,use_anneal
      common /disgeo/ bnd(maxgeo,maxgeo),vdwrad(maxatm),vchir(maxatm),
     &                compact,pathmax,vdwmax,nchir,ichir(4,maxatm),
     &                use_invert,use_anneal
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  domega.i  --  derivative components over dihedrals  ##
c     ##                                                      ##
c     ##########################################################
c
c
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     tebt    stretch-torsion derivatives over torsions
c     tett    torsion-torsion derivatives over torsions
c     tev     van der Waals 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     ter     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
      real*8 teb,tea,teba,teub
      real*8 teaa,teopb,teopd
      real*8 teid,teit,tet,tebt
      real*8 tett,tev,tec,tecd
      real*8 ted,tem,tep,ter
      real*8 tes,telf,teg,tex
      common /domega/ teb(maxrot),tea(maxrot),teba(maxrot),
     &                teub(maxrot),teaa(maxrot),teopb(maxrot),
     &                teopd(maxrot),teid(maxrot),teit(maxrot),
     &                tet(maxrot),tebt(maxrot),tett(maxrot),
     &                tev(maxrot),tec(maxrot),tecd(maxrot),
     &                ted(maxrot),tem(maxrot),tep(maxrot),
     &                ter(maxrot),tes(maxrot),telf(maxrot),
     &                teg(maxrot),tex(maxrot)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  energi.i  --  individual potential energy components  ##
c     ##                                                        ##
c     ############################################################
c
c
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     ebt    stretch-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     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     er     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
      real*8 eb,ea,eba,eub
      real*8 eaa,eopb,eopd
      real*8 eid,eit,et,ebt
      real*8 ett,ev,ec,ecd
      real*8 ed,em,ep,er
      real*8 es,elf,eg,ex
      common /energi/ eb,ea,eba,eub,eaa,eopb,eopd,eid,eit,et,ebt,
     &                ett,ev,ec,ecd,ed,em,ep,er,es,elf,eg,ex
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2001  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  ewald.i  --  parameters for regular or PM Ewald summation  ##
c     ##                                                             ##
c     #################################################################
c
c
c     aewald    Ewald convergence coefficient value (Ang-1)
c     frecip    fractional cutoff value for reciprocal sphere
c     tinfoil   flag governing use of tinfoil boundary conditions
c
c
      real*8 aewald,frecip
      logical tinfoil
      common /ewald/ aewald,frecip,tinfoil
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  ewreg.i  --  exponential factors for regular Ewald sum  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     maxvec    maximum number of k-vectors per reciprocal axis
c
c     ejc       exponental factors for cosine along the j-axis
c     ejs       exponental factors for sine along the j-axis
c     ekc       exponental factors for cosine along the k-axis
c     eks       exponental factors for sine along the k-axis
c     elc       exponental factors for cosine along the l-axis
c     els       exponental factors for sine along the l-axis
c
c
      integer maxvec
      parameter (maxvec=15)
      real*8 ejc,ejs,ekc,eks,elc,els
      common /ewreg/ ejc(maxatm,0:maxvec),ejs(maxatm,0:maxvec),
     &               ekc(maxatm,-maxvec:maxvec),
     &               eks(maxatm,-maxvec:maxvec),
     &               elc(maxatm,-maxvec:maxvec),
     &               els(maxatm,-maxvec:maxvec)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  faces.i  --  variables for Connolly area and volume  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     maxnbr   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     maxep    maximum number of convex edges
c     maxfs    maximum number of saddle faces
c     maxcy    maximum number of cycles
c     mxcyep   maximum number of cycle convex edges
c     maxfp    maximum number of convex faces
c     mxfpcy   maximum number of convex face cycles
c
c
      integer maxnbr,maxtt,maxt,maxp,maxv
      integer maxen,maxfn,maxc,maxep,maxfs
      integer maxcy,mxcyep,maxfp,mxfpcy
      parameter (maxnbr=50*maxatm)
      parameter (maxtt=25*maxatm)
      parameter (maxt=3*maxatm)
      parameter (maxp=2*maxatm)
      parameter (maxv=5*maxatm)
      parameter (maxen=5*maxatm)
      parameter (maxfn=2*maxatm)
      parameter (maxc=5*maxatm)
      parameter (maxep=5*maxatm)
      parameter (maxfs=3*maxatm)
      parameter (maxcy=maxatm)
      parameter (mxcyep=30)
      parameter (maxfp=maxatm)
      parameter (mxfpcy=10)
c
c
c     a        atomic coordinates
c     ar       atomic radii
c     pr       probe radius
c     na       number of atoms
c
c
      integer na
      real*8 a,ar,pr
      common /face01/ a(3,maxatm),ar(maxatm),pr,na
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 skip,nosurf,afree,abur
      common /face02/ skip(maxatm),nosurf(maxatm),afree(maxatm),
     &                abur(maxatm)
c
c
c     anbr     begin and end pointers for atoms neighbors
c     nbr      atom numbers of neighbors
c     nbrt     pointer from neighbor to torus
c
c
      integer anbr,nbr,nbrt
      common /face03/ anbr(2,maxatm),nbr(maxnbr),nbrt(maxnbr)
c
c
c     ntt      number of temporary tori
c     tta      temporary 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 temporary torus
c     ttbur    temporary torus buried
c     ttfree   temporary torus free
c
c
      integer ntt,tta,ttfe,ttle,enext
      logical ttbur,ttfree
      common /face04/ ntt,tta(2,maxtt),ttfe(maxtt),ttle(maxtt),
     &                enext(maxen),ttbur(maxtt),ttfree(maxtt)
c
c
c     t        torus center
c     tr       torus radius
c     tax      torus axis
c     nt       number of tori
c     ta       torus atom numbers
c     tfe      torus first edge
c     tfree    torus free of neighbors
c
c
      integer nt,ta,tfe
      real*8 t,tr,tax
      logical tfree
      common /face05/ t(3,maxt),tr(maxt),tax(3,maxt),nt,
     &                ta(2,maxt),tfe(maxt),tfree(maxt)
c
c
c     p        probe position coordinates
c     np       number of probe positions
c     pa       probe position atom numbers
c
c
      integer np,pa
      real*8 p
      common /face06/ p(3,maxp),np,pa(3,maxp)
c
c
c     v        vertex coordinates
c     nv       number of vertices
c     va       vertex atom number
c     vp       vertex probe number
c
c
      integer nv,va,vp
      real*8 v
      common /face07/ v(3,maxv),nv,va(maxv),vp(maxv)
c
c
c     nen      number of concave edges
c     env      vertex numbers for each concave edge
c     nfn      number of concave faces
c     fnen     concave face concave edge numbers
c
c
      integer nen,env,nfn,fnen
      common /face08/ nen,env(2,maxen),nfn,fnen(3,maxfn)
c
c
c     c        circle center
c     cr       circle radius
c     nc       number of circles
c     ca       circle atom number
c     ct       circle torus number
c
c
      integer nc,ca,ct
      real*8 c,cr
      common /face09/ c(3,maxc),cr(maxc),nc,ca(maxc),ct(maxc)
c
c
c     nep      number of convex edges
c     epc      convex edge circle number
c     epv      convex edge vertex numbers
c     afe      first convex edge of each atom
c     ale      last convex edge of each atom
c     epnext   pointer to next convex edge of atom
c
c
      integer nep,epc,epv,afe,ale,epnext
      common /face10/ nep,epc(maxep),epv(2,maxep),afe(maxatm),
     &                ale(maxatm),epnext(maxep)
c
c
c     nfs      number of saddle faces
c     fsen     saddle face concave edge numbers
c     fsep     saddle face convex edge numbers
c
c
      integer nfs,fsen,fsep
      common /face11/ nfs,fsen(2,maxfs),fsep(2,maxfs)
c
c
c     ncy      number of cycles
c     cynep    number of convex edges in cycle
c     cyep     cycle convex edge numbers
c
c
      integer ncy,cynep,cyep
      common /face12/ ncy,cynep(maxcy),cyep(mxcyep,maxcy)
c
c
c     nfp      number of convex faces
c     fpa      atom number of convex face
c     fpcy     convex face cycle numbers
c     fpncy    number of cycles bounding convex face
c
c
      integer nfp,fpa,fpcy,fpncy
      common /face13/ nfp,fpa(maxfp),fpcy(mxfpcy,maxfp),fpncy(maxfp)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  fields.i  --  molecular mechanics force field description  ##
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
      integer biotyp
      character*20 forcefield
      common /fields/ biotyp(maxbio),forcefield
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  files.i  --  name and number of current structure files  ##
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   base filename used by default for all files
c     outfile    output filename used for intermediate results
c
c
      integer nprior,ldir,leng
      character*60 filename,outfile
      common /files/ nprior,ldir,leng,filename,outfile
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  fracs.i  --  atom 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
      real*8 xfrac,yfrac,zfrac
      common /fracs/ xfrac(maxatm),yfrac(maxatm),zfrac(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  group.i  --  partitioning of system into atom groups  ##
c     ##                                                        ##
c     ############################################################
c
c
c     grpmass     total mass of all the atoms in each group
c     wgrp        weight for each set of group-group interactions
c     grpnum      original group number for each nonempty group
c     ngrp        total number of atom groups in the system
c     kgrp        contiguous list of the atoms in each group
c     igrp        first and last atom of each group in the list
c     grplist     number of the group to which each atom belongs
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
      integer grpnum,ngrp
      integer kgrp,igrp
      integer grplist
      real*8 grpmass,wgrp
      logical use_group
      logical use_intra
      logical use_inter
      common /group/ grpmass(maxgrp),wgrp(0:maxgrp,0:maxgrp),
     &               grpnum(maxgrp),ngrp,kgrp(maxatm),igrp(2,0:maxgrp),
     &               grplist(maxatm),use_group,use_intra,use_inter
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  hescut.i  --  cutoff value for Hessian matrix elements  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     hesscut   magnitude of smallest allowed Hessian element
c
c
      real*8 hesscut
      common /hescut/ hesscut
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  hessn.i  --  Cartesian Hessian elements for a single 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
      real*8 hessx,hessy,hessz
      common /hessn/ hessx(3,maxatm),hessy(3,maxatm),hessz(3,maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  improp.i  --  improper dihedrals in the current structure  ##
c     ##                                                             ##
c     #################################################################
c
c
c     kprop    force constant values for improper dihedral angles
c     vprop    ideal improper dihedral angle value in degrees
c     niprop   total number of improper dihedral angles in the system
c     iiprop   numbers of the atoms in each improper dihedral angle
c
c
      integer niprop,iiprop
      real*8 kprop,vprop
      common /improp/ kprop(maxtors),vprop(maxtors),niprop,
     &                iiprop(4,maxtors)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  imptor.i  --  improper torsions in the current structure  ##
c     ##                                                            ##
c     ################################################################
c
c
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     nitors   total number of improper torsional angles in the system
c     iitors   numbers of the atoms in each improper torsional angle
c
c
      integer nitors,iitors
      real*8 itors1,itors2,itors3
      common /imptor/ itors1(4,maxtors),itors2(4,maxtors),
     &                itors3(4,maxtors),nitors,iitors(4,maxtors)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  inform.i  --  control values for I/O and program flow  ##
c     ##                                                         ##
c     #############################################################
c
c
c     digits    decimal places output for energy and coordinates
c     iprint    steps between status printing (0=no printing)
c     iwrite    steps between coordinate dumps (0=no dumps)
c     verbose   logical flag to turn on extra information
c     debug     logical flag to turn on full debug printing
c     holdup    logical flag to wait for carriage return on exit
c     abort     logical flag to stop execution at next chance
c
c
      integer digits,iprint,iwrite
      logical verbose,debug,holdup,abort
      common /inform/ digits,iprint,iwrite,verbose,debug,holdup,abort
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  inter.i  --  sum of intermolecular energy components  ##
c     ##                                                        ##
c     ############################################################
c
c
c     einter   total intermolecular potential energy
c
c
      real*8 einter
      common /inter/ einter
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  iounit.i  --  Fortran input/output (I/O) unit numbers  ##
c     ##                                                         ##
c     #############################################################
c
c
c     iout    Fortran I/O unit for major output (default=6)
c     input   Fortran I/O unit for major input (default=5)
c
c
      integer iout,input
      common /iounit/ iout,input
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  kanang.i  --  forcefield parameters for angle-angle terms  ##
c     ##                                                             ##
c     #################################################################
c
c
c     anan   angle-angle cross term parameters for each atom class
c
c
      real*8 anan
      common /kanang/ anan(3,maxclass)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  kangs.i  --  forcefield parameters for bond angle bending  ##
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     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     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     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     kaf      string of atom classes for Fourier angle bends
c
c
      integer maxna,maxna5,maxna4
      integer maxna3,maxnaf
      parameter (maxna=1000)
      parameter (maxna5=200)
      parameter (maxna4=100)
      parameter (maxna3=100)
      parameter (maxnaf=100)
      real*8 acon,acon5,acon4,acon3,aconf
      real*8 ang,ang5,ang4,ang3,angf
      character*9 ka,ka5,ka4,ka3,kaf
      common /kangs/ acon(maxna),acon5(maxna5),acon4(maxna4),
     &               acon3(maxna3),aconf(maxnaf),ang(3,maxna),
     &               ang5(3,maxna5),ang4(3,maxna4),ang3(3,maxna3),
     &               angf(2,maxnaf),ka(maxna),ka5(maxna5),ka4(maxna4),
     &               ka3(maxna3),kaf(maxnaf)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  katoms.i  --  forcefield parameters for the atom types  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     weight     average atomic mass of each atom type
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     symbol     modified atomic symbol for each atom type
c     describe   string identifing each of the atom types
c
c
      integer atmcls,atmnum
      integer ligand
      real*8 weight
      character*3 symbol
      character*20 describe
      common /katoms/ weight(maxtyp),atmcls(maxtyp),atmnum(maxtyp),
     &                ligand(maxtyp),symbol(maxtyp),describe(maxtyp)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  kbonds.i  --  forcefield parameters for bond stretching  ##
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
      integer maxnb,maxnb5,maxnb4
      integer maxnb3,maxnel
      parameter (maxnb=500)
      parameter (maxnb5=100)
      parameter (maxnb4=100)
      parameter (maxnb3=100)
      parameter (maxnel=500)
      real*8 bcon,bcon5,bcon4,bcon3
      real*8 blen,blen5,blen4,blen3,dlen
      character*6 kb,kb5,kb4,kb3
      character*9 kel
      common /kbonds/ bcon(maxnb),bcon5(maxnb5),bcon4(maxnb4),
     &                bcon3(maxnb3),blen(maxnb),blen5(maxnb5),
     &                blen4(maxnb4),blen3(maxnb3),dlen(maxnel),
     &                kb(maxnb),kb5(maxnb5),kb4(maxnb4),kb3(maxnb3),
     &                kel(maxnel)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  kchrge.i  --  forcefield parameters for partial charges  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     chg   partial charge parameters for each atom type
c
c
      real*8 chg
      common /kchrge/ chg(maxtyp)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  kdipol.i  --  forcefield parameters for bond dipoles  ##
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
      integer maxnd,maxnd5
      integer maxnd4,maxnd3
      parameter (maxnd=500)
      parameter (maxnd5=100)
      parameter (maxnd4=100)
      parameter (maxnd3=100)
      real*8 dpl,dpl5,dpl4,dpl3
      real*8 pos,pos5,pos4,pos3
      character*6 kd,kd5,kd4,kd3
      common /kdipol/ dpl(maxnd),dpl5(maxnd5),dpl4(maxnd4),dpl3(maxnd3),
     &                pos(maxnd),pos5(maxnd5),pos4(maxnd4),pos3(maxnd3),
     &                kd(maxnd),kd5(maxnd5),kd4(maxnd4),kd3(maxnd3)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  keys.i  --  contents of current keyword parameter 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
      integer nkey
      character*80 keyline
      common /keys/ nkey,keyline(maxkey)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  kgeoms.i  --  parameters for the geometrical restraints  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     depth      depth of shallow Gaussian basin restraint
c     width      exponential width coefficient of Gaussian basin
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       flat-well range and force constant for each position
c     dfix       target range and force constant for each distance
c     afix       target range and force constant for each angle
c     tfix       target range and force constant for each torsion
c     npfix      number of position restraints to be applied
c     ipfix      atom number involved in each position restraint
c     ndfix      number of distance restraints to be applied
c     idfix      atom numbers defining each distance restraint
c     nafix      number of angle restraints to be applied
c     iafix      atom numbers defining each angle restraint
c     ntfix      number of torsional restraints to be applied
c     itfix      atom numbers defining each torsional restraint
c     use_basin  logical flag governing use of Gaussian basin
c     use_wall   logical flag governing use of droplet boundary
c
c
      integer npfix,ipfix
      integer ndfix,idfix
      integer nafix,iafix
      integer ntfix,itfix
      real*8 depth,width,rwall
      real*8 xpfix,ypfix,zpfix
      real*8 pfix,dfix,afix,tfix
      logical use_basin,use_wall
      common /kgeoms/ depth,width,rwall,xpfix(maxfix),ypfix(maxfix),
     &                zpfix(maxfix),pfix(2,maxfix),dfix(3,maxfix),
     &                afix(3,maxfix),tfix(3,maxfix),npfix,ipfix(maxfix),
     &                ndfix,idfix(2,maxfix),nafix,iafix(3,maxfix),ntfix,
     &                itfix(4,maxfix),use_basin,use_wall
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  khbond.i  --  forcefield parameters for H-bonding terms  ##
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
      integer maxnhb
      parameter (maxnhb=200)
      real*8 radhb,epshb
      character*6 khb
      common /khbond/ radhb(maxnhb),epshb(maxnhb),khb(maxnhb)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  kiprop.i  --  forcefield parameters for improper dihedral  ##
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
      integer maxndi
      parameter (maxndi=200)
      real*8 dcon,tdi
      character*12 kdi
      common /kiprop/ dcon(maxndi),tdi(maxndi),kdi(maxndi)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  kitors.i  --  forcefield parameters for improper torsions  ##
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
      integer maxnti
      parameter (maxnti=200)
      real*8 ti1,ti2,ti3
      character*12 kti
      common /kitors/ ti1(2,maxnti),ti2(2,maxnti),ti3(2,maxnti),
     &                kti(maxnti)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  kmulti.i  --  forcefield parameters for atomic multipoles  ##
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
      integer maxnmp
      parameter (maxnmp=500)
      real*8 multip
      character*8 mpaxis
      character*9 kmp
      common /kmulti/ multip(13,maxnmp),mpaxis(maxnmp),kmp(maxnmp)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  kopbnd.i  --  forcefield parameters for out-of-plane bend  ##
c     ##                                                             ##
c     #################################################################
c
c
c     maxnopb   maximum number of out-of-plane bending entries
c
c     copb      force constant parameters for out-of-plane bending
c     kaopb     string of atom classes for out-of-plane bending
c
c
      integer maxnopb
      parameter (maxnopb=200)
      real*8 copb
      character*6 kaopb
      common /kopbnd/ copb(maxnopb),kaopb(maxnopb)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  kopdst.i  --  forcefield parameters for out-plane distance  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     maxnopb   maximum number of out-of-plane distance entries
c
c     copb      force constant parameters for out-of-plane distance
c     kaopb     string of atom classes for out-of-plane distance
c
c
      integer maxnopd
      parameter (maxnopd=200)
      real*8 copd
      character*12 kaopd
      common /kopdst/ copd(maxnopd),kaopd(maxnopd)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  korbs.i  --  forcefield parameters for pisystem orbitals  ##
c     ##                                                            ##
c     ################################################################
c
c
c     maxnpi     maximum number of pisystem bond parameter 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     tslope     slope for 2-fold torsion vs. pi-bond order
c     kpi        string of atom classes for pisystem bonds
c
c
      integer maxnpi
      parameter (maxnpi=100)
      real*8 electron,ionize,repulse
      real*8 sslope,tslope
      character*6 kpi
      common /korbs/ electron(maxclass),ionize(maxclass),
     &               repulse(maxclass),sslope(maxnpi),tslope(maxnpi),
     &               kpi(maxnpi)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  kpolr.i  --  forcefield parameters for polarizability  ##
c     ##                                                         ##
c     #############################################################
c
c
c     polr   dipole polarizability parameters for each atom type
c     pgrp   connected types in polarization group of each atom type
c
c
      integer pgrp
      real*8 polr
      common /kpolr/ polr(maxtyp),pgrp(maxval,maxtyp)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  kstbnd.i  --  forcefield parameters for stretch-bending  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     stbn   stretch-bending parameters for each atom class
c
c
      real*8 stbn
      common /kstbnd/ stbn(3,maxclass)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  ksttor.i  --  forcefield parameters for stretch-torsions  ##
c     ##                                                            ##
c     ################################################################
c
c
c     maxnbt   maximum number of stretch-torsion parameter entries
c
c     btcon    force constant parameters for stretch-torsion
c     kbt      string of atom classes for bonds in stretch-torsion
c
c
      integer maxnbt
      parameter (maxnbt=200)
      real*8 btcon
      character*6 kbt
      common /ksttor/ btcon(3,maxnbt),kbt(maxnbt)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  ktorsn.i  --  forcefield parameters for torsional angles  ##
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
      integer maxnt,maxnt5,maxnt4
      parameter (maxnt=2000)
      parameter (maxnt5=300)
      parameter (maxnt4=100)
      real*8 t1,t2,t3,t4,t5,t6
      real*8 t15,t25,t35,t45,t55,t65
      real*8 t14,t24,t34,t44,t54,t64
      character*12 kt,kt5,kt4
      common /ktorsn/ t1(2,maxnt),t2(2,maxnt),t3(2,maxnt),
     &                t4(2,maxnt),t5(2,maxnt),t6(2,maxnt),
     &                t15(2,maxnt5),t25(2,maxnt5),t35(2,maxnt5),
     &                t45(2,maxnt5),t55(2,maxnt5),t65(2,maxnt5),
     &                t14(2,maxnt4),t24(2,maxnt4),t34(2,maxnt4),
     &                t44(2,maxnt4),t54(2,maxnt4),t64(2,maxnt4),
     &                kt(maxnt),kt5(maxnt5),kt4(maxnt4)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  kurybr.i  --  forcefield parameters for Urey-Bradley terms  ##
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
      integer maxnu
      parameter (maxnu=200)
      real*8 ucon,dst13
      character*9 ku
      common /kurybr/ ucon(maxnu),dst13(maxnu),ku(maxnu)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  kvdwpr.i  --  forcefield parameters for special vdw terms  ##
c     ##                                                             ##
c     #################################################################
c
c
c     maxnvp   maximum number of special van der Waals pair 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
      integer maxnvp
      parameter (maxnvp=200)
      real*8 radpr,epspr
      character*6 kvpr
      common /kvdwpr/ radpr(maxnvp),epspr(maxnvp),kvpr(maxnvp)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  kvdws.i  --  forcefield parameters for van der Waals terms  ##
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
      real*8 rad,eps,rad4,eps4,reduct
      common /kvdws/ rad(maxclass),eps(maxclass),rad4(maxclass),
     &               eps4(maxclass),reduct(maxclass)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  light.i  --  indices for method of lights pair neighbors  ##
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    pointer from x-sorted list into original interaction list
c     locy    pointer from y-sorted list into original interaction list
c     locz    pointer from z-sorted list into original interaction list
c     rgx     pointer from original interaction list into x-sorted list
c     rgy     pointer from original interaction list into y-sorted list
c     rgz     pointer from original interaction list into z-sorted list
c
c
      integer nlight,kbx,kby,kbz
      integer kex,key,kez
      integer locx,locy,locz
      integer rgx,rgy,rgz
      common /light/ nlight,kbx(maxatm),kby(maxatm),kbz(maxatm),
     &               kex(maxatm),key(maxatm),kez(maxatm),
     &               locx(maxlight),locy(maxlight),locz(maxlight),
     &               rgx(maxlight),rgy(maxlight),rgz(maxlight)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  linmin.i  --  parameters for line search minimization  ##
c     ##                                                         ##
c     #############################################################
c
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     angmax   maximum angle between search direction and -gradient
c     intmax   maximum number of inner iterations during line search
c
c
      integer intmax
      real*8 stpmin,stpmax
      real*8 cappa,angmax
      common /linmin/ stpmin,stpmax,cappa,angmax,intmax
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  math.i  --  mathematical and geometrical constants  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     radian   conversion factor from radians to degrees
c     pi       numerical value of the geometric constant
c     sqrtpi   numerical value of the square root of Pi
c     logten   numerical value of the natural log of ten
c     twosix   numerical value of the sixth root of two
c
c
      real*8 radian,pi,sqrtpi
      real*8 logten,twosix
      parameter (radian=57.29577951308232088d0)
      parameter (pi=3.141592653589793238d0)
      parameter (sqrtpi=1.772453850905516027d0)
      parameter (logten=2.302585092994045684d0)
      parameter (twosix=1.122462048309372981d0)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  mdstuf.i  --  control of molecular dynamics trajectory  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     nfree       total number of degrees of freedom for a system
c     velsave     flag to save atomic velocity components to a file
c     uindsave    flag to save induced atomic dipoles to a file
c     integrate   type of molecular dynamics integration algorithm
c
c
      integer nfree
      logical velsave,uindsave
      character*10 integrate
      common /mdstuf/ nfree,velsave,uindsave,integrate
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##########################################################
c     ##                                                      ##
c     ##  minima.i  --  general parameters for minimizations  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     fctmin    value below which function is deemed optimized
c     hguess    initial value for the H-matrix diagonal elements
c     maxiter   maximum number of iterations during optimization
c     nextiter  iteration number to use for the first iteration
c
c
      integer maxiter,nextiter
      real*8 fctmin,hguess
      common /minima/ fctmin,hguess,maxiter,nextiter
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  molcul.i  --  individual molecules within current system  ##
c     ##                                                            ##
c     ################################################################
c
c
c     molmass   molecular weight for each molecule in the system
c     totmass   total weight of all the molecules in the system
c     nmol      total number of separate molecules in the system
c     kmol      contiguous list of the atoms in each molecule
c     imol      first and last atom of each molecule in the list
c     molcule   number of the molecule to which each atom belongs
c
c
      integer nmol,kmol,imol,molcule
      real*8 molmass,totmass
      common /molcul/ molmass(maxatm),totmass,nmol,kmol(maxatm),
     &                imol(2,maxatm),molcule(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  moldyn.i  --  velocity and acceleration on MD trajectory  ##
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     aold    previous acceleration of each atom along x,y,z-axes
c
c
      real*8 v,a,aold
      common /moldyn/ v(3,maxatm),a(3,maxatm),aold(3,maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  moment.i  --  components of electric multipole moments  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     netchg   net electric charge for the total system
c     netdpl   dipole moment magnitude for the total system
c     netqdp   diagonal quadrupole (Qxx, Qyy, Qzz) for system
c     xdpl     dipole vector x-component in the global frame
c     ydpl     dipole vector y-component in the global frame
c     zdpl     dipole vector z-component in the global frame
c     xxqdp    quadrupole tensor xx-component in global frame
c     xyqdp    quadrupole tensor xy-component in global frame
c     xzqdp    quadrupole tensor xz-component in global frame
c     yxqdp    quadrupole tensor yx-component in global frame
c     yyqdp    quadrupole tensor yy-component in global frame
c     yzqdp    quadrupole tensor yz-component in global frame
c     zxqdp    quadrupole tensor zx-component in global frame
c     zyqdp    quadrupole tensor zy-component in global frame
c     zzqdp    quadrupole tensor zz-component in global frame
c
c
      real*8 netchg,netdpl,netqdp
      real*8 xdpl,ydpl,zdpl
      real*8 xxqdp,xyqdp,xzqdp
      real*8 yxqdp,yyqdp,yzqdp
      real*8 zxqdp,zyqdp,zzqdp
      common /moment/ netchg,netdpl,netqdp(3),xdpl,ydpl,zdpl,xxqdp,
     &                xyqdp,xzqdp,yxqdp,yyqdp,yzqdp,zxqdp,zyqdp,zzqdp
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2001  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  mplpot.i  --  specifics of atomic multipole functions  ##
c     ##                                                         ##
c     #############################################################
c
c
c     m2scale   factor by which 1-2 multipole interactions are scaled
c     m3scale   factor by which 1-3 multipole interactions are scaled
c     m4scale   factor by which 1-4 multipole interactions are scaled
c     m5scale   factor by which 1-5 multipole interactions are scaled
c
c
      real*8 m2scale,m3scale
      real*8 m4scale,m5scale
      common /mplpot/ m2scale,m3scale,m4scale,m5scale
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  mpole.i  --  multipole components for current structure  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     maxpole   max components (monopole=1,dipole=4,quadrupole=13)
c
c     pole      multipole values for each site in the local frame
c     rpole     multipoles rotated to the global coordinate system
c     npole     total number of multipole sites in the system
c     ipole     number of the atom for each multipole site
c     polsiz    number of mutipole components at each multipole site
c     zaxis     number of the z-axis defining atom for each site
c     xaxis     number of the x-axis defining atom for each site
c     polaxe    local axis type for each multipole site
c
c
      integer maxpole
      parameter (maxpole=13)
      integer npole,ipole
      integer polsiz
      integer zaxis,xaxis
      real*8 pole,rpole
      character*8 polaxe
      common /mpole/ pole(maxpole,maxatm),rpole(maxpole,maxatm),npole,
     &               ipole(maxatm),polsiz(maxatm),zaxis(maxatm),
     &               xaxis(maxatm),polaxe(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  mutant.i  --  hybrid atoms for free energy perturbation  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     lambda    weighting of initial state in hybrid Hamiltonian
c     nhybrid   number of atoms mutated from initial to final state
c     ihybrid   atomic 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     alter     true if an atom is to be mutated, false otherwise
c
c
      integer nhybrid,ihybrid(maxatm)
      integer type0(maxatm),class0(maxatm)
      integer type1(maxatm),class1(maxatm)
      real*8 lambda
      logical alter(maxatm)
      common /mutant/ lambda,nhybrid,ihybrid,type0,class0,
     &                type1,class1,alter
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     ##  nucleo.i  --  parameters for nucleic acid structure  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     bkbone    phosphate backbone angles for each nucleotide
c     glyco     glycosidic torsional angle for each nucleotide
c     pucker    sugar pucker, either 2=2'-endo or 3=3'-endo
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
      integer pucker
      real*8 bkbone,glyco
      logical dblhlx,deoxy
      character*1 hlxform
      common /nucleo/ bkbone(6,maxres),glyco(maxres),pucker(maxres),
     &                dblhlx,deoxy(maxres),hlxform
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  omega.i  --  dihedrals for torsional space computations  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     dihed    current value in radians of each dihedral angle
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
c
      integer nomega,iomega,zline
      real*8 dihed
      common /omega/ dihed(maxrot),nomega,iomega(2,maxrot),
     &               zline(maxrot)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  opbend.i  --  out-of-plane bends in the current structure  ##
c     ##                                                             ##
c     #################################################################
c
c
c     kopb      force constant values for out-of-plane bending
c     nopbend   total number of out-of-plane bends in the system
c     iopb      bond angle numbers used in out-of-plane bending
c
c
      integer nopbend,iopb
      real*8 kopb
      common /opbend/ kopb(maxang),nopbend,iopb(maxang)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  opdist.i  --  out-of-plane distances in current structure  ##
c     ##                                                             ##
c     #################################################################
c
c
c     kopd      force constant values for out-of-plane distance
c     nopdist   total number of out-of-plane distances in the system
c     iopb      numbers of the atoms in each out-of-plane distance
c
c
      integer nopdist,iopd
      real*8 kopd
      common /opdist/ kopd(maxatm),nopdist,iopd(4,maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  orbits.i  --  orbital energies for conjugated pisystem  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     q       number of pi-electrons contributed by each atom
c     w       ionization potential of each pisystem atom
c     em      repulsion integral for each pisystem atom
c     nfill   number of filled pisystem molecular orbitals
c
c
      integer nfill
      real*8 q,w,em
      common /orbits/ q(maxpi),w(maxpi),em(maxpi),nfill
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  output.i  --  control of coordinate output file format  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     archive    logical flag to save structures in an archive
c     noversion  logical flag governing use of filename versions
c     overwrite  logical flag to overwrite intermediate files inplace
c     cyclesave  logical flag to mark use of numbered cycle files
c     coordtype  selects Cartesian, internal, rigid body or none
c
c
      logical archive,noversion
      logical overwrite,cyclesave
      character*9 coordtype
      common /output/ archive,noversion,overwrite,cyclesave,coordtype
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  paths.i  --  parameters for Elber reaction path method  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     p0       reactant Cartesian coordinates as variables
c     p1       product Cartesian coordinates as variables
c     pmid     midpoint between the reactant and product
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     pnorm    length of the reactant-product vector
c     acoeff   transformation matrix 'A' from Elber paper
c     gc       gradients of the path constraints
c
c
      real*8 p0,p1,pmid
      real*8 pvect,pstep
      real*8 pzet,pnorm
      real*8 acoeff,gc
      common /paths/ p0(maxvar),p1(maxvar),pmid(maxvar),pvect(maxvar),
     &               pstep(maxvar),pzet(maxvar),pnorm,acoeff(7,7),
     &               gc(maxvar,7)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  pdb.i  --  definition of a Protein Data Bank structure  ##
c     ##                                                          ##
c     ##############################################################
c
c
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     npdb      number of atoms stored in Protein Data Bank format
c     resnum    number of the residue to which each atom belongs
c     npdb12    number of atoms directly bonded to each CONECT atom
c     ipdb12    atom numbers of atoms connected to each CONECT atom
c     pdblist   list of the Protein Data Bank atom number of each atom
c     pdbtyp    Protein Data Bank record type assigned to each atom
c     atmnam    Protein Data Bank atom name assigned to each atom
c     resnam    Protein Data Bank residue name assigned to each atom
c
c
      integer npdb,resnum
      integer npdb12,ipdb12
      integer pdblist
      real*8 xpdb,ypdb,zpdb
      character*3 resnam
      character*4 atmnam
      character*6 pdbtyp
      common /pdb/ xpdb(maxatm),ypdb(maxatm),zpdb(maxatm),npdb,
     &             resnum(maxatm),npdb12(maxatm),ipdb12(maxval,maxatm),
     &             pdblist(maxatm),pdbtyp(maxatm),atmnam(maxatm),
     &             resnam(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  phipsi.i  --  phi-psi-omega-chi angles for a protein  ##
c     ##                                                        ##
c     ############################################################
c
c
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     omega    value of the omega angle for each amino acid residue
c     chi      values of the chi angles for each amino acid residue
c     chiral   chirality of each amino acid residue (1=L, -1=D)
c     disulf   residue joined to each residue via a disulfide link
c
c
      integer chiral,disulf
      real*8 phi,psi,omega,chi
      common /phipsi/ phi(maxres),psi(maxres),omega(maxres),
     &                chi(4,maxres),chiral(maxres),disulf(maxres)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  piorbs.i  --  conjugated system in the current structure  ##
c     ##                                                            ##
c     ################################################################
c
c
c     norbit    total number of pisystem orbitals in the system
c     iorbit    numbers of the atoms containing pisystem orbitals
c     reorbit   number of evaluations between orbital updates
c     piperp    atoms defining a normal plane to each orbital
c     npibond   total number of bonds affected by the pisystem
c     pibond    bond and piatom numbers for each pisystem bond
c     npitors   total number of torsions affected by the pisystem
c     pitors    torsion and pibond numbers for each pisystem torsion
c     listpi    atom list indicating whether each atom has an orbital
c
c
      integer norbit,iorbit
      integer reorbit,piperp
      integer npibond,pibond
      integer npitors,pitors
      logical listpi
      common /piorbs/ norbit,iorbit(maxpi),reorbit,piperp(3,maxpi),
     &                npibond,pibond(3,maxpib),npitors,pitors(2,maxpit),
     &                listpi(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  pistuf.i  --  bonds and torsions in the current pisystem  ##
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     torspi   2-fold torsional energy barrier for pi-bond order of 1.0
c
c
      real*8 bkpi,blpi
      real*8 kslope,lslope
      real*8 torspi
      common /pistuf/ bkpi(maxpib),blpi(maxpib),kslope(maxpib),
     &                lslope(maxpib),torspi(maxpit)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  pme.i  --  parameters for particle mesh Ewald summation  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     maxfft     maximum number of points along each FFT direction
c     maxorder   maximum order of the B-spline approximation
c     maxtable   maximum size of the FFT table array
c     maxgrid    maximum dimension of the PME charge grid array
c
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     table      intermediate array used by the FFT calculation
c     nfft1      number of grid points along the a-axis direction
c     nfft2      number of grid points along the b-axis direction
c     nfft3      number of grid points along the c-axis direction
c     bsorder    order of the PME B-spline approximation
c
c
      integer maxfft,maxorder,maxtable,maxgrid
      parameter (maxfft=80)
      parameter (maxorder=12)
      parameter (maxtable=4*maxfft+15)
      parameter (maxgrid=2*(maxfft/2)+1)
      integer nfft1,nfft2,nfft3,bsorder
      real*8 bsmod1,bsmod2,bsmod3
      real*8 table,qgrid
      common /pme/ bsmod1(maxfft),bsmod2(maxfft),bsmod3(maxfft),
     &             table(maxtable,3),qgrid(2,maxgrid,maxgrid,maxgrid),
     &             nfft1,nfft2,nfft3,bsorder
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  polar.i  --  polarizabilities and induced dipole moments  ##
c     ##                                                            ##
c     ################################################################
c
c
c     polarity  dipole polarizability for each multipole site (Ang**3)
c     pdamp     value of polarizability damping factor for each site
c     uind      induced dipole components at each multipole site
c     uinp      induced dipoles in field used for energy interactions
c     npolar    total number of polarizable sites in the system
c
c
      integer npolar
      real*8 polarity,pdamp
      real*8 uind,uinp
      common /polar/ polarity(maxatm),pdamp(maxatm),uind(3,maxatm),
     &               uinp(3,maxatm),npolar
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2001  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  polgrp.i  --  polarizable site 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     ip11     atom numbers of atoms in same group as each atom
c     np12     number of atoms in groups 1-2 to each atom
c     ip12     atom numbers of atoms in groups 1-2 to each atom
c     np13     number of atoms in groups 1-3 to each atom
c     ip13     atom numbers of atoms in groups 1-3 to each atom
c     np14     number of atoms in groups 1-4 to each atom
c     ip14     atom numbers of atoms in groups 1-4 to each atom
c
c
      integer maxp11,maxp12
      integer maxp13,maxp14
      parameter (maxp11=20)
      parameter (maxp12=30)
      parameter (maxp13=30)
      parameter (maxp14=30)
      integer np11,ip11,np12,ip12
      integer np13,ip13,np14,ip14
      common /polgrp/ np11(maxatm),ip11(maxp11,maxatm),
     &                np12(maxatm),ip12(maxp12,maxatm),
     &                np13(maxatm),ip13(maxp13,maxatm),
     &                np14(maxatm),ip14(maxp14,maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  polpot.i  --  specifics of polarization functional form  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     poleps    induced dipole convergence criterion (rms Debyes/atom)
c     polsor    induced dipole SOR convergence acceleration factor
c     pgamma    prefactor in exponential polarization damping term
c     p2scale   field 1-2 scale factor for energy evaluations
c     p3scale   field 1-3 scale factor for energy evaluations
c     p4scale   field 1-4 scale factor for energy evaluations
c     p5scale   field 1-5 scale factor for energy evaluations
c     d1scale   field intra-group scale factor for direct induced
c     d2scale   field 1-2 group scale factor for direct induced
c     d3scale   field 1-3 group scale factor for direct induced
c     d4scale   field 1-4 group scale factor for direct induced
c     u1scale   field intra-group scale factor for mutual induced
c     u2scale   field 1-2 group scale factor for mutual induced
c     u3scale   field 1-3 group scale factor for mutual induced
c     u4scale   field 1-4 group scale factor for mutual induced
c     poltyp    type of polarization potential (direct or mutual)
c
c
      real*8 poleps
      real*8 polsor,pgamma
      real*8 p2scale,p3scale
      real*8 p4scale,p5scale
      real*8 d1scale,d2scale
      real*8 d3scale,d4scale
      real*8 u1scale,u2scale
      real*8 u3scale,u4scale
      character*6 poltyp
      common /polpot/ poleps,polsor,pgamma,p2scale,p3scale,p4scale,
     &                p5scale,d1scale,d2scale,d3scale,d4scale,u1scale,
     &                u2scale,u3scale,u4scale,poltyp
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  potent.i  --  usage of each potential energy component  ##
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_strtor  logical flag governing use of stretch-torsion term
c     use_tortor  logical flag governing use of torsion-torsion term
c     use_vdw     logical flag governing use of vdw der Waals 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_rxnfld  logical flag governing use of reaction field term
c     use_solv    logical flag governing use of surface area solvation
c     use_gbsa    logical flag governing use of GB/SA 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_orbit   logical flag governing use of pisystem computation
c
c
      logical use_bond,use_angle,use_strbnd
      logical use_urey,use_angang,use_opbend
      logical use_opdist,use_improp,use_imptor
      logical use_tors,use_strtor,use_tortor
      logical use_vdw,use_charge,use_chgdpl
      logical use_dipole,use_mpole,use_polar
      logical use_rxnfld,use_solv,use_gbsa
      logical use_metal,use_geom,use_extra
      logical use_orbit
      common /potent/ use_bond,use_angle,use_strbnd,use_urey,use_angang,
     &                use_opbend,use_opdist,use_improp,use_imptor,
     &                use_tors,use_strtor,use_tortor,use_vdw,use_charge,
     &                use_chgdpl,use_dipole,use_mpole,use_polar,
     &                use_rxnfld,use_solv,use_gbsa,use_metal,use_geom,
     &                use_extra,use_orbit
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  precis.i  --  values of machine precision tolerances  ##
c     ##                                                        ##
c     ############################################################
c
c
c     tiny    the smallest positive floating point value
c     small   the smallest relative floating point spacing
c     huge    the largest relative floating point spacing
c
c
      real*8 tiny,small,huge
      common /precis/ tiny,small,huge
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  refer.i  --  storage of reference atomic coordinate set  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     xref        reference x-coordinate for each atom in the system
c     yref        reference y-coordinate for each atom in the system
c     zref        reference z-coordinate for each atom in the system
c     nref        total number of atoms in the reference system
c     reftyp      atom type for each atom in the 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     refleng     length in characters of the reference filename
c     refltitle   length in characters of the reference title string
c     refnam      atom name for each atom in the reference system
c     reffile     base filename for the reference structure
c     reftitle    title used to describe the reference structure
c
c
      integer nref,reftyp
      integer n12ref,i12ref
      integer refleng,refltitle
      real*8 xref,yref,zref
      character*3 refnam
      character*60 reffile,reftitle
      common /refer/ xref(maxatm),yref(maxatm),zref(maxatm),nref,
     &               reftyp(maxatm),n12ref(maxatm),
     &               i12ref(maxval,maxatm),refleng,refltitle,
     &               refnam(maxatm),reffile,reftitle
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  resdue.i  --  standard biopolymer residue abbreviations  ##
c     ##                                                           ##
c     ###############################################################
c
c
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
      character*1 amino1,nuclz1
      character*3 amino,nuclz
      common /resdue/ amino(maxamino),nuclz(maxnuc),amino1(maxamino),
     &                nuclz1(maxnuc)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2001  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  rgddyn.i  --  velocities and momenta for rigid-body MD  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     vcm     current translational velocity of each rigid-body
c     wcm     current angular velocity of each rigid-body
c     lm      current angular momenta of each rigid-body
c     linear  logical flag to mark group as linear or nonlinear
c
c
      real*8 vcm,wcm,lm
      logical linear
      common /rgddyn/ vcm(3,maxgrp),wcm(3,maxgrp),lm(3,maxgrp),
     &                linear(maxgrp)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  rigid.i  --  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 atom group
c
c
      real*8 xrb,yrb,zrb,rbc
      common /rigid/ xrb(maxatm),yrb(maxatm),zrb(maxatm),rbc(6,maxgrp)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  ring.i  --  number and location of small ring structures  ##
c     ##                                                            ##
c     ################################################################
c
c
c     nring3   total number of 3-membered rings in the system
c     iring3   numbers of the atoms involved in each 3-ring
c     nring4   total number of 4-membered rings in the system
c     iring4   numbers of the atoms involved in each 4-ring
c     nring5   total number of 5-membered rings in the system
c     iring5   numbers of the atoms involved in each 5-ring
c     nring6   total number of 6-membered rings in the system
c     iring6   numbers of the atoms involved in each 6-ring
c
c
      integer nring3,iring3
      integer nring4,iring4
      integer nring5,iring5
      integer nring6,iring6
      common /ring/ nring3,iring3(3,maxring),nring4,iring4(4,maxring),
     &              nring5,iring5(5,maxring),nring6,iring6(6,maxring)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  rotate.i  --  molecule partitions for rotation of a bond  ##
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
      integer nrot,rot
      logical use_short
      common /rotate/ nrot,rot(maxatm),use_short
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  rxnfld.i  --  reaction field matrix elements and indices  ##
c     ##                                                            ##
c     ################################################################
c
c
c     b1
c     b2
c     ijk
c
c
      integer ijk
      real*8 b1,b2
      common /b1b2/ b1(40,13),b2(40,13),ijk(0:5,0:5,0:5)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  rxnpot.i  --  specifics of reaction field functional form  ##
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
      integer rfterms
      real*8 rfsize,rfbulkd
      common /rxnpot/ rfsize,rfbulkd,rfterms
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  scales.i  --  parameter scale factors for optimization  ##
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
      real*8 scale
      logical set_scale
      common /scales/ scale(maxvar),set_scale
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  sequen.i  --  sequence information for a 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     seq      three-letter code for each residue in the sequence
c     chnnam   one-letter identifier for each sequence chain
c
c
      integer nseq,seqtyp
      integer nchain,ichain
      character*1 chnnam
      character*3 seq
      common /sequen/ nseq,nchain,ichain(2,maxres),seqtyp(maxres),
     &                seq(maxres),chnnam(maxres)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  shake.i  --  definition of Shake/Rattle constraints  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     krat         ideal distance value for rattle constraint
c     nrat         number of rattle constraints to be applied
c     irat         atom numbers of atoms in a rattle constraint
c     ratimage     flag to use minimum image for rattle constraint
c     use_rattle   logical flag to set use of rattle contraints
c
c
      integer nrat,irat
      real*8 krat
      logical ratimage,use_rattle
      common /shake/ krat(maxbnd),nrat,irat(2,maxbnd),ratimage(maxbnd),
     &               use_rattle
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  shunt.i  --  polynomial switching function coefficients  ##
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
      real*8 off,off2,cut,cut2
      real*8 c0,c1,c2,c3,c4,c5
      real*8 f0,f1,f2,f3,f4,f5,f6,f7
      common /shunt/ off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,
     &               f0,f1,f2,f3,f4,f5,f6,f7
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  sizes.i  --  parameter values to set array dimensions  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "sizes.i" sets values for critical array dimensions used
c     throughout the software; these parameters will fix the size
c     of the largest systems that can be handled; values too large
c     for the computer's memory and/or swap space to accomodate
c     will result in poor performance or outright failure
c
c     parameter:      maximum allowed number of:
c
c     maxatm          atoms in the molecular system
c     maxval          atoms directly bonded to an atom
c     maxgrp          user-defined groups of atoms
c     maxtyp          force field atom type definitions
c     maxclass        force field atom class definitions
c     maxkey          lines in the keyword file
c     maxrot          bonds for torsional rotation
c     maxvar          optimization variables (vector storage)
c     maxopt          optimization variables (matrix storage)
c     maxhess         off-diagonal Hessian elements
c     maxlight        sites for method of lights neighbors
c     maxvib          vibrational frequencies
c     maxgeo          distance geometry points
c     maxcell         unit cells in replicated crystal
c     maxring         3-, 4-, or 5-membered rings
c     maxfix          geometric restraints
c     maxbio          biopolymer atom definitions
c     maxres          residues in the macromolecule
c     maxamino        amino acid residue types
c     maxnuc          nucleic acid residue types
c     maxbnd          covalent bonds in molecular system
c     maxang          bond angles in molecular system
c     maxtors         torsional angles in molecular system
c     maxpi           atoms in conjugated pisystem
c     maxpib          covalent bonds involving pisystem
c     maxpit          torsional angles involving pisystem
c
c
      integer maxatm,maxval,maxgrp
      integer maxtyp,maxclass,maxkey
      integer maxrot,maxvar,maxopt
      integer maxhess,maxlight,maxvib
      integer maxgeo,maxcell,maxring
      integer maxfix,maxbio,maxres
      integer maxamino,maxnuc,maxbnd
      integer maxang,maxtors,maxpi
      integer maxpib,maxpit
      parameter (maxatm=10000)
      parameter (maxval=4)
      parameter (maxgrp=1000)
      parameter (maxtyp=3000)
      parameter (maxclass=500)
      parameter (maxkey=10000)
      parameter (maxrot=1000)
      parameter (maxvar=3*maxatm)
      parameter (maxopt=1000)
      parameter (maxhess=1000000)
      parameter (maxlight=8*maxatm)
      parameter (maxvib=1000)
      parameter (maxgeo=1000)
      parameter (maxcell=10000)
      parameter (maxring=10000)
      parameter (maxfix=10000)
      parameter (maxbio=10000)
      parameter (maxres=1000)
      parameter (maxamino=31)
      parameter (maxnuc=12)
      parameter (maxbnd=2*maxatm)
      parameter (maxang=3*maxatm)
      parameter (maxtors=4*maxatm)
      parameter (maxpi=100)
      parameter (maxpib=2*maxpi)
      parameter (maxpit=4*maxpi)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  solute.i  --  parameters for continuum solvation models  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     rsolv    atomic radius of each atom for continuum solvation
c     vsolv    atomic volume of each atom for continuum solvation
c     asolv    atomic solvation parameters (kcal/mole/Ang**2)
c     rborn    Born radius of each atom for GB/SA solvation
c     drb      solvation derivatives with respect to Born radii
c     doffset  dielectric offset to continuum solvation atomic radii
c     p1       single-atom scale factor for analytical Still GB/SA
c     p2       1-2 interaction scale factor for analytical Still GB/SA
c     p3       1-3 interaction scale factor for analytical Still GB/SA
c     p4       nonbonded scale factor for analytical Still GB/SA
c     p5       soft cutoff parameter for analytical Still GB/SA
c     gpol     polarization self-energy values for each atom
c     shct     overlap scaling factors for Hawkins-Cramer-Truhlar GB/SA
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     solvtyp  solvation model (ASP, SASA, ONION, STILL, HCT, ACE)
c
c
      real*8 rsolv,vsolv,asolv
      real*8 rborn,drb,doffset
      real*8 p1,p2,p3,p4,p5,gpol
      real*8 shct,wace,s2ace,uace
      character*5 solvtyp
      common /solute/ rsolv(maxatm),vsolv(maxatm),asolv(maxatm),
     &                rborn(maxatm),drb(maxatm),doffset,p1,p2,p3,p4,p5,
     &                gpol(maxatm),shct(maxatm),wace(maxclass,maxclass),
     &                s2ace(maxclass,maxclass),uace(maxclass,maxclass),
     &                solvtyp
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  stodyn.i  --  frictional coefficients for SD trajectory  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     friction    global frictional coefficient for exposed particle
c     gamma       atomic frictional coefficients for each atom
c     use_sdarea  logical flag to use surface area friction scaling
c
c
      real*8 friction,gamma
      logical use_sdarea
      common /stodyn/ friction,gamma(maxatm),use_sdarea
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  strbnd.i  --  stretch-bends in the current structure  ##
c     ##                                                        ##
c     ############################################################
c
c
c     ksb       force constant for stretch-bend terms
c     nstrbnd   total number of stretch-bend interactions
c     isb       angle and bond numbers used in stretch-bend
c
c
      integer nstrbnd,isb
      real*8 ksb
      common /strbnd/ ksb(maxang),nstrbnd,isb(3,maxang)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  strtor.i  --  stretch-torsions in the current structure  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     kst       1-, 2- and 3-fold stretch-torsion force constants
c     nstrtor   total number of stretch-torsion interactions
c     ist       torsion and bond numbers used in stretch-torsion
c
c
      integer nstrtor,ist
      real*8 kst
      common /strtor/ kst(3,maxtors),nstrtor,ist(2,maxtors)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  syntrn.i  --  definition of synchronous transit path  ##
c     ##                                                        ##
c     ############################################################
c
c
c     t      value of the path coordinate (0=reactant, 1=product)
c     pm     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
      real*8 t,pm,xmin1,xmin2,xm
      common /syntrn/ t,pm,xmin1(maxvar),xmin2(maxvar),xm(maxvar)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  titles.i  --  title for the 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
      integer ltitle
      character*60 title
      common /titles/ ltitle,title
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  torpot.i  --  specifics of torsional functional forms  ##
c     ##                                                         ##
c     #############################################################
c
c
c     idihunit  convert improper dihedral force to kcal/mole/deg**2
c     itorunit  convert improper torsion amplitudes to kcal/mole
c     torsunit  convert torsional parameter amplitudes to kcal/mole
c     storunit  convert stretch-torsion force to kcal/mole/Ang
c
c
      real*8 idihunit,itorunit
      real*8 torsunit,storunit
      common /torpot/ idihunit,itorunit,torsunit,storunit
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  tors.i  --  torsional angles within the current structure  ##
c     ##                                                             ##
c     #################################################################
c
c
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     ntors   total number of torsional angles in the system
c     itors   numbers of the atoms in each torsional angle
c
c
      integer ntors,itors
      real*8 tors1,tors2,tors3
      real*8 tors4,tors5,tors6
      common /tors/ tors1(4,maxtors),tors2(4,maxtors),tors3(4,maxtors),
     &              tors4(4,maxtors),tors5(4,maxtors),tors6(4,maxtors),
     &              ntors,itors(4,maxtors)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  tree.i  --  potential smoothing & search tree levels  ##
c     ##                                                        ##
c     ############################################################
c
c
c     maxpss   maximum number of potential smoothing levels
c
c     etree    energy reference value at the top of the tree
c     ilevel   smoothing deformation value at each tree level
c     nlevel   number of levels of potential smoothing used
c
c
      integer maxpss
      parameter (maxpss=500)
      integer nlevel
      real*8 etree,ilevel
      common /tree/ etree,ilevel(0:maxpss),nlevel
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  units.i  --  physical constants and unit conversions  ##
c     ##                                                        ##
c     ############################################################
c
c
c     avogadro    Avogadro's number (N) in particles/mole
c     boltzmann   Boltzmann constant (kB) in g*Ang**2/ps**2/K/mole
c     gasconst    ideal gas constant (R) in kcal/mole/K
c     lightspd    speed of light in vacuum (c) in cm/ps
c     bohr        conversion from Bohrs to Angstroms
c     joule       conversion from calories to joules
c     evolt       conversion from Hartree to electron-volts
c     hartree     conversion from Hartree to kcal/mole
c     electric    conversion from electron**2/Ang to kcal/mole
c     debye       conversion from electron-Ang to Debyes
c     prescon     conversion from kcal/mole/Ang**3 to Atm
c     convert     conversion from kcal to g*Ang**2/ps**2
c
c
      real*8 avogadro,boltzmann
      real*8 gasconst,lightspd
      real*8 bohr,joule,evolt
      real*8 hartree,electric
      real*8 debye,prescon,convert
      parameter (avogadro=6.022045d+23)
      parameter (boltzmann=0.83143435d0)
      parameter (gasconst=1.98717623d-3)
      parameter (lightspd=2.99792458d-2)
      parameter (bohr=0.529177249d0)
      parameter (joule=4.184d0)
      parameter (evolt=27.2107d0)
      parameter (hartree=627.503d0)
      parameter (electric=332.05382d0)
      parameter (debye=4.8033324d0)
      parameter (prescon=6.85695d+4)
      parameter (convert=4.184d+2)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  urey.i  --  Urey-Bradley interactions in the structure  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     uk      Urey-Bradley force constants (kcal/mole/Ang**2)
c     ul      ideal 1-3 distance values in Angstroms
c     nurey   total number of Urey-Bradley terms in the system
c     iury    numbers of the atoms in each Urey-Bradley interaction
c
c
      integer nurey,iury
      real*8 uk,ul
      common /urey/ uk(maxang),ul(maxang),nurey,iury(2,maxang)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  2000  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  urypot.i  --  specifics of Urey-Bradley functional form  ##
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 constant to kcal/mole/Ang**2
c
c
      real*8 cury,qury
      real*8 ureyunit
      common /urypot/ cury,qury,ureyunit
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  usage.i  --  atoms active during energy computation  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     nuse   number of active atoms used in energy calculation
c     use    true if an atom is active, false if inactive
c
c
      integer nuse
      logical use
      common /usage/ nuse,use(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  vdw.i  --  van der Waals parameters for current structure  ##
c     ##                                                             ##
c     #################################################################
c
c
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     kred       value of reduction factor parameter for each atom
c     ired       attached atom from which reduction factor is applied
c     nvdw       total number van der Waals active sites in the system
c     ivdw       number of the atom for each van der Waals active site
c
c
      integer ired,nvdw,ivdw
      real*8 radmin,epsilon
      real*8 radmin4,epsilon4
      real*8 radhbnd,epshbnd,kred
      common /vdw/ radmin(maxclass,maxclass),
     &             epsilon(maxclass,maxclass),
     &             radmin4(maxclass,maxclass),
     &             epsilon4(maxclass,maxclass),
     &             radhbnd(maxclass,maxclass),
     &             epshbnd(maxclass,maxclass),
     &             kred(maxatm),ired(maxatm),
     &             nvdw,ivdw(maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  vdwpot.i  --  specifics of van der Waals functional form  ##
c     ##                                                            ##
c     ################################################################
c
c
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     igauss     coefficients of Gaussian fit to vdw potential
c     ngauss     number of Gaussians used in fit to vdw potential
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
      integer ngauss
      real*8 abuck,bbuck,cbuck
      real*8 ghal,dhal
      real*8 v2scale,v3scale
      real*8 v4scale,v5scale
      real*8 igauss
      character*5 radtyp
      character*8 radsiz,gausstyp
      character*10 radrule,epsrule
      character*13 vdwtyp
      common /vdwpot/ abuck,bbuck,cbuck,ghal,dhal,v2scale,v3scale,
     &                v4scale,v5scale,igauss(2,4),ngauss,vdwtyp,radtyp,
     &                radsiz,radrule,epsrule,gausstyp
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #######################################################
c     ##                                                   ##
c     ##  virial.i  --  components of the internal virial  ##
c     ##                                                   ##
c     #######################################################
c
c
c     virx   x-component of the total internal virial
c     viry   y-component of the total internal virial
c     virz   z-component of the total internal virial
c
c
      real*8 virx,viry,virz
      common /virial/ virx,viry,virz
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  warp.i  --  parameters for potential surface smoothing  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     m2          second moment of Gaussian representing each atom
c     deform      value of diffusional 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     use_deform  flag to use diffusion smoothed potential terms
c     use_gda     flag to use Straub's GDA instead of Scheraga's DEM 
c
c
      real*8 m2,deform
      real*8 difft,diffv,diffc
      logical use_deform,use_gda
      common /warp/ m2(maxatm),deform,difft,diffv,diffc,use_deform,
     &              use_gda
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  xtals.i  --  crystal structures for parameter fitting  ##
c     ##                                                         ##
c     #############################################################
c
c
c     e0_lattice   ideal lattice energy for the current crystal
c     moment_0     ideal dipole moment for monomer from crystal
c     nxtal        number of crystal structures to be stored
c     nvary        number of potential parameters to optimize
c     ivary        index for the types of potential parameters
c     vary         atom numbers involved in potential parameters
c     iresid       crystal structure to which each residual refers
c     rsdtyp       experimental variable for each of the residuals
c     vartyp       type of potential parameter to be optimized
c
c
      integer nxtal,nvary,ivary
      integer vary,iresid
      real*8 e0_lattice,moment_0
      character*20 rsdtyp,vartyp
      common /xtal1/ e0_lattice,moment_0,nxtal,nvary,ivary(maxlsq),
     &               vary(2,maxlsq),iresid(maxrsd),rsdtyp(maxrsd),
     &               vartyp(maxlsq)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  zclose.i  --  ring openings and closures for Z-matrix  ##
c     ##                                                         ##
c     #############################################################
c
c
c     nadd   number of added bonds between Z-matrix atoms
c     iadd   numbers of the atom pairs defining added bonds
c     ndel   number of bonds between Z-matrix bonds to delete
c     idel   numbers of the atom pairs defining deleted bonds
c
c
      integer nadd,iadd
      integer ndel,idel
      common /zclose/ nadd,iadd(2,maxatm),ndel,idel(2,maxatm)
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  zcoord.i  --  Z-matrix internal coordinate definitions  ##
c     ##                                                          ##
c     ##############################################################
c
c
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     iz      defining atom numbers for each Z-matrix atom
c
c
      integer iz
      real*8 zbond,zang,ztors
      common /zcoord/ zbond(maxatm),zang(maxatm),ztors(maxatm),
     &                iz(4,maxatm)
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     each potential energy function calculation
c
c
      subroutine active
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'usage.i'
      integer i,j,next
      integer nmobile,nfixed
      integer center,nsphere
      integer nlist,list(maxatm)
      integer mobile(maxatm)
      integer fixed(maxatm)
      real*8 xcenter,ycenter,zcenter
      real*8 radius,radius2,dist2
      character*20 keyword
      character*80 record,string
c
c
c     set defaults for the numbers and lists of active atoms
c
      nuse = n
      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)
c
c     get any lists of atoms whose coordinates are active
c
         if (keyword(1:7) .eq. 'ACTIVE ') then
            string = record(next:80)
            read (string,*,err=10,end=10)  (mobile(i),i=nmobile+1,n)
   10       continue
            dowhile (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
            string = record(next:80)
            read (string,*,err=20,end=20)  (fixed(i),i=nfixed+1,n)
   20       continue
            dowhile (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:7) .eq. 'SPHERE ') then
            center = 0
            xcenter = 0.0d0
            ycenter = 0.0d0
            zcenter = 0.0d0
            radius = 0.0d0
            string = record(next:80)
            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 (/,' Active Site 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     set active atoms to those not on the inactive atom list
c
      i = 1
      dowhile (fixed(i) .ne. 0)
         if (fixed(i) .gt. 0) then
            use(fixed(i)) = .false.
            nuse = nuse - 1
            i = i + 1
         else
            do j = abs(fixed(i)), abs(fixed(i+1))
               use(j) = .false.
               nuse = nuse - 1
            end do
            i = i + 2
         end if
      end do
c
c     set active atoms to only those on the active atom list
c
      i = 1
      dowhile (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
            use(mobile(i)) = .true.
            nuse = nuse + 1
            i = i + 1
         else
            do j = abs(mobile(i)), abs(mobile(i+1))
               use(j) = .true.
               nuse = nuse + 1
            end do
            i = i + 2
         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
         nlist = 0
         do i = 1, n
            if (use(i)) then
               nlist = nlist + 1
               list(nlist) = i
            end if
         end do
         write (iout,70)
   70    format (/,' List of Active Atoms for Energy',
     &              ' Calculations :',/)
         write (iout,80)  (list(i),i=1,nlist)
   80    format (3x,10i7)
      end if
      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     nrun    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
      implicit none
      include 'sizes.i'
      include 'analyz.i'
      include 'atoms.i'
      include 'energi.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'katoms.i'
      include 'mutant.i'
      include 'potent.i'
      include 'units.i'
      include 'usage.i'
      integer maxblock,maxstep
      parameter (maxblock=100)
      parameter (maxstep=5000)
      integer i,j,k,ixyz,start,stop
      integer nblock,nrun
      integer modrun,modblock
      integer istep,nstep,ilamb,nlamb
      integer lext,next,freeunit
      real*8 delta,lam0,lamp,lamm
      real*8 rt,e0,energy,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,ebp,ebm,ea0,eap,eam
      real*8 eit0,eitp,eitm,et0,etp,etm
      real*8 ev0,evp,evm,ec0,ecp,ecm
      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 badep(maxblock),badem(maxblock)
      real*8 bdap(maxblock),bdam(maxblock)
      real*8 nrg(3,maxstep),cb(3,maxstep)
      real*8 ca(3,maxstep),cit(3,maxstep)
      real*8 ct(3,maxstep),cv(3,maxstep)
      real*8 cc(3,maxstep)
      logical dogeom
      character*1 answer
      character*7 ext
      character*60 coordfile
      character*80 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 (a80)
      read (record,*,err=30,end=30)  start,stop
   30 continue
      if (start .eq. 0)  start = 1
      if (stop .eq. 0)  stop = start
      nrun  = 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 = nrun / 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 (a80)
      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     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
         dowhile (i.ge.start .and. i.le.stop)
            istep = istep + 1
            lext = 3
            call numeral (i,ext,lext)
            coordfile = filename(1:leng)//'.'//ext(1:lext)
            call version (coordfile,'old')
            ixyz = freeunit ()
            open (unit=ixyz,file=coordfile,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, nhybrid
               use(ihybrid(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',6x,'EB',8x,'EA',7x,'EIT',
     &                       8x,'ET',8x,'EV',8x,'EC',/)
               end if
               write (iout,150)  istep,eb,ea,eit,et,ev,ec
  150          format (i6,6f10.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)
         evp = cv(2,istep)
         evm = cv(3,istep)
         ec0 = cc(1,istep)
         ecp = cc(2,istep)
         ecm = cc(3,istep)
         if (dogeom) then
            eb0 = cb(1,istep)
            ebp = cb(2,istep)
            ebm = cb(3,istep)
            ea0 = ca(1,istep)
            eap = ca(2,istep)
            eam = ca(3,istep)
            eit0 = cit(1,istep)
            eitp = cit(2,istep)
            eitm = cit(3,istep)
            et0 = ct(1,istep)
            etp = ct(2,istep)
            etm = ct(3,istep)
         end if
         modrun = mod(istep-1,nrun)
         modblock = mod(istep-1,nblock)
c
c     zero out summation variables for new running average
c
         if (modrun .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
         modrun = mod(istep,nrun)
         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',8x,'E0',10x,'EP',10x,'EM',
     &                    10x,'DEP',9x,'DEM',/)
            end if
            write (iout,180)  istep,e0,eplus,eminus,deplus,deminus
  180       format (i6,5f12.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 + evp - ev0
         svm = svm + evm - ev0
         scp = scp + ecp - ec0
         scm = scm + ecm - ec0
         if (dogeom) then
            sbp = sbp + ebp - eb0
            sbm = sbm + ebm - eb0
            sap = sap + eap - ea0
            sam = sam + eam - ea0
            sitp = sitp + eitp - eit0
            sitm = sitm + eitm - eit0
            stp = stp + etp - et0
            stm = stm + etm - 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',6x,'NStep',7x,'BADEP',
     &                    7x,'BADEM',8x,'BDAP',8x,'BDAM',/)
            end if
            write (iout,200)  k,istep,badep(k),badem(k),
     &                        bdap(k),bdam(k)
  200       format (i6,5x,i6,1x,4f12.4)
         end if
c
c     calculate running averages for potential energy
c
         if (modrun .eq. 0) then
            adep = sdep / dble(nrun)
            adem = sdem / dble(nrun)
            a2dep = s2dep / dble(nrun)
            a2dem = s2dem / dble(nrun)
            adep2 = adep * adep
            adem2 = adem * adem
            fdep =  sqrt(a2dep - adep2)
            fdem =  sqrt(a2dem - adem2)
            do k = 1, nrun / nblock
               v = (badep(k) - adep)**2
               vdep = vdep + v
               v = (badem(k) - adem)**2
               vdem = vdem + v
            end do
            vdep = vdep / dble(nrun/nblock)
            se_ep = sqrt(vdep / dble(nrun/nblock))
            vdem = vdem / dble(nrun/nblock)
            se_em = sqrt(vdem / dble(nrun/nblock))
c
c     calculate running averages for free energy
c
            da = spos / dble(nrun)
            da = -rt * log (da)
            dap = da
            da = sneg / dble(nrun)
            da = -rt * log (da)
            dam = da
            adapb = sdapb / dble(nrun/nblock)
            adamb = sdamb / dble(nrun/nblock)
            do k = 1, nrun/nblock
               v = (bdap(k) - adapb)**2
               vdap = vdap + v
               v = (bdam(k) - adamb)**2
               vdam = vdam + v
            end do
            vdap = vdap / dble(nrun/nblock)
            se_ap = sqrt(vdap / dble(nrun/nblock))
            vdam = vdam / dble(nrun/nblock)
            se_am = sqrt(vdam / dble(nrun/nblock))
c
c     calculate running averages for energy components
c
            avp = svp / dble(nrun)
            avm = svm / dble(nrun)
            acp = scp / dble(nrun)
            acm = scm / dble(nrun)
            if (dogeom) then
               abp = sbp / dble(nrun)
               abm = sbm / dble(nrun)
               aap = sap / dble(nrun)
               aam = sam / dble(nrun)
               aitp = sitp / dble(nrun)
               aitm = sitm / dble(nrun)
               atp = stp / dble(nrun)
               atm = stm / dble(nrun)
            end if
            sdep = 0.0d0
            sdem = 0.0d0
c
c     write information about running averages and block averages
c
            write (iout,210)  nstep,nrun/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 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 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)
      implicit none
      include 'sizes.i'
      include 'analyz.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'inter.i'
      include 'potent.i'
      include 'vdwpot.i'
      integer i
      real*8 energy
      real*8 cutoff
c
c
c     zero out each of the potential energy components
c
      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
      ebt = 0.0d0
      ett = 0.0d0
      ev = 0.0d0
      ec = 0.0d0
      ecd = 0.0d0
      ed = 0.0d0
      em = 0.0d0
      ep = 0.0d0
      er = 0.0d0
      es = 0.0d0
      elf = 0.0d0
      eg = 0.0d0
      ex = 0.0d0
c
c     zero out energy partitioning components for each atom
c
      do i = 1, n
         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
         aebt(i) = 0.0d0
         aett(i) = 0.0d0
         aev(i) = 0.0d0
         aec(i) = 0.0d0
         aecd(i) = 0.0d0
         aed(i) = 0.0d0
         aem(i) = 0.0d0
         aep(i) = 0.0d0
         aer(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     maintain any periodic boundary conditions
c
      if (use_bounds)  call bounds
c
c     remove any previous use of the replicates method
c
      cutoff = 0.0d0
      if (use_image)  call replica (cutoff)
c
c     alter bond and torsion constants for pisystem
c
      if (use_orbit)  call piscf
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_strtor)  call estrtor3
c     if (use_tortor)  call etortor3
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
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 .or. use_polar)  call empole3
      if (use_rxnfld)  call erxnfld3
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
      energy = eb + ea + eba + eub + eaa + eopb + eopd + eid + eit
     &            + et + ebt + ett + ev + ec + ecd + ed + em + ep
     &            + er + es + elf + eg + ex
      return
      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; options
c     are provided to partition the energy by atom or by potential
c     function type; parameters used in computing interactions can
c     also be displayed by atom; output of large energy interactions
c     and of electrostatic and inertial properties is available
c
c
      program analyze
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      integer i,j,ixyz
      integer frame
      integer freeunit
      integer trimtext
      integer list(20)
      logical doenergy,doatom
      logical dolarge,doall
      logical doprops,doparam
      logical exist
      logical active(maxatm)
      character*1 letter
      character*60 xyzfile
      character*80 record
      character*80 string
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
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 Analysis Facility can Provide :',
     &           //,' 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]',
     &           /,' Show Electrostatic and Inertial Properties [M]',
     &           /,' Force Field Parameters for Interactions [P]')
   20    continue
         write (iout,30)
   30    format (/,' Enter the Desired Analysis Types',
     &              ' [E,A,L,D,M,P] :  ',$)
         read (input,40,err=20)  string
   40    format (a80)
      end if
c
c     set option control flags based desired analysis types
c
      doenergy = .false.
      doatom = .false.
      dolarge = .false.
      doall = .false.
      doprops = .false.
      doparam = .false.
      call upcase (string)
      do i = 1, trimtext(string)
         letter = string(i:i)
         if (letter .eq. 'E')  doenergy = .true.
         if (letter .eq. 'A')  doatom = .true.
         if (letter .eq. 'L')  dolarge = .true.
         if (letter .eq. 'D')  doall = .true.
         if (letter .eq. 'M')  doprops = .true.
         if (letter .eq. 'P')  doparam = .true.
      end do
c
c     get the list of atoms for which output is desired
c
      if (doatom .or. doparam) then
         do i = 1, 20
            list(i) = 0
         end do
         if (exist) then
            do i = 1, 20
               call nextarg (string,exist)
               if (.not. exist)  goto 50
               read (string,*,err=50,end=50)  list(i)
            end do
   50       continue
         else
            write (iout,60)
   60       format (/,' List Atoms for which Output is Desired',
     &                 ' [ALL] :  '/,'    >  ',$)
            read (input,70)  record
   70       format (a80)
            read (record,*,err=80,end=80)  (list(i),i=1,20)
   80       continue
         end if
         do i = 1, n
            active(i) = .true.
         end do
         i = 1
         dowhile (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.
      else
         verbose = .false.
      end if
c
c     setup to write out all of the individual energy terms
c
      if (doall) then
         debug = .true.
      else
         debug = .false.
      end if
c
c     reopen the coordinates file and read the first structure
c
      frame = 0
      ixyz = freeunit ()
      xyzfile = filename
      call suffix (xyzfile,'xyz')
      call version (xyzfile,'old')
      open (unit=ixyz,file=xyzfile,status ='old')
      rewind (unit=ixyz)
      call readxyz (ixyz)
c
c     perform analysis for each successive coordinate structure
c
      dowhile (.not. abort)
         frame = frame + 1
         if (frame .gt. 1) then
            write (iout,90)  frame
   90       format (/,' Analysis for Archive Structure :',8x,i8)
         end if
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) then
            if (digits .ge. 8) then
               call analyz8
            else if (digits .ge. 6) then
               call analyz6
            else
               call analyz4
            end if
         end if
c
c     get various electrostatic and inertial properties
c
         if (doprops)  call propyze
c
c     energy partitioning over the individual atoms
c
         if (doatom)  call atomyze (active)
c
c     list parameters used for molecular mechanics potentials
c
         if (doparam)  call paramyze (active)
c
c     attempt to read next structure from the coordinate file
c
         call readxyz (ixyz)
      end do
c
c     perform any final tasks before program exit
c
      close (unit=ixyz)
      if (doall)  debug = .false.
      call final
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine enrgyze  --  compute & report energy analysis  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "energyze" 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      real*8 energy
c
c
c     perform the energy analysis by atom and component
c
      call analysis (energy)
c
c     print out the total potential energy of the system
c
      if (digits .ge. 8) then
         if (abs(energy) .lt. 1.0d10) then
            write (iout,10)  energy
   10       format (/,' Total Potential Energy :',8x,f20.8,
     &                    ' Kcal/mole')
         else
            write (iout,20)  energy
   20       format (/,' Total Potential Energy :',8x,d20.8,
     &                    ' Kcal/mole')
         end if
      else if (digits .ge. 6) then
         if (abs(energy) .lt. 1.0d10) then
            write (iout,30)  energy
   30       format (/,' Total Potential Energy :',8x,f18.6,
     &                    ' Kcal/mole')
         else
            write (iout,40)  energy
   40       format (/,' Total Potential Energy :',8x,d18.6,
     &                    ' Kcal/mole')
         end if
      else
         if (abs(energy) .lt. 1.0d10) then
            write (iout,50)  energy
   50       format (/,' Total Potential Energy :',8x,f16.4,
     &                    ' Kcal/mole')
         else
            write (iout,60)  energy
   60       format (/,' Total Potential Energy :',8x,d16.4,
     &                    ' Kcal/mole')
         end if
      end if
c
c     intermolecular energy for systems with multiple molecules
c
      if (nmol.gt.1 .and. nmol.lt.n) then
         if (digits .ge. 8) then
            if (abs(einter) .lt. 1.0d10) then
               write (iout,70)  einter
   70          format (/,' Intermolecular Energy :',9x,f20.8,
     &                       ' Kcal/mole')
            else
               write (iout,80)  einter
   80          format (/,' Intermolecular Energy :',9x,d20.8,
     &                       ' Kcal/mole')
            end if
         else if (digits .ge. 6) then
            if (abs(einter) .lt. 1.0d10) then
               write (iout,90)  einter
   90          format (/,' Intermolecular Energy :',9x,f18.6,
     &                       ' Kcal/mole')
            else
               write (iout,100)  einter
  100          format (/,' Intermolecular Energy :',9x,d18.6,
     &                       ' Kcal/mole')
            end if
         else
            if (abs(einter) .lt. 1.0d10) then
               write (iout,110)  einter
  110          format (/,' Intermolecular Energy :',9x,f16.4,
     &                       ' Kcal/mole')
            else
               write (iout,120)  einter
  120          format (/,' Intermolecular Energy :',9x,d16.4,
     &                       ' Kcal/mole')
            end if
         end if
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine analyz4  --  low precision energy components  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "analyz4" prints the energy to 4 decimal places and number
c     of interactions for each component of the potential energy
c
c
      subroutine analyz4
      include 'action.i'
      include 'cutoff.i'
      include 'energi.i'
      include 'iounit.i'
      include 'potent.i'
      character*8 label
c
c
c     write out each energy component to the desired precision
c
      write (iout,10)
   10 format (/,' Energy Component Breakdown :',11x,'Kcal/mole',
     &          6x,'Interactions'/)
      if (use_bond .and. neb.ne.0) then
         write (iout,20)  eb,neb
   20    format (' Bond Stretching',17x,f16.4,i15)
      end if
      if (use_angle .and. nea.ne.0) then
         write (iout,30)  ea,nea
   30    format (' Angle Bending',19x,f16.4,i15)
      end if
      if (use_strbnd .and. neba.ne.0) then
         write (iout,40)  eba,neba
   40    format (' Stretch-Bend',20x,f16.4,i15)
      end if
      if (use_urey .and. neub.ne.0) then
         write (iout,50)  eub,neub
   50    format (' Urey-Bradley',20x,f16.4,i15)
      end if
      if (use_angang .and. neaa.ne.0) then
         write (iout,60)  eaa,neaa
   60    format (' Angle-Angle',21x,f16.4,i15)
      end if
      if (use_opbend .and. neopb.ne.0) then
         write (iout,70)  eopb,neopb
   70    format (' Out-of-Plane Bend',15x,f16.4,i15)
      end if
      if (use_opdist .and. neopd.ne.0) then
         write (iout,80)  eopd,neopd
   80    format (' Out-of-Plane Distance',11x,f16.4,i15)
      end if
      if (use_improp .and. neid.ne.0) then
         write (iout,90)  eid,neid
   90    format (' Improper Dihedral',15x,f16.4,i15)
      end if
      if (use_imptor .and. neit.ne.0) then
         write (iout,100)  eit,neit
  100    format (' Improper Torsion',16x,f16.4,i15)
      end if
      if (use_tors .and. net.ne.0) then
         write (iout,110)  et,net
  110    format (' Torsional Angle',17x,f16.4,i15)
      end if
      if (use_strtor .and. nebt.ne.0) then
         write (iout,120)  ebt,nebt
  120    format (' Stretch-Torsion',17x,f16.4,i15)
      end if
      if (use_tortor .and. nett.ne.0) then
         write (iout,130)  ett
  130    format (' Torsion-Torsion',17x,f16.4,i15)
      end if
      if (use_vdw .and. nev.ne.0) then
         if (abs(ev) .lt. 1.0d10) then
            write (iout,140)  ev,nev
  140       format (' Van der Waals',19x,f16.4,i15)
         else
            write (iout,150)  ev,nev
  150       format (' Van der Waals',19x,d16.4,i15)
         end if
      end if
      if (use_charge .and. nec.ne.0) then
         label = '        '
         if (use_ewald)  label = ' (Ewald)'
         if (abs(ec) .lt. 1.0d10) then
            write (iout,160)  label,ec,nec
  160       format (' Charge-Charge',a8,11x,f16.4,i15)
         else
            write (iout,170)  label,ec,nec
  170       format (' Charge-Charge',a8,11x,d16.4,i15)
         end if
      end if
      if (use_chgdpl .and. necd.ne.0) then
         if (abs(ecd) .lt. 1.0d10) then
            write (iout,180)  ecd,necd
  180       format (' Charge-Dipole',19x,f16.4,i15)
         else
            write (iout,190)  ecd,necd
  190       format (' Charge-Dipole',19x,d16.4,i15)
         end if
      end if
      if (use_dipole .and. ned.ne.0) then
         if (abs(ed) .lt. 1.0d10) then
            write (iout,200)  ed,ned
  200       format (' Dipole-Dipole',19x,f16.4,i15)
         else
            write (iout,210)  ed,ned
  210       format (' Dipole-Dipole',19x,d16.4,i15)
         end if
      end if
      if (use_mpole .and. nem.ne.0) then
         label = '        '
         if (use_ewald)  label = ' (Ewald)'
         if (abs(em) .lt. 1.0d10) then
            write (iout,220)  label,em,nem
  220       format (' Atomic Multipoles',a8,7x,f16.4,i15)
         else
            write (iout,230)  label,em,nem
  230       format (' Atomic Multipoles',a8,7x,d16.4,i15)
         end if
      end if
      if (use_polar .and. nep.ne.0) then
         label = '        '
         if (use_ewald)  label = ' (Ewald)'
         if (abs(ep) .lt. 1.0d10) then
            write (iout,240)  label,ep,nep
  240       format (' Polarization',a8,12x,f16.4,i15)
         else
            write (iout,250)  label,ep,nep
  250       format (' Polarization',a8,12x,d16.4,i15)
         end if
      end if
      if (use_rxnfld .and. ner.ne.0) then
         write (iout,260)  er,ner
  260    format (' Reaction Field',18x,f16.4,i15)
      end if
      if (use_solv .and. nes.ne.0) then
         write (iout,270)  es,nes
  270    format (' Continuum Solvation',13x,f16.4,i15)
      end if
      if (use_metal .and. nelf.ne.0) then
         write (iout,280)  elf,nelf
  280    format (' Metal Ligand Field',14x,f16.4,i15)
      end if
      if (use_geom .and. neg.ne.0) then
         write (iout,290)  eg,neg
  290    format (' Geometric Restraints',12x,f16.4,i15)
      end if
      if (use_extra .and. nex.ne.0) then
         write (iout,300)  ex,nex
  300    format (' Extra Energy Terms',14x,f16.4,i15)
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine analyz6  --  medium precision energy components  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "analyz6" prints the energy to 6 decimal places and number
c     of interactions for each component of the potential energy
c
c
      subroutine analyz6
      include 'action.i'
      include 'cutoff.i'
      include 'energi.i'
      include 'iounit.i'
      include 'potent.i'
      character*8 label
c
c
c     write out each energy component to the desired precision
c
      write (iout,10)
   10 format (/,' Energy Component Breakdown :',13x,'Kcal/mole',
     &          6x,'Interactions'/)
      if (use_bond .and. neb.ne.0) then
         write (iout,20)  eb,neb
   20    format (' Bond Stretching',17x,f18.6,i15)
      end if
      if (use_angle .and. nea.ne.0) then
         write (iout,30)  ea,nea
   30    format (' Angle Bending',19x,f18.6,i15)
      end if
      if (use_strbnd .and. neba.ne.0) then
         write (iout,40)  eba,neba
   40    format (' Stretch-Bend',20x,f18.6,i15)
      end if
      if (use_urey .and. neub.ne.0) then
         write (iout,50)  eub,neub
   50    format (' Urey-Bradley',20x,f18.6,i15)
      end if
      if (use_angang .and. neaa.ne.0) then
         write (iout,60)  eaa,neaa
   60    format (' Angle-Angle',21x,f18.6,i15)
      end if
      if (use_opbend .and. neopb.ne.0) then
         write (iout,70)  eopb,neopb
   70    format (' Out-of-Plane Bend',15x,f18.6,i15)
      end if
      if (use_opdist .and. neopd.ne.0) then
         write (iout,80)  eopd,neopd
   80    format (' Out-of-Plane Distance',11x,f18.6,i15)
      end if
      if (use_improp .and. neid.ne.0) then
         write (iout,90)  eid,neid
   90    format (' Improper Dihedral',15x,f18.6,i15)
      end if
      if (use_imptor .and. neit.ne.0) then
         write (iout,100)  eit,neit
  100    format (' Improper Torsion',16x,f18.6,i15)
      end if
      if (use_tors .and. net.ne.0) then
         write (iout,110)  et,net
  110    format (' Torsional Angle',17x,f18.6,i15)
      end if
      if (use_strtor .and. nebt.ne.0) then
         write (iout,120)  ebt,nebt
  120    format (' Stretch-Torsion',17x,f18.6,i15)
      end if
      if (use_tortor .and. nett.ne.0) then
         write (iout,130)  ett
  130    format (' Torsion-Torsion',17x,f18.6,i15)
      end if
      if (use_vdw .and. nev.ne.0) then
         if (abs(ev) .lt. 1.0d10) then
            write (iout,140)  ev,nev
  140       format (' Van der Waals',19x,f18.6,i15)
         else
            write (iout,150)  ev,nev
  150       format (' Van der Waals',19x,d18.6,i15)
         end if
      end if
      if (use_charge .and. nec.ne.0) then
         label = '        '
         if (use_ewald)  label = ' (Ewald)'
         if (abs(ec) .lt. 1.0d10) then
            write (iout,160)  label,ec,nec
  160       format (' Charge-Charge',a8,11x,f18.6,i15)
         else
            write (iout,170)  label,ec,nec
  170       format (' Charge-Charge',a8,11x,d18.6,i15)
         end if
      end if
      if (use_chgdpl .and. necd.ne.0) then
         if (abs(ecd) .lt. 1.0d10) then
            write (iout,180)  ecd,necd
  180       format (' Charge-Dipole',19x,f18.6,i15)
         else
            write (iout,190)  ecd,necd
  190       format (' Charge-Dipole',19x,d18.6,i15)
         end if
      end if
      if (use_dipole .and. ned.ne.0) then
         if (abs(ed) .lt. 1.0d10) then
            write (iout,200)  ed,ned
  200       format (' Dipole-Dipole',19x,f18.6,i15)
         else
            write (iout,210)  ed,ned
  210       format (' Dipole-Dipole',19x,d18.6,i15)
         end if
      end if
      if (use_mpole .and. nem.ne.0) then
         label = '        '
         if (use_ewald)  label = ' (Ewald)'
         if (abs(em) .lt. 1.0d10) then
            write (iout,220)  label,em,nem
  220       format (' Atomic Multipoles',a8,7x,f18.6,i15)
         else
            write (iout,230)  label,em,nem
  230       format (' Atomic Multipoles',a8,7x,d18.6,i15)
         end if
      end if
      if (use_polar .and. nep.ne.0) then
         label = '        '
         if (use_ewald)  label = ' (Ewald)'
         if (abs(ep) .lt. 1.0d10) then
            write (iout,240)  label,ep,nep
  240       format (' Polarization',a8,12x,f18.6,i15)
         else
            write (iout,250)  label,ep,nep
  250       format (' Polarization',a8,12x,d18.6,i15)
         end if
      end if
      if (use_rxnfld .and. ner.ne.0) then
         write (iout,260)  er,ner
  260    format (' Reaction Field',18x,f18.6,i15)
      end if
      if (use_solv .and. nes.ne.0) then
         write (iout,270)  es,nes
  270    format (' Continuum Solvation',13x,f18.6,i15)
      end if
      if (use_metal .and. nelf.ne.0) then
         write (iout,280)  elf,nelf
  280    format (' Metal Ligand Field',14x,f18.6,i15)
      end if
      if (use_geom .and. neg.ne.0) then
         write (iout,290)  eg,neg
  290    format (' Geometric Restraints',12x,f18.6,i15)
      end if
      if (use_extra .and. nex.ne.0) then
         write (iout,300)  ex,nex
  300    format (' Extra Energy Terms',14x,f18.6,i15)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine analyz8  --  high precision energy components  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "analyz8" prints the energy to 8 decimal places and number
c     of interactions for each component of the potential energy
c
c
      subroutine analyz8
      include 'action.i'
      include 'cutoff.i'
      include 'energi.i'
      include 'iounit.i'
      include 'potent.i'
      character*8 label
c
c
c     write out each energy component to the desired precision
c
      write (iout,10)
   10 format (/,' Energy Component Breakdown :',15x,'Kcal/mole',
     &          6x,'Interactions'/)
      if (use_bond .and. neb.ne.0) then
         write (iout,20)  eb,neb
   20    format (' Bond Stretching',17x,f20.8,i15)
      end if
      if (use_angle .and. nea.ne.0) then
         write (iout,30)  ea,nea
   30    format (' Angle Bending',19x,f20.8,i15)
      end if
      if (use_strbnd .and. neba.ne.0) then
         write (iout,40)  eba,neba
   40    format (' Stretch-Bend',20x,f20.8,i15)
      end if
      if (use_urey .and. neub.ne.0) then
         write (iout,50)  eub,neub
   50    format (' Urey-Bradley',20x,f20.8,i15)
      end if
      if (use_angang .and. neaa.ne.0) then
         write (iout,60)  eaa,neaa
   60    format (' Angle-Angle',21x,f20.8,i15)
      end if
      if (use_opbend .and. neopb.ne.0) then
         write (iout,70)  eopb,neopb
   70    format (' Out-of-Plane Bend',15x,f20.8,i15)
      end if
      if (use_opdist .and. neopd.ne.0) then
         write (iout,80)  eopd,neopd
   80    format (' Out-of-Plane Distance',11x,f20.8,i15)
      end if
      if (use_improp .and. neid.ne.0) then
         write (iout,90)  eid,neid
   90    format (' Improper Dihedral',15x,f20.8,i15)
      end if
      if (use_imptor .and. neit.ne.0) then
         write (iout,100)  eit,neit
  100    format (' Improper Torsion',16x,f20.8,i15)
      end if
      if (use_tors .and. net.ne.0) then
         write (iout,110)  et,net
  110    format (' Torsional Angle',17x,f20.8,i15)
      end if
      if (use_strtor .and. nebt.ne.0) then
         write (iout,120)  ebt,nebt
  120    format (' Stretch-Torsion',17x,f20.8,i15)
      end if
      if (use_tortor .and. nett.ne.0) then
         write (iout,130)  ett
  130    format (' Torsion-Torsion',17x,f20.8,i15)
      end if
      if (use_vdw .and. nev.ne.0) then
         if (abs(ev) .lt. 1.0d10) then
            write (iout,140)  ev,nev
  140       format (' Van der Waals',19x,f20.8,i15)
         else
            write (iout,150)  ev,nev
  150       format (' Van der Waals',19x,d20.8,i15)
         end if
      end if
      if (use_charge .and. nec.ne.0) then
         label = '        '
         if (use_ewald)  label = ' (Ewald)'
         if (abs(ec) .lt. 1.0d10) then
            write (iout,160)  label,ec,nec
  160       format (' Charge-Charge',a8,11x,f20.8,i15)
         else
            write (iout,170)  label,ec,nec
  170       format (' Charge-Charge',a8,11x,d20.8,i15)
         end if
      end if
      if (use_chgdpl .and. necd.ne.0) then
         if (abs(ecd) .lt. 1.0d10) then
            write (iout,180)  ecd,necd
  180       format (' Charge-Dipole',19x,f20.8,i15)
         else
            write (iout,190)  ecd,necd
  190       format (' Charge-Dipole',19x,d20.8,i15)
         end if
      end if
      if (use_dipole .and. ned.ne.0) then
         if (abs(ed) .lt. 1.0d10) then
            write (iout,200)  ed,ned
  200       format (' Dipole-Dipole',19x,f20.8,i15)
         else
            write (iout,210)  ed,ned
  210       format (' Dipole-Dipole',19x,d20.8,i15)
         end if
      end if
      if (use_mpole .and. nem.ne.0) then
         label = '        '
         if (use_ewald)  label = ' (Ewald)'
         if (abs(em) .lt. 1.0d10) then
            write (iout,220)  label,em,nem
  220       format (' Atomic Multipoles',a8,7x,f20.8,i15)
         else
            write (iout,230)  label,em,nem
  230       format (' Atomic Multipoles',a8,7x,d20.8,i15)
         end if
      end if
      if (use_polar .and. nep.ne.0) then
         label = '        '
         if (use_ewald)  label = ' (Ewald)'
         if (abs(ep) .lt. 1.0d10) then
            write (iout,240)  label,ep,nep
  240       format (' Polarization',a8,12x,f20.8,i15)
         else
            write (iout,250)  label,ep,nep
  250       format (' Polarization',a8,12x,d20.8,i15)
         end if
      end if
      if (use_rxnfld .and. ner.ne.0) then
         write (iout,260)  er,ner
  260    format (' Reaction Field',18x,f20.8,i15)
      end if
      if (use_solv .and. nes.ne.0) then
         write (iout,270)  es,nes
  270    format (' Continuum Solvation',13x,f20.8,i15)
      end if
      if (use_metal .and. nelf.ne.0) then
         write (iout,280)  elf,nelf
  280    format (' Metal Ligand Field',14x,f20.8,i15)
      end if
      if (use_geom .and. neg.ne.0) then
         write (iout,290)  eg,neg
  290    format (' Geometric Restraints',12x,f20.8,i15)
      end if
      if (use_extra .and. nex.ne.0) then
         write (iout,300)  ex,nex
  300    format (' Extra Energy Terms',14x,f20.8,i15)
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine propyze  --  electrostatic & inertial analysis  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "propyze" finds and prints the total charge, dipole moment
c     components, radius of gyration and moments of inertia
c
c
      subroutine propyze
      include 'sizes.i'
      include 'chgpot.i'
      include 'iounit.i'
      include 'moment.i'
      real*8 rg
c
c
c     get the total charge, dipole and quadrupole moments
c
      call moments
      write (iout,10)  netchg
   10 format (/,' Total Electric Charge :',13x,f12.5,' Electrons')
      write (iout,20)  netdpl,xdpl,ydpl,zdpl
   20 format (/,' Dipole Moment Magnitude :',11x,f12.4,' Debyes',
     &        //,' Dipole X-Component :',16x,f12.4,' Debyes',
     &        /,' Dipole Y-Component :',16x,f12.4,' Debyes',
     &        /,' Dipole Z-Component :',16x,f12.4,' Debyes')
      write (iout,30)  xxqdp,xyqdp,xzqdp,yxqdp,yyqdp,
     &                 yzqdp,zxqdp,zyqdp,zzqdp
   30 format (/,' Quadrupole Moment Tensor :',10x,3f12.4,
     &        /,6x,'(Buckinghams)',18x,3f12.4,
     &        /,37x,3f12.4)
      write (iout,40)  netqdp(1),netqdp(2),netqdp(3)
   40 format (/,' Principal Axes Quadrupole :',9x,3f12.4)
      if (dielec .ne. 1.0d0) then
         write (iout,50)  dielec
   50    format (/,' Dielectric Constant :',15x,f12.4)
         write (iout,60)  netchg/sqrt(dielec)
   60    format (' Effective Total Charge :',12x,f12.5,' Electrons')
         write (iout,70)  netdpl/sqrt(dielec)
   70    format (' Effective Dipole Moment :',11x,f12.4,' Debyes')
      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 :',16x,f12.4,' 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)
      include 'sizes.i'
      include 'analyz.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      integer i
      logical active(maxatm)
c
c
c     energy partitioning over the individual atoms
c
      write (iout,10)
   10 format (/,' Potential Energy Breakdown over Atoms :')
      if (digits .ge. 8) then
         write (iout,20)
   20    format (/,'  Atom',9x,'EB',14x,'EA',14x,'EBA',13x,'EUB',
     &           /,15x,'EAA',13x,'EOPB',12x,'EOPD',12x,'EID',
     &           /,15x,'EIT',13x,'ET',14x,'EBT',13x,'ETT',
     &           /,15x,'EV',14x,'EC',14x,'ECD',13x,'ED',
     &           /,15x,'EM',14x,'EP',14x,'ER',14x,'ES',
     &           /,15x,'ELF',13x,'EG',14x,'EX')
         do i = 1, n
            if (active(i)) then
               write (iout,30)  i,aeb(i),aea(i),aeba(i),aeub(i),
     &                          aeaa(i),aeopb(i),aeopd(i),aeid(i),
     &                          aeit(i),aet(i),aebt(i),aett(i),
     &                          aev(i),aec(i),aecd(i),aed(i),aem(i),
     &                          aep(i),aer(i),aes(i),aelf(i),aeg(i),
     &                          aex(i)
   30          format (/,i6,4f16.8,/,6x,4f16.8,/,6x,4f16.8,
     &                 /,6x,4f16.8,/,6x,4f16.8,/,6x,3f16.8)
            end if
         end do
      else if (digits .ge. 6) then
         write (iout,40)
   40    format (/,'  Atom',8x,'EB',12x,'EA',12x,'EBA',11x,'EUB',
     &              11x,'EAA',
     &           /,14x,'EOPB',10x,'EOPD',10x,'EID',11x,'EIT',
     &              11x,'ET',
     &           /,14x,'EBT',11x,'ETT',11x,'EV',12x,'EC',12x,'ECD',
     &           /,14x,'ED',12x,'EM',12x,'EP',12x,'ER',12x,'ES',
     &           /,14x,'ELF',11x,'EG',12x,'EX')
         do i = 1, n
            if (active(i)) then
               write (iout,50)  i,aeb(i),aea(i),aeba(i),aeub(i),
     &                          aeaa(i),aeopb(i),aeopd(i),aeid(i),
     &                          aeit(i),aet(i),aebt(i),aett(i),
     &                          aev(i),aec(i),aecd(i),aed(i),aem(i),
     &                          aep(i),aer(i),aes(i),aelf(i),aeg(i),
     &                          aex(i)
   50          format (/,i6,5f14.6,/,6x,5f14.6,/,6x,5f14.6,
     &                 /,6x,5f14.6,/,6x,3f14.6)
            end if
         end do
      else
         write (iout,60)
   60    format (/,'  Atom',8x,'EB',10x,'EA',10x,'EBA',9x,'EUB',
     &              9x,'EAA',9x,'EOPB',
     &           /,14x,'EOPD',8x,'EID',9x,'EIT',9x,'ET',10x,'EBT',
     &              9x,'ETT',
     &           /,14x,'EV',10x,'EC',10x,'ECD',9x,'ED',10x,'EM',
     &              10x,'EP',
     &           /,14x,'ER',10x,'ES',10x,'ELF',9x,'EG',10x,'EX')
         do i = 1, n
            if (active(i)) then
               write (iout,70)  i,aeb(i),aea(i),aeba(i),aeub(i),
     &                          aeaa(i),aeopb(i),aeopd(i),aeid(i),
     &                          aeit(i),aet(i),aebt(i),aett(i),
     &                          aev(i),aec(i),aecd(i),aed(i),aem(i),
     &                          aep(i),aer(i),aes(i),aelf(i),aeg(i),
     &                          aex(i)
   70          format (/,i6,6f12.4,/,6x,6f12.4,/,6x,6f12.4,
     &                 /,6x,5f12.4)
            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)
      implicit none
      include 'sizes.i'
      include 'angang.i'
      include 'angle.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'charge.i'
      include 'dipole.i'
      include 'improp.i'
      include 'imptor.i'
      include 'iounit.i'
      include 'kvdws.i'
      include 'mpole.i'
      include 'opbend.i'
      include 'opdist.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'potent.i'
      include 'solute.i'
      include 'strbnd.i'
      include 'strtor.i'
      include 'tors.i'
      include 'units.i'
      include 'urey.i'
      include 'vdw.i'
      integer i,j,k
      integer ia,ib,ic,id
      integer izaxe,ixaxe
      integer fold(6)
      real*8 bla,blc
      real*8 ampli(6)
      real*8 phase(6)
      logical header
      logical active(maxatm)
c
c
c     list 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,10)
   10          format (/,' Atom Type Definition Parameters :',
     &                 //,3x,'Atom',4x,'Symbol',3x,'Type',
     &                    2x,'Class',2x,'Atomic',4x,'Mass',
     &                    3x,'Valence',2x,'Description',/)
            end if
            write (iout,20)  i,name(i),type(i),class(i),atomic(i),
     &                       mass(i),valence(i),story(i)
   20       format (i6,7x,a3,3i7,f11.3,i6,5x,a20)
         end if
      end do
c
c     list 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,30)
   30             format (/,' Van der Waals Parameters :',
     &                    //,10x,'Atom Number',5x,'Radius',
     &                       3x,'Epsilon',3x,'Rad 1-4',
     &                       3x,'Eps 1-4',3x,'Reduction',/)
               end if
               j = class(i)
               if (rad(j).eq.rad4(j) .and. eps(j).eq.eps4(j)) then
                  if (reduct(j) .eq. 0.0d0) then
                     write (iout,40)  k,i,rad(j),eps(j)
   40                format (i6,3x,i6,7x,2f10.4)
                  else
                     write (iout,50)  k,i,rad(j),eps(j),reduct(j)
   50                format (i6,3x,i6,7x,2f10.4,20x,f10.4)
                  end if
               else
                  if (reduct(j) .eq. 0.0d0) then
                     write (iout,60)  k,i,rad(j),eps(j),rad4(j),
     &                                eps4(j)
   60                format (i6,3x,i6,7x,4f10.4)
                  else
                     write (iout,70)  k,i,rad(j),eps(j),rad4(j),
     &                                eps4(j),reduct(j)
   70                format (i6,3x,i6,7x,5f10.4)
                  end if
               end if
            end if
         end do
      end if
c
c     list 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,80)
   80             format (/,' Bond Stretching Parameters :',
     &                    //,10x,'Atom Numbers',25x,'KS',
     &                       5x,'Length',/)
               end if
               write (iout,90)  i,ia,ib,bk(i),bl(i)
   90          format (i6,3x,2i6,13x,f16.4,f10.4)
            end if
         end do
      end if
c
c     list 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,100)
  100             format (/,' Angle Bending Parameters :',
     &                    //,13x,'Atom Numbers',22x,'KB',
     &                       6x,'Angle',/)
               end if
               if (angtyp(i) .eq. 'HARMONIC') then
                  write (iout,110)  i,ia,ib,ic,ak(i),anat(i)
  110             format (i6,3x,3i6,7x,f16.4,f10.4)
               else if (angtyp(i) .eq. 'IN-PLANE') then
                  write (iout,120)  i,ia,ib,ic,ak(i),anat(i)
  120             format (i6,3x,3i6,7x,f16.4,f10.4,2x,'In-Plane')
               end if
            end if
         end do
      end if
c
c     list 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,130)
  130             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))
               write (iout,140)  i,ia,ib,ic,ksb(i),anat(k),bla,blc
  140          format (i6,3x,3i6,f13.4,3f10.4)
            end if
         end do
      end if
c
c     list 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)
            if (active(ia) .or. active(ib)) then
               if (header) then
                  header = .false.
                  write (iout,150)
  150             format (/,' Urey-Bradley Parameters :',
     &                    //,10x,'Atom Numbers',24x,'KUB',
     &                       4x,'Distance',/)
               end if
               write (iout,160)  i,ia,ib,uk(i),ul(i)
  160          format (i6,3x,2i6,13x,f16.4,f10.4)
            end if
         end do
      end if
c
c     list parameters used for out-of-plane bending 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,170)
  170             format (/,' Out-of-Plane Bending Parameters :',
     &                    //,17x,'Atom Numbers',19x,'KOPB',/)
               end if
               write (iout,180)  i,id,ib,ia,ic,kopb(i)
  180          format (i6,3x,4i6,9x,f10.4)
            end if
         end do
      end if
c
c     list 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,190)
  190             format (/,' Out-of-Plane Distance Parameters :',
     &                    //,17x,'Atom Numbers',18x,'KOPD',/)
               end if
               write (iout,200)  i,ia,ib,ic,id,kopd(i)
  200          format (i6,3x,4i6,8x,f10.4)
            end if
         end do
      end if
c
c     list 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,210)
  210             format (/,' Improper Dihedral Parameters :',
     &                    //,17x,'Atom Numbers',19x,'KID',
     &                       4x,'Dihedral',/)
               end if
               write (iout,220)  i,ia,ib,ic,id,kprop(i),vprop(i)
  220          format (i6,3x,4i6,9x,2f10.4)
            end if
         end do
      end if
c
c     list 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,230)
  230             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,240)  i,ia,ib,ic,id
  240             format (i6,3x,4i6)
               else if (j .eq. 1) then
                  write (iout,250)  i,ia,ib,ic,id,
     &                              ampli(1),phase(1),fold(1)
  250             format (i6,3x,4i6,10x,f10.3,f8.1,i4)
               else if (j .eq. 2) then
                  write (iout,260)  i,ia,ib,ic,id,(ampli(k),
     &                              phase(k),fold(k),k=1,j)
  260             format (i6,3x,4i6,2x,2(f10.3,f6.1,i4))
               else
                  write (iout,270)  i,ia,ib,ic,id,(ampli(k),
     &                              nint(phase(k)),fold(k),k=1,j)
  270             format (i6,3x,4i6,4x,3(f8.3,i4,'/',i1))
               end if
            end if
         end do
      end if
c
c     list 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,280)
  280             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,290)  i,ia,ib,ic,id
  290             format (i6,3x,4i6)
               else
                  write (iout,300)  i,ia,ib,ic,id,(ampli(k),
     &                              nint(phase(k)),fold(k),k=1,j)
  300             format (i6,3x,4i6,4x,6(f8.3,i4,'/',i1))
               end if
            end if
         end do
      end if
c
c     list 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,310)
  310             format (/,' Stretch-Torsion Parameters :',
     &                    //,17x,'Atom Numbers',10x,'Length',
     &                       5x,'Torsion Terms',/)
               end if
               j = 0
               if (kst(1,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 1
                  ampli(j) = kst(1,i)
                  phase(j) = tors1(2,k)
               end if
               if (kst(2,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 2
                  ampli(j) = kst(2,i)
                  phase(j) = tors2(2,k)
               end if
               if (kst(3,i) .ne. 0.0d0) then
                  j = j + 1
                  fold(j) = 3
                  ampli(j) = kst(3,i)
                  phase(j) = tors3(2,k)
               end if
               write (iout,320)  i,ia,ib,ic,id,bl(ist(2,i)),
     &                           (ampli(k),nint(phase(k)),
     &                           fold(k),k=1,j)
  320          format (i6,3x,4i6,2x,f10.4,1x,3(f8.3,i4,'/',i1))
            end if
         end do
      end if
c
c     list 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(i)
            ic = kion(i)
            if (active(ia) .or. active(ic)) then
               if (header) then
                  header = .false.
                  write (iout,330)
  330             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,340)  i,ia,pchg(i)
  340             format (i6,3x,i6,15x,f10.4)
               else
                  write (iout,350)  i,ia,pchg(i),ib,ic
  350             format (i6,3x,i6,15x,f10.4,5x,i6,4x,i6)
               end if
            end if
         end do
      end if
c
c     list 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,360)
  360             format (/,' Bond Dipole Moment Parameters :',
     &                    //,10x,'Atom Numbers',22x,'Dipole',
     &                       3x,'Position',/)
               end if
               write (iout,370)  i,ia,ib,bdpl(i),sdpl(i)
  370          format (i6,3x,2i6,13x,f16.4,f10.4)
            end if
         end do
      end if
c
c     list 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,380)
  380             format (/,' Atomic Multipole Parameters :',
     &                    //,10x,'Atom Number',3x,'Local Axes',
     &                       ' Definition',10x,'Multipole Moments',/)
               end if
               izaxe = zaxis(i)
               ixaxe = xaxis(i)
               if (izaxe .gt. n)  izaxe = 0
               if (ixaxe .gt. n)  ixaxe = 0
               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
               write (iout,390)  i,ia,izaxe,ixaxe,polaxe(i),
     &                           (pole(j,i),j=1,5),pole(8,i),
     &                           pole(9,i),(pole(j,i),j=11,13)
  390          format (i6,3x,i6,6x,i6,1x,i6,3x,a8,4x,f9.5,
     &                    /,49x,3f9.5,/,49x,f9.5,
     &                    /,49x,2f9.5,/,49x,3f9.5)
            end if
         end do
      end if
c
c     list 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,400)
  400             format (/,' Dipole Polarizability Parameters :',
     &                    //,10x,'Atom Number',9x,'Alpha',8x,
     &                       'Polarization Group',/)
               end if
               write (iout,410)  i,ia,polarity(i),
     &                           (ip11(j,ia),j=1,np11(ia))
  410          format (i6,3x,i6,10x,f10.4,5x,20i6)
            end if
         end do
      end if
c
c     list parameters used for empirical solvation
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.
                  write (iout,420)
  420             format (/,' Empirical Solvation Parameters :',
     &                    //,10x,'Atom Number',13x,'Radius',
     &                       3x,'ASP Value',/)
               end if
               write (iout,430)  k,i,rsolv(i),asolv(i)
  430          format (i6,3x,i6,15x,2f10.4)
            end if
         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 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 tricoordinate central atom, the third
c     bonded atom is stored for use in out-of-plane bending
c
c
      subroutine angles
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmlst.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      integer i,j,k,iangle
c
c
c     loop over all atoms, storing the atoms in each bond angle
c
      nangle = 0
      do i = 1, n
         iangle = 0
         do j = 2, n12(i)
            do k = 1, j-1
               nangle = nangle + 1
               if (nangle .gt. maxang) then
                  write (iout,10)
   10             format (/,' ANGLES  --  Too many Bond Angles;',
     &                       ' Increase MAXANG')
                  call fatal
               end if
               iangle = iangle + 1
               anglist(iangle,i) = nangle
               iang(1,nangle) = i12(k,i)
               iang(2,nangle) = i
               iang(3,nangle) = i12(j,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
      return
      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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bath.i'
      include 'bond.i'
      include 'bound.i'
      include 'inform.i'
      include 'iounit.i'
      include 'mdstuf.i'
      include 'potent.i'
      include 'solute.i'
      include 'usage.i'
      include 'warp.i'
      integer i,nequil
      integer nstep,istep
      integer next,modstep
      real*8 logmass,factor
      real*8 ratio,sigmoid
      real*8 dt,dtdump
      real*8 temp_start,temp_stop
      real*8 tau_start,tau_stop
      real*8 def_start,def_stop
      logical exist
      character*1 answer
      character*8 cooltyp
      character*80 record,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
      temp_start = -1.0d0
      temp_stop = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  temp_start
      call nextarg (string,exist)
      if (exist)  read (string,*,err=10,end=10)  temp_stop
   10 continue
      if (temp_start.lt.0.0d0 .or. temp_stop.lt.0.0d0) then
         temp_start = -1.0d0
         temp_stop = -1.0d0
         write (iout,20)
   20    format (/,' Enter the Initial and Final Temperatures in',
     &              ' Degrees K [1000,0] :  ',$)
         read (input,30)  record
   30    format (a80)
         read (record,*,err=40,end=40)  temp_start,temp_stop
   40    continue
      end if
      if (temp_start .le. 0.0d0)  temp_start = 1000.0d0
      if (temp_stop .le. 0.0d0)  temp_stop = 0.0d0
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
      if (nequil .lt. 0) then
         write (iout,60)
   60    format (/,' Enter the Number of Equilibration Steps [0] :  ',$)
         read (input,70)  nequil
   70    format (i10)
      end if
      if (nequil .le. 0)  nequil = 0
c
c     set the number of dynamics steps for the cooling protocol
c
      nstep = -1
      call nextarg (string,exist)
      if (exist)  read (string,*,err=80,end=80)  nstep
   80 continue
      if (nstep .lt. 0) then
         write (iout,90)
   90    format (/,' Enter the Number of Cooling Protocol Steps',
     &              ' [2000] :  ',$)
         read (input,100)  nstep
  100    format (i10)
      end if
      if (nstep .le. 0)  nstep = 2000
c
c     decide which annealing cooling protocol to use
c
      cooltyp = 'linear'
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,110)
  110    format (/,' Use Linear, Sigmoidal or Exponential Cooling',
     &              ' Protocol ([L], S or E) :  ',$)
         read (input,120)  record
  120    format (a80)
         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=130,end=130)  dt
  130 continue
      if (dt .le. 0.0d0) then
         write (iout,140)
  140    format (/,' Enter the Time Step Length in Femtoseconds',
     &              ' [1.0] :  ',$)
         read (input,150)  dt
  150    format (f20.0)
      end if
      if (dt .le. 0.0d0)  dt = 1.0d0
      dt = 1.0d-3 * dt
c
c     set the time between trajectory snapshot coordinate dumps
c
      dtdump = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=160,end=160)  dtdump
  160 continue
      if (dtdump .lt. 0.0d0) then
         write (iout,170)
  170    format (/,' Enter Time between Dumps in Picoseconds',
     &              ' [0.1] :  ',$)
         read (input,180)  dtdump
  180    format (f20.0)
      end if
      if (dtdump .le. 0.0d0)  dtdump = 0.1d0
      iwrite = nint(dtdump/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=190,end=190)  logmass
  190 continue
      if (logmass .lt. 0.0d0) then
         write (iout,200)
  200    format (/,' Increase Atomic Weights by a Factor of',
     &              ' 10^x [x=0.0] :  ',$)
         read (input,210)  logmass
  210    format (f20.0)
      end if
      if (logmass .le. 0.0d0) then
         logmass = 0.0d0
      else
         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_deform) then
         def_stop = -1.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=220,end=220)  def_stop
  220    continue
         if (def_stop .le. 0.0d0) then
            write (iout,230)
  230       format (/,' Enter Final Desired Deformation Parameter',
     &                 ' [0.0] :  ',$)
            read (input,240)  def_stop
  240       format (f20.0)
         end if
         if (def_stop .le. 0.0d0)  def_stop = 0.0d0
         def_start = deform - def_stop
         if (def_start .le. 0.0d0)  def_start = 0.0d0
      end if
c
c     set values for temperature, pressure and coupling baths
c
      isothermal = .true.
      isobaric = .false.
      tau_start = 100.0d0 * dt
      tau_stop = 10.0d0 * dt
      kelvin = temp_start
      tautemp = tau_start
c
c     initialize any dynamics options and rattle constraints
c
      call mdinit
      call shakeup
c
c     print out a header lines for the equilibration phase
c
      if (nequil .ne. 0) then
         write (iout,250)
  250    format (/,' Simulated Annealing Equilibration Phase')
         write (iout,260)  nequil,dt,logmass,temp_start,temp_start
  260    format (/,' Steps:',i6,3x,'Time/Step:',f6.3,' ps',3x,
     &              'LogMass:',f5.2,3x,'Temp:',f7.1,' to',f7.1)
      end if
c
c     take the dynamics steps for the equilibration phase
c
      do istep = 1, nequil
         modstep = mod(istep,iprint)
         if (verbose .and. modstep.eq.1) then
            write (iout,270)
  270       format (/,'    MD Step      E Total   E Potential',
     &                 '   E Kinetic       Temp',/)
         end if
         if (integrate .eq. 'VERLET') then
            call verlet (istep,dt)
         else if (integrate .eq. 'STOCHASTIC') then
            call sdstep (istep,dt)
         else
            call beeman (istep,dt)
         end if
         if (nuse.eq.n .and. modstep.eq.0)  call mdrest
      end do
c
c     start the cooling phase from the end of equilibration phase
c
      if (nequil .ne. 0)  call mdinit
c
c     print out a header lines for the cooling protocol
c
      write (iout,280)
  280 format (/,' Simulated Annealing Cooling Protocol')
      write (iout,290)  nstep,dt,logmass,temp_start,temp_stop
  290 format (/,' Steps:',i6,3x,'Time/Step:',f6.3,' ps',3x,
     &           'LogMass:',f5.2,3x,'Temp:',f7.1,' to',f7.1)
c
c     take the desired number of molecular dynamics steps
c
      do istep = 1, nstep
         modstep = mod(istep,iprint)
         if (verbose .and. modstep.eq.1) then
            if (isobaric) then
               write (iout,300)
  300          format (/,'    MD Step      E Total   E Potential',
     &                    '   E Kinetic       Temp       Pres',/)
            else
               write (iout,310)
  310          format (/,'    MD Step      E Total   E Potential',
     &                    '   E Kinetic       Temp',/)
            end if
         end if
c
c     set target temperature using the desired cooling protocol
c
         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 = temp_start*(1.0d0-ratio) + temp_stop*ratio
         tautemp = tau_start*(1.0d0-ratio) + tau_stop*ratio
c
c     set the deformation value if potential smoothing is used
c
         if (use_deform) then
            ratio = (1.0d0-dble(istep)/dble(nstep))**3
            deform = def_stop + ratio*def_start
         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. 'STOCHASTIC') then
            call sdstep (istep,dt)
         else
            call beeman (istep,dt)
         end if
         if (modstep.eq.0 .and. nuse.eq.n) then
            if (integrate .ne. 'STOCHASTIC')  call mdrest
         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 archive  --  create or extract from an archive  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "archive" is a utility program for coordinate files which
c     concatenates multiple coordinate sets into a single archive
c     file, or extracts individual coordinate sets from an archive
c
c
      program archive
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'iounit.i'
      integer i,iarc,ixyz
      integer start,stop,step
      integer lext,next,current
      integer freeunit,trimtext
      integer lines,last,nold
      integer leng1,leng2
      logical exist,query
      character*1 letter,answer
      character*4 output
      character*7 ext
      character*8 mode
      character*60 arcfile,coordfile
      character*80 record,string
c
c
c     get the name to use for the coordinate archive file
c
      call initial
      call nextarg (filename,exist)
      if (.not. exist) then
         write (iout,10)
   10    format (/,' Enter Name of the Coordinate Archive File :  ',$)
         read (input,20)  filename
   20    format (a60)
      end if
      call basefile (filename)
      iarc = freeunit ()
c
c     decide whether to compress or extract files
c
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,30)
   30    format (/,' Create (C) or Extract (E) from an Archive',
     &              ' [C] :  ',$)
         read (input,40)  record
   40    format (a80)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'E') then
         mode = 'extract '
      else
         mode = 'compress'
      end if
c
c     make separate files into a single concatenated file
c
      if (mode .eq. 'compress') then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,50)
   50       format (/,' Use TINKER (T), XMol XYZ (X) or MSI',
     &                 ' InsightII (M) Format [T] :  ',$)
            read (input,60)  record
   60       format (a80)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         last = leng
         do i = 1, leng
            letter = filename(i:i)
            if (letter .eq. '/')  last = leng
c           if (letter .eq. '\')  last = leng
            if (ichar(letter) .eq. 92)  last = leng
            if (letter .eq. ']')  last = leng
            if (letter .eq. ':')  last = leng
            if (letter .eq. '~')  last = leng
            if (letter .eq. '.')  last = i - 1
         end do
         leng = min(leng,last)
         if (answer .eq. 'X') then
            output = 'xmol'
            arcfile = filename(1:leng)//'.xmol'
         else if (answer .eq. 'M') then
            output = 'msi'
            arcfile = filename(1:leng)//'.msi'
         else
            output = 'xyz '
            arcfile = filename(1:leng)
            call suffix (arcfile,'arc')
         end if
         start = 0
         stop = 0
         step = 0
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=70,end=70)  start
            query = .false.
         end if
         call nextarg (string,exist)
         if (exist)  read (string,*,err=70,end=70)  stop
         call nextarg (string,exist)
         if (exist)  read (string,*,err=70,end=70)  step
   70    continue
         if (query) then
            write (iout,80)
   80       format (/,' Numbers of First & Last File and Step',
     &                 ' Increment :  ',$)
            read (input,90)  record
   90       format (a80)
            read (record,*,err=100,end=100)  start,stop,step
  100       continue
         end if
         if (stop .eq. 0)  stop = start
         if (step .eq. 0)  step = 1
         call version (arcfile,'new')
         open (unit=iarc,file=arcfile,status='new')
c
c     cycle over the user specified coordinate files
c
         nold = 0
         i = start
         dowhile (i.ge.start .and. i.le.stop)
            ixyz = freeunit ()
            lext = 3
            call numeral (i,ext,lext)
            coordfile = filename(1:leng)//'.'//ext(1:lext)
            call version (coordfile,'old')
            inquire (file=coordfile,exist=exist)
            if (.not.exist .and. i.lt.100) then
               lext = 2
               call numeral (i,ext,lext)
               coordfile = filename(1:leng)//'.'//ext(1:lext)
               call version (coordfile,'old')
               inquire (file=coordfile,exist=exist)
            end if
            if (.not.exist .and. i.lt.10) then
               lext = 1
               call numeral (i,ext,lext)
               coordfile = filename(1:leng)//'.'//ext(1:lext)
               call version (coordfile,'old')
               inquire (file=coordfile,exist=exist)
            end if
            if (exist) then
               open (unit=ixyz,file=coordfile,status='old')
               rewind (unit=ixyz)
               call readxyz (ixyz)
               close (unit=ixyz)
               if (output .eq. 'xmol') then
                  if (n .ne. nold)  call active
                  call prtxmol (iarc)
               else if (output .eq. 'msi') then
                  if (n .ne. nold)  call active
                  call prtmsi (iarc)
               else
                  call prtxyz (iarc)
               end if
            end if
            i = i + step
            nold = n
         end do
c
c     extract coordinates from a concatenated file
c
      else if (mode .eq. 'extract ') then
  110    continue
         arcfile = filename(1:leng)
         call suffix (arcfile,'arc')
         call version (arcfile,'old')
         inquire (file=arcfile,exist=exist)
         if (exist) then
            open (unit=iarc,file=arcfile,status='old')
         else
            write (iout,120)
  120       format (/,' Enter Name of the Coordinate Archive File',
     &                 ' :  ',$)
            read (input,130)  filename
  130       format (a60)
            leng = trimtext (filename)
            goto 110
         end if
         rewind (unit=iarc)
         call readxyz (iarc)
         rewind (unit=iarc)
         current = 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
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=140,end=140)  start
            query = .false.
         end if
         call nextarg (string,exist)
         if (exist)  read (string,*,err=140,end=140)  stop
  140    continue
         if (query) then
            write (iout,150)
  150       format (/,' Numbers of First & Last File to Extract',
     &                 ' [<CR>=Exit] :  ',$)
            read (input,160)  record
  160       format (a80)
            read (record,*,err=170,end=170)  start,stop
  170       continue
         end if
         if (stop .eq. 0)  stop = start
         dowhile (start .ne. 0)
            if (start .le. current) then
               current = 1
               rewind (unit=iarc)
            end if
            lines = (start-current) * (n+1)
            do i = 1, lines
               read (iarc,180)
  180          format ()
            end do
            do i = start, stop
               lext = 3
               call numeral (i,ext,lext)
               call readxyz (iarc)
               ixyz = freeunit ()
               coordfile = filename(1:leng)//'.'//ext(1:lext)
               call version (coordfile,'new')
               open (unit=ixyz,file=coordfile,status='new')
               call prtxyz (ixyz)
               close (unit=ixyz)
            end do
            current = stop
            start = 0
            stop = 0
            query = .true.
            call nextarg (string,exist)
            if (exist) then
               read (string,*,err=190,end=190)  start
               query = .false.
            end if
            call nextarg (string,exist)
            if (exist)  read (string,*,err=190,end=190)  stop
  190       continue
            if (query) then
               write (iout,200)
  200          format (/,' Numbers of First & Last File to Extract',
     &                    ' [<CR>=Exit] :  ',$)
               read (input,210)  record
  210          format (a80)
               read (record,*,err=220,end=220)  start,stop
  220          continue
            end if
            if (stop .eq. 0)  stop = start
         end do
      end if
      close (unit=iarc)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine prtxmol  --  output of a generic XYZ archive  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "prtxmol" writes out a set of Cartesian coordinates for
c     all active atoms in a simple, generic XYZ format originally
c     due to the XMOL program
c
c
      subroutine prtxmol (ixmol)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'titles.i'
      include 'usage.i'
      integer i,j,ixmol
      logical opened
      character*3 atmnam
      character*60 coordfile
c
c
c     open output unit if not already done
c
      inquire (unit=ixmol,opened=opened)
      if (.not. opened) then
         coordfile = filename(1:leng)//'.xmol'
         call version (coordfile,'new')
         open (unit=ixmol,file=coordfile,status='new')
      end if
c
c     write out the number of active atoms and the title
c
      if (ltitle .eq. 0) then
         write (ixmol,10)  nuse
   10    format (i6,/)
      else
         write (ixmol,20)  nuse,title(1:ltitle)
   20    format (i6,2x,a,/)
      end if
c
c     write the atom name and coordinates for each active atom
c
      do i = 1, n
         if (use(i)) then
            atmnam = name(i)
            do j = 1, 3
               if ((atmnam(j:j).lt.'a'.or.atmnam(j:j).gt.'z') .and.
     &             (atmnam(j:j).lt.'A'.or.atmnam(j:j).gt.'Z'))
     &            atmnam(j:j) = ' '
            end do
            if (atmnam(1:1) .eq. 'H')  atmnam(2:3) = '  '
            if (atmnam(1:1) .eq. 'C')  atmnam(2:3) = '  '
            if (atmnam(1:1) .eq. 'N')  atmnam(2:3) = '  '
            if (atmnam(1:1) .eq. 'O')  atmnam(2:3) = '  '
            if (atmnam(1:1) .eq. 'S')  atmnam(2:3) = '  '
            write (ixmol,30)  atmnam,x(i),y(i),z(i)
   30       format (5x,a3,2x,3f12.6)
         end if
      end do
      if (.not. opened)  close (unit=ixmol)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine prtmsi  --  output of an MSI/InsightII archive  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "prtmsi" writes out a set of Cartesian coordinates for
c     all active atoms in the MSI Insight II archive format
c
c
      subroutine prtmsi (imsi)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'titles.i'
      include 'usage.i'
      integer i,k,imsi
      logical opened
      character*60 coordfile
c
c
c     open output unit if not already done
c
      inquire (unit=imsi,opened=opened)
      if (.not. opened) then
         coordfile = filename(1:leng)//'.msi'
         call version (coordfile,'new')
         open (unit=imsi,file=coordfile,status='new')
      end if
c
c     write out the title and the date/time line
c
      if (ltitle .eq. 0) then
         write (imsi,10)
   10    format (/,'date:')
      else
         write (imsi,20)  title(1:ltitle)
   20    format (a,/,'date:')
      end if
c
c     write the coordinates for each active atom
c
      k = 0
      do i = 1, n
         if (use(i)) then
            k = k + 1
            write (imsi,30)  name(i),x(i),y(i),z(i),k
   30       format (a3,2x,3f15.6,4x,i6)
         end if
      end do
c
c     finally, write the end lines for this frame
c
      write (imsi,40)
   40 format ('end',/,'end')
      if (.not. opened)  close (unit=imsi)
      return
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      integer i,j,k,m
      integer jj,kk
c
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
         call sort (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 20
               do m = 1, n12(i)
                  if (kk .eq. i12(m,i))  goto 20
               end do
               do m = 1, n13(i)
                  if (kk .eq. i13(m,i))  goto 20
               end do
               n14(i) = n14(i) + 1
               i14(n14(i),i) = kk
   20          continue
            end do
         end do
         call sort (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 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
               do m = 1, n14(i)
                  if (kk .eq. i14(m,i))  goto 30
               end do
               n15(i) = n15(i) + 1
               i15(n15(i),i) = kk
   30          continue
            end do
         end do
         call sort (n15(i),i15(1,i))
      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 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
c
      subroutine basefile (string)
      implicit none
      include 'files.i'
      integer i,k,trimtext
      character*1 letter
      character*60 string
c
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. 92)  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
      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. 92)  k = i
         if (letter .eq. ']')  k = i
         if (letter .eq. ':')  k = i
         if (letter .eq. '~')  k = i
         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)  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 single molecular dynamics time step
c     by means of a Beeman multistep recursion formula; the
c     actual coefficients are Brooks' "Better Beeman" values
c
c     literature reference :
c
c     B. R. Brooks, "Algorithms for Molecular Dynamics at Constant
c     Temperature and Pressure", DCRT Report, NIH, April 1988
c
c
      subroutine beeman (istep,dt)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bath.i'
      include 'mdstuf.i'
      include 'moldyn.i'
      include 'shake.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,istep
      real*8 dt,dt_8,dt2_8
      real*8 etot,ekin,epot
      real*8 temp,pres
      real*8 xterm,yterm,zterm
      real*8 xold(maxatm)
      real*8 yold(maxatm)
      real*8 zold(maxatm)
      real*8 derivs(3,maxatm)
c
c
c     set some time values for the dynamics integration
c
      dt_8 = dt / 8.0d0
      dt2_8 = dt * dt_8
c
c     store the current atom positions, then find new atom
c     positions and half-step velocities via Beeman recursion
c
      do i = 1, n
         if (use(i)) then
            xold(i) = x(i)
            yold(i) = y(i)
            zold(i) = z(i)
            xterm = 5.0d0*a(1,i) - aold(1,i)
            yterm = 5.0d0*a(2,i) - aold(2,i)
            zterm = 5.0d0*a(3,i) - aold(3,i)
            x(i) = x(i) + v(1,i)*dt + xterm*dt2_8
            y(i) = y(i) + v(2,i)*dt + yterm*dt2_8
            z(i) = z(i) + v(3,i)*dt + zterm*dt2_8
            v(1,i) = v(1,i) + xterm*dt_8
            v(2,i) = v(2,i) + yterm*dt_8
            v(3,i) = v(3,i) + zterm*dt_8
         end if
      end do
c
c     apply "rattle" to correct atom positions and velocities
c
      if (use_rattle)  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 Beeman recursion
c
      do i = 1, n
         if (use(i)) then
            do j = 1, 3
               aold(j,i) = a(j,i)
               a(j,i) = -convert * derivs(j,i) / mass(i)
               v(j,i) = v(j,i) + (3.0d0*a(j,i)+aold(j,i))*dt_8
            end do
         end if
      end do
c
c     use "rattle" method to get corrected full-step velocities
c
      if (use_rattle)  call rattle2 (dt)
c
c     sum the total kinetic energy over all atoms
c
      ekin = 0.0d0
      do i = 1, n
         if (use(i)) then
            do j = 1, 3
               ekin = ekin + mass(i)*v(j,i)**2
            end do
         end if
      end do
      ekin = 0.5d0 * ekin / convert
c
c     determine the system temperature and total energy
c
      temp = 2.0d0 * ekin / (dble(nfree) * gasconst)
      etot = ekin + epot
c
c     control temperature and pressure via external bath coupling
c
      if (isothermal)  call temper (dt,temp)
      if (isobaric)  call pressure (dt,pres,ekin)
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,ekin,temp,pres)
      call mdsave (istep)
      return
      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
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
      dowhile (.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
      dowhile (.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,betacf,gammln
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 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
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'iounit.i'
      integer i,j,k,m
c
c
c     loop over all atoms, storing the atoms 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
               if (nbond .gt. maxbnd) then
                  write (iout,10)
   10             format (/,' BONDS  --  Too many Bonds; Increase',
     &                       ' MAXBND')
                  call fatal
               end if
               ibnd(1,nbond) = i
               ibnd(2,nbond) = k
               bndlist(j,i) = nbond
               do m = 1, n12(k)
                  if (i .eq. i12(m,k)) then
                     bndlist(m,k) = nbond
                     goto 20
                  end if
               end do
   20          continue
            end if
         end do
      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 born  --  find Born radii for GB/SA solvation  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "born" computes the Born radius of each atom for use with
c     the various GB/SA 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)  (Original Still; 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     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)  (Analytical Continuum Electrostatics, ACE)
c
c
      subroutine born
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'solute.i'
      include 'units.i'
      integer i,j,k,it,kt
      integer skip(maxatm)
      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,sum
      real*8 lik,lik2,uik,uik2
      real*8 xr,yr,zr,rvdw
      real*8 r,r2,r3,r4
      real*8 gpi,pip5,p5inv
      real*8 theta,term,ccf
      real*8 expterm,rmu
      real*8 b0,gself,third
      real*8 roff(maxatm)
      logical done
c
c
c     compute atomic radii modified by the dielectric offset
c
      do i = 1, n
         roff(i) = rsolv(i) + doffset
      end do
c
c     get the Born radii via the numerical Still method
c
      if (solvtyp .eq. 'ONION') then
         tinit = 0.1d0
         ratio = 1.5d0
         do i = 1, n
            t = tinit
            rold = roff(i)
            total = 0.0d0
            done = .false.
            dowhile (.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 the analytical Still method;
c     note this code only loops over the variable parts
c     
      else if (solvtyp .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 (solvtyp .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)
                  sk2 = sk * sk
                  if (ri .lt. r+sk) then
                     lik = 1.0d0 / max(ri,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)
                     sum = sum - 0.5d0*term
                  end if
               end if
            end do
            rborn(i) = 1.0d0 / sum
            rborn(i) = max(ri,rborn(i))
         end do
c     
c     get the Born radii via analytical continuum electrostatics
c     
      else if (solvtyp .eq. 'ACE') then
         third = 1.0d0 / 3.0d0
         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
      end if
c
c     write out the final Born radius value for each atom
c
      if (debug) then
         write (iout,10)
   10    format (/,' Born Radii for Individual Atoms :',/)
         k = 1
         dowhile (k .le. n)
            write (iout,20)  (i,rborn(i),i=k,min(k+4,n))
   20       format (1x,5(i7,f8.3))
            k = k + 5
         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 bounds  --  check periodic boundary conditions  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "bounds" finds the center of mass of each molecule, translates
c     any stray molecules back into the periodic box, and saves the
c     offset of each atom relative to the molecular center of mass
c
c
      subroutine bounds
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'centre.i'
      include 'molcul.i'
      integer i,j,k
      integer init,stop
      real*8 weight
      real*8 xmid,ymid,zmid
      real*8 xfrac,yfrac,zfrac
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)
            weight = mass(k)
            xmid = xmid + x(k)*weight
            ymid = ymid + y(k)*weight
            zmid = zmid + z(k)*weight
         end do
         weight = molmass(i)
         xmid = xmid / weight
         ymid = ymid / weight
         zmid = zmid / weight
c
c     store coordinates of atoms relative to center of mass
c
         do j = init, stop
            k = kmol(j)
            xcm(k) = x(k) - xmid
            ycm(k) = y(k) - ymid
            zcm(k) = z(k) - zmid
         end do
c
c     get fractional coordinates of center of mass
c
         if (orthogonal .or. octahedron) then
            zfrac = zmid
            yfrac = ymid
            xfrac = xmid
         else if (monoclinic) then
            zfrac = zmid / beta_sin
            yfrac = ymid
            xfrac = xmid - zfrac*beta_cos
         else if (triclinic) then
            zfrac = zmid / gamma_term
            yfrac = (ymid - zfrac*beta_term) / gamma_sin
            xfrac = xmid - yfrac*gamma_cos - zfrac*beta_cos
         end if
c
c     translate center of mass into the periodic box
c
         dowhile (xfrac .gt. xbox2)
            xfrac = xfrac - xbox
         end do
         dowhile (xfrac .lt. -xbox2)
            xfrac = xfrac + xbox
         end do
         dowhile (yfrac .gt. ybox2)
            yfrac = yfrac - ybox
         end do
         dowhile (yfrac .lt. -ybox2)
            yfrac = yfrac + ybox
         end do
         dowhile (zfrac .gt. zbox2)
            zfrac = zfrac - zbox
         end do
         dowhile (zfrac .lt. -zbox2)
            zfrac = zfrac + zbox
         end do
c
c     truncated octahedron needs to have corners removed
c
         if (octahedron) then
            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
         end if
c
c     convert fractional center of mass back to Cartesian
c
         if (orthogonal .or. octahedron) then
            xmid = xfrac
            ymid = yfrac
            zmid = zfrac
         else if (monoclinic) then
            xmid = xfrac + zfrac*beta_cos
            ymid = yfrac
            zmid = zfrac * beta_sin
         else if (triclinic) then
            xmid = xfrac + yfrac*gamma_cos + zfrac*beta_cos
            ymid = yfrac*gamma_sin + zfrac*beta_term
            zmid = zfrac * gamma_term
         end if
c
c     translate atomic coordinates based upon center of mass
c
         do j = init, stop
            k = kmol(j)
            x(k) = xcm(k) + xmid
            y(k) = ycm(k) + ymid
            z(k) = zcm(k) + zmid
         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 bspline  --  get 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(n)
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 bspline1  --  get B-spline coeffs & derivs  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "bspline1" calculates the coefficients and derivative
c     coefficients for an n-th order B-spline approximation
c
c
      subroutine bspline1 (x,n,c,d)
      implicit none
      integer i,k,n
      real*8 x,denom
      real*8 c(n),d(n)
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-1-th order
c
      do k = 3, n-1
         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
c
c     get the derivative from n-1-th order coefficients
c
      d(1) = -c(1)
      do i = 2, n
         d(i) = c(i-1) - c(i)
      end do
c
c     use one final recursion to get n-th order coefficients
c
      denom = 1.0d0 / dble(n-1)
      c(n) = x * c(n-1) * denom
      do i = 1, n-2
         c(n-i) = ((x+dble(i))*c(n-i-1)
     &               + (dble(n-i)-x)*c(n-i)) * denom
      end do
      c(1) = (1.0d0-x) * c(1) * denom
      return
      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 Unix-style "itime" and "idate" intrinsic functions,
c     this code works for all compilers except those noted below
c
      integer hms(3)
      call itime (hms)
      hour = hms(1)
      minute = hms(2)
      second = hms(3)
      call idate (month,day,year)
c
c     code for the IBM AIX xlf compiler appends an underscore
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)
c
c     code for Hewlett-Packard HP-UX and Compaq OpenVMS systems;
c     for the HP systems the +E1 compiler option is required
c
c     real secnds
c     second = int(secnds(0.0))
c     hour = mod(second,3600)
c     second = second - 3600*hour
c     minute = mod(second,60)
c     second = second - 60*minute
c     call idate (month,day,year)
      return
      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)
      implicit none
      include 'sizes.i'
      include 'align.i'
      integer i,k,n1,n2
      real*8 weight,norm
      real*8 xmid,ymid,zmid
      real*8 x1(maxatm),x2(maxatm)
      real*8 y1(maxatm),y2(maxatm)
      real*8 z1(maxatm),z2(maxatm)
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)
         weight = wfit(i)
         xmid = xmid + x2(k)*weight
         ymid = ymid + y2(k)*weight
         zmid = zmid + z2(k)*weight
         norm = norm + weight
      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)
         weight = wfit(i)
         xmid = xmid + x1(k)*weight
         ymid = ymid + y1(k)*weight
         zmid = zmid + z1(k)*weight
         norm = norm + weight
      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)  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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      integer i,j
      real*8 xi,yi,zi,r2
      logical header
c
c
c     loop over atom pairs testing for identical coordinates
c
      header = .true.
      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 .le. 0.0d0) then
               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
      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 solve  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "cholesky" uses a modified Cholesky method to solve the linear
c     system Ax = b, returning "x" in "b"; "A" is assumed to be a
c     real symmetric positive definite matrix with diagonal and upper
c     triangle stored by rows in "A"; thus the actual size of the
c     passed portion of "A" is nvar*(nvar+1)/2
c
c     literature reference:
c
c     R. S. Martin, G. Peters and J. H. Wilkinson, Numer. Math.,
c     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(nvar*(nvar+1)/2)
      real*8 b(nvar)
c
c
c     use Cholesky to reduce "A" to (L)(D)(L transpose) = A;
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     now, 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)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine clock  --  find elapsed time for current job  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "clock" determines elapsed CPU time in seconds since the
c     start of the job
c
c     note only one of the various implementations below should
c     be activated by removing comment characters
c
c
      subroutine clock (seconds)
      implicit none
      real*8 seconds
c
c
c     use the Unix-style "etime" intrinsic function, this code
c     works for all compilers except those noted below
c
      real etime,times(2)
      seconds = dble(etime(times))
c
c     code for Windows PC's under Compaq Visual Fortran
c
c     real time
c     call cpu_time (time)
c     seconds = dble(time)
c
c     code for the IBM AIX xlf compiler appends an underscore
c
c     real etime_,times(2)
c     seconds = dble(etime_(times))
c
c     code for Hewlett-Packard HP-UX only gives wall clock time;
c     for the HP systems the +E1 compiler option is required
c
c     real secnds,start
c     logical initial
c     save initial,start
c     data initial  / .true. /
c     if (initial) then
c        initial = .false.
c        start = secnds (0.0)
c     end if
c     seconds = secnds (start)
c
c     code for Compaq OpenVMS system uses a special system call
c
c     include '($jpidef)'
c     structure /itmlst3_1item/
c        structure item
c           integer*2 buffer_length
c           integer*2 code
c           integer*4 buffer_address
c           integer*4 retlen_address
c        end structure
c     end structure
c     record /itmlst3_1item/ jpi_list
c     integer*4 cputime
c     jpi_list.item.code = jpi$_cputim
c     jpi_list.item.buffer_length = 4
c     jpi_list.item.buffer_address = %loc(cputime)
c     jpi_list.item.retlen_address = 0
c     call sys$getjpiw (,,,jpi_list,,,)
c     seconds = 0.01d0 * dble(cputime)
      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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cutoff.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'molcul.i'
      integer i,j,k
      integer inum,jnum
      integer last,next
      integer gnum,ga,gb
      integer nlist
      integer list(maxatm)
      real*8 wg
      logical header
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     set defaults for the group atom list and weight options
c
      use_group = .false.
      use_intra = .false.
      use_inter = .false.
      do i = 1, n
         grplist(i) = 0
      end do
      do i = 1, maxgrp
         igrp(1,i) = 1
         igrp(2,i) = 0
      end do
      do i = 0, maxgrp
         do j = 0, maxgrp
            wgrp(j,i) = 0.0d0
         end do
      end do
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, n
               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:80)
            read (string,*,err=20,end=20)  (list(i),i=1,n)
   20       continue
            i = 1
            dowhile (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.
            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:80)
            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
c
c     get keywords to select intragroup or intergroup 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
      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 nonempty group
c
      ngrp = 0
      igrp(1,ngrp) = 1
      do i = 1, n
         j = list(i)
         if (j .ne. last) then
            igrp(2,ngrp) = i - 1
            ngrp = ngrp + 1
            igrp(1,ngrp) = i
            grpnum(ngrp) = j
            last = j
         end if
      end do
      igrp(2,ngrp) = n
c
c     sort the list of atoms in each group by atom number
c
      do i = 0, maxgrp
         j = igrp(2,i) - igrp(1,i) + 1
         call sort (j,kgrp(igrp(1,i)))
      end do
c
c     renumber the group list and weights to remove empty groups
c
      do i = 1, ngrp
         do j = igrp(1,i), igrp(2,i)
            grplist(kgrp(j)) = i
         end do
      end do
      do i = 1, ngrp
         inum = grpnum(i)
         wgrp(0,i) = wgrp(0,inum)
         wgrp(i,0) = wgrp(inum,0)
         do j = 1, ngrp
            jnum = grpnum(j)
            wgrp(j,i) = wgrp(jnum,inum)
            if (jnum.ne.j .or. inum.ne.i)  wgrp(jnum,inum) = 0.0d0
         end do
      end do
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     turn off bounds, replicas and Ewald for intragroup calculations
c
      if (use_intra) then
         use_bounds = .false.
         use_replica = .false.
         call cutoffs
         use_ewald = .false.
      end if
c
c     compute the total mass of all atoms in each group
c
      do i = 1, 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     output the final list of atoms in each group
c
      if (debug .and. use_group) then
         do i = 1, ngrp
            nlist = 0
            do j = igrp(1,i), igrp(2,i)
               nlist = nlist + 1
               list(nlist) = kgrp(j)
            end do
            if (nlist .ne. 0) then
               write (iout,50)  grpnum(i)
   50          format (/,' List of Atoms Contained in Group',i3,' :',/)
               write (iout,60)  (list(j),j=1,nlist)
   60          format (3x,10i7)
            end if
         end do
      end if
c
c     output the weights for intragroup and intergroup interactions
c
      if (debug .and. use_group) then
         header = .true.
         do i = 1, 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)  grpnum(i),grpnum(j),wgrp(j,i)
   80                format (5x,2i6,12x,'IntraGroup',5x,f12.4)
                  else
                     write (iout,90)  grpnum(i),grpnum(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,h_init,h_stop,h_index,
     &                   c_init,c_stop,c_index,c_value)
      implicit none
      include 'sizes.i'
      integer i,j,k
      integer m,nvar
      integer h_init(maxvar)
      integer h_stop(maxvar)
      integer c_init(maxvar)
      integer c_stop(maxvar)
      integer h_index(maxhess)
      integer c_index(maxhess)
      integer c_value(maxhess)
c
c
c     zero out beginning and end marker for each column
c
      do i = 1, nvar
         c_init(i) = 0
         c_stop(i) = 0
      end do
c
c     count the number of elements in each column
c
      do i = 1, nvar
         do j = h_init(i), h_stop(i)
            k = h_index(j)
            c_stop(k) = c_stop(k) + 1
         end do
      end do
c
c     set each beginning marker just beyond
c     the last element for its column
c
      c_init(1) = c_stop(1) + 1
      do i = 2, nvar
         c_init(i) = c_init(i-1) + c_stop(i)
      end do
c
c     set column index by scanning rows in reverse order
c
      do i = nvar, 1, -1
         do j = h_init(i), h_stop(i)
            k = h_index(j)
            m = c_init(k) - 1
            c_init(k) = m
            c_index(m) = i
            c_value(m) = j
         end do
      end do
c
c     convert "c_stop" from number of elements
c     in column to end marker for the column
c
      do i = 1, nvar
         c_stop(i) = c_init(i) + c_stop(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
      implicit none
      include 'argue.i'
      integer i,iargc
      character*1 letter
      character*20 blank
c
c
c     initialize command line arguments as blank strings
c
      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-1
         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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'zcoord.i'
      include 'zclose.i'
      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
      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     nep     number of convex edges
c     nfs     number of saddle faces
c     ncy     number of cycles
c     fpncy   number of cycles bounding convex face
c     nfp     number of convex faces
c     cynep   number of convex edges in cycle
c
c     a       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     anbr    begin and end pointers for atoms neighbors
c     nbr     atom numbers of neighbors
c     nbrt    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     v       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     epc     convex edge circle number
c     epv     convex edge vertex numbers
c     afe     first convex edge of each atom
c     ale     last convex edge of each atom
c     epnext  pointer to next convex edge of atom
c     fsen    saddle face concave edge numbers
c     fsep    saddle face convex edge numbers
c     cyep    cycle convex edge numbers
c     fpa     atom number of convex face
c     fpcy    convex face cycle numbers
c
c
      subroutine connolly (volume,area,radius,probe,exclude)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'faces.i'
      include 'math.i'
      integer i
      real*8 volume,area
      real*8 probe,exclude
      real*8 radius(maxatm)
c
c
c     set the probe radius and the number of atoms
c
      pr = probe
      na = n
c
c     set atom coordinates and radii, the excluded buffer
c     radius ("exclude") is added to atomic radii
c
      do i = 1, na
         a(1,i) = x(i)
         a(2,i) = y(i)
         a(3,i) = z(i)
         ar(i) = radius(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     find the analytical volume and surface area
c
      call neighbor
      call torus
      call place
      call compress
      call saddles
      call contact
      call vam (volume,area)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine neighbor  --  list of neighboring atom pairs  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "neighbor" finds all of the neighbors of each atom
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 neighbor
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer maxnbra,maxcube
      parameter (maxnbra=1000)
      parameter (maxcube=40)
      integer i,j,k,m,iptr,i1,j1,k1,iatom,jatom
      integer jnbr,ici,icj,ick,jci,jcj,jck
      integer iuse,jmin,jminbr,jmold
      integer nnbr,nnbra,nbra(maxnbra),itnl(maxnbra)
      integer ico(3,maxatm),icuptr(maxatm)
      integer icube(maxcube,maxcube,maxcube)
      real*8 radmax,width,sum,sumi,dist2,d2,r2
      real*8 vect1,vect2,vect3,comin(3)
      logical scube(maxcube,maxcube,maxcube)
      logical sscube(maxcube,maxcube,maxcube)
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(a(1,i),a(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) = a(k,1)
      end do
      do i = 1, na
         do k = 1, 3
            if (a(k,i) .lt. comin(k))  comin(k) = a(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     set up cube arrays; first the integer coordinate arrays
c
      do i = 1, na
         do k = 1, 3
            ico(k,i) = (a(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(a(1,iatom),a(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
      nnbr = 0
c
c     zero pointers for atom and find its cube
c
      do i = 1, na
         nnbra = 0
         nosurf(i) = skip(i)
         anbr(1,i) = 0
         anbr(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(a(1,j) - a(1,i))
                  if (vect1 .ge. sum)  goto 50
                  vect2 = abs(a(2,j) - a(2,i))
                  if (vect2 .ge. sum)  goto 50
                  vect3 = abs(a(3,j) - a(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.
                  nnbra = nnbra + 1
                  if (nnbra .gt. maxnbra) then
                     call cerror ('Too many Neighbors for Atom')
                  end if
                  itnl(nnbra) = 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 iuse = 1, nnbra
            jmin = na + 1
            do jnbr = 1, nnbra
c
c     don't use ones already sorted
c
               if (itnl(jnbr) .gt. jmold) then
                  if (itnl(jnbr) .lt. jmin) then
                     jmin = itnl(jnbr)
                     jminbr = jnbr
                  end if
               end if
            end do
            jmold = jmin
            jnbr = jminbr
            jatom = itnl(jnbr)
            nbra(iuse) = jatom
         end do
c
c     set up pointers to first and last neighbors of atom
c
         if (nnbra .gt. 0) then
            anbr(1,i) = nnbr + 1
            do m = 1, nnbra
               nnbr = nnbr + 1
               if (nnbr .gt. maxnbr) then
                  call cerror ('Too many Neighboring Atom Pairs')
               end if
               nbr(nnbr) = nbra(m)
            end do
            anbr(2,i) = nnbr
         end if
   70    continue
      end do
      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
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer ia,ibeg,iend,ja,jn
      real*8 tt(3),ttr,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 = anbr(1,ia)
            iend = anbr(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
                  nbrt(jn) = 0
c
c     get atom number of neighbor
c
                  ja = nbr(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
                        nbrt(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
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer maxmut
      parameter (maxmut=500)
      integer k,ke,kv,l,l1,l2,ia,ja,ka
      integer ik,ip,jk,km,la,lm,lkf,itt
      integer nmut,iend,jend,iptr,jptr
      integer mut(maxmut),ikt(maxmut)
      integer jkt(maxmut),lknbr(maxnbr)
      real*8 dist2,d2,det,hij,hijk
      real*8 disnbr(maxmut),sumnbr(maxmut)
      real*8 uij(3),bij(3),bijk(3),tempv(3)
      real*8 uijk(3),aijk(3),pijk(3)
      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
         nmut = 0
c
c     get begin and end pointers for each atom's neighbor list
c
         iptr = anbr(1,ia)
         jptr = anbr(1,ja)
         if (iptr.le.0 .or. jptr.le.0)  goto 130
         iend = anbr(2,ia)
         jend = anbr(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 (nbr(iptr) .lt. nbr(jptr))  goto 20
         if (nbr(jptr) .lt. nbr(iptr))  goto 30
c
c     both point at same neighbor
c     one more mutual neighbor
c     save atom number of mutual neighbor
c
         nmut = nmut + 1
         if (nmut .gt. maxmut) then
            call cerror ('Too many Mutual Neighbors')
         end if
         mut(nmut) = nbr(iptr)
c
c     save pointers to second and third tori
c
         ikt(nmut) = nbrt(iptr)
         jkt(nmut) = nbrt(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 (nmut .le. 0) then
            ttbur(itt) = .false.
            goto 130
         end if
         call gettor (ia,ja,ttok,bij,hij,uij)
         do km = 1, nmut
            ka = mut(km)
            disnbr(km) = dist2(bij,a(1,ka))
            sumnbr(km) = (pr+ar(ka))**2
c
c     initialize link to next farthest out neighbor
c
            lknbr(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 (nmut .le. 1)  goto 70
c
c     put remaining neighbors in linked list at proper position
c
         do l = 2, nmut
            l1 = 0
            l2 = lkf
   50       continue
            if (disnbr(l) .lt. disnbr(l2))  goto 60
            l1 = l2
            l2 = lknbr(l2)
            if (l2 .ne. 0)  goto 50
   60       continue
c
c     add to list
c
            if (l1 .eq. 0) then
               lkf = l
               lknbr(l) = l2
            else
               lknbr(l1) = l
               lknbr(l) = l2
            end if
         end do
   70    continue
c
c     loop thru mutual neighbors
c
         do km = 1, nmut
c
c     get atom number of neighbors
c
            ka = mut(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 = mut(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,a(1,la))
               if (d2 .le. sumnbr(lm))  goto 110
   90          continue
               lm = lknbr(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
                  v(k,nv+1) = a(k,ia) - p(k,np)
                  v(k,nv+2) = a(k,ja) - p(k,np)
                  v(k,nv+3) = a(k,ka) - p(k,np)
               end do
c
c     calculate determinant of vectors defining triangle
c
               det = v(1,nv+1)*v(2,nv+2)*v(3,nv+3)
     &                  + v(1,nv+2)*v(2,nv+3)*v(3,nv+1)
     &                  + v(1,nv+3)*v(2,nv+1)*v(3,nv+2)
     &                  - v(1,nv+3)*v(2,nv+2)*v(3,nv+1)
     &                  - v(1,nv+2)*v(2,nv+1)*v(3,nv+3)
     &                  - v(1,nv+1)*v(2,nv+3)*v(3,nv+2)
c
c     now add probe coordinates to vertices
c
               do k = 1, 3
                  v(k,nv+1) = p(k,np) + v(k,nv+1)*pr/(ar(ia)+pr)
                  v(k,nv+2) = p(k,np) + v(k,nv+2)*pr/(ar(ja)+pr)
                  v(k,nv+3) = p(k,np) + v(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) = v(k,nv+2)
                     v(k,nv+2) = v(k,nv+3)
                     v(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)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer ien,itt,iepen
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
         iepen = ttle(itt)
         enext(iepen) = 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
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer itt,ia,ja,iptr,ned
      integer ip1,ip2,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
            dowhile (iptr .ne. 0)
               ned = ned + 1
               iptr = enext(iptr)
            end do
            if (mod(ned,2) .ne. 0) then
               iptr = tfe(nt)
               dowhile (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
      implicit none
      include 'sizes.i'
      include 'faces.i'
      include 'math.i'
      integer maxent
      parameter (maxent=500)
      integer k,ia,in,ip,it,iv,itwo
      integer ien,ient,nent,l1,l2,m1,n1
      integer ten(maxent),nxtang(maxent)
      real*8 triple,factor,dtev,dt,atvect(3)
      real*8 teang(maxent),tev(3,maxent)
      logical sdstrt(maxent)
c
c
c     zero the number of circles, convex edges and saddle faces
c
      nc = 0
      nep = 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) - a(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) = a(k,ia) + factor*atvect(k)
            end do
c
c     pointer from circle to atom
c
            ca(nc) = ia
c
c     pointer from circle to torus
c
            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
            nep = nep + 1
            if (nep .gt. maxep)  call cerror ('Too many Convex Edges')
c
c     first convex edge points to second circle
c
            epc(nep) = nc
c
c     atom circle lies on
c
            ia = ca(nc)
c
c     insert convex edge into linked list for atom
c
            call ipedge (nep,ia)
c
c     first vertex of convex edge is second vertex of concave edge
c
            epv(1,nep) = env(2,ien)
c
c     first convex edge of saddle
c
            fsep(1,nfs) = nep
c
c     one more convex edge
c
            nep = nep + 1
            if (nep .gt. maxep)  call cerror ('Too many Convex Edges')
c
c     second convex edge points to first circle
c
            epc(nep) = nc - 1
            ia = ca(nc-1)
c
c     insert convex edge into linked list for atom
c
            call ipedge (nep,ia)
c
c     second vertex of second convex edge
c     is first vertex of first concave edge
c
            epv(2,nep) = 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
            epv(2,nep-1) = env(1,ien)
c
c     first vertex of second convex edge is
c     second vertex of second concave edge
c
            epv(1,nep) = env(2,ien)
            fsep(2,nfs) = nep
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
         nep = nep + 1
         ia = ca(nc)
c
c     insert convex edge into linked list for atom
c
         call ipedge (nep,ia)
c
c     no vertices for convex edge
c
         epv(1,nep) = 0
         epv(2,nep) = 0
c
c     pointer from convex edge to second circle
c
         epc(nep) = nc
c
c     first convex edge for saddle face
c
         fsep(1,nfs) = nep
c
c     one more convex edge
c
         nep = nep + 1
         ia = ca(nc-1)
c
c     insert second convex edge into linked list
c
         call ipedge (nep,ia)
c
c     no vertices for convex edge
c
         epv(1,nep) = 0
         epv(2,nep) = 0
c
c     convex edge points to first circle
c
         epc(nep) = nc - 1
c
c     second convex edge for saddle face
c
         fsep(2,nfs) = nep
c
c     buried torus; do nothing with it
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)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer k,ia,ja
      real*8 dist2,dij,temp,temp1,temp2
      real*8 torcen(3),torad,torax(3)
      real*8 vij(3),uij(3),bij(3)
      logical ttok
c
c
c     get the distance between the two atoms
c
      ttok = .false.
      dij = sqrt(dist2(a(1,ia),a(1,ja)))
c
c     find a unit vector along interatomic (torus) axis
c
      do k = 1, 3
         vij(k) = a(k,ja) - a(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) = a(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)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer k,ia,ja,ka
      real*8 dot,dotijk,dotut,wijk,swijk,fact
      real*8 dist2,dat2,rad,rad2,dba,rip2,hijk
      real*8 rij,rik,uij(3),uik(3),uijk(3),utb(3)
      real*8 tij(3),tik(3),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(a(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(a(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 (iep,ia)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer iep,ia,iepen
c
c
c     first, check for an error condition
c
      if (iep .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) = iep
         epnext(iep) = 0
         ale(ia) = iep
      else
         iepen = ale(ia)
         epnext(iepen) = iep
         epnext(iep) = 0
         ale(ia) = iep
      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
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer maxepa,maxcypa
      parameter (maxepa=300)
      parameter (maxcypa=100)
      integer i,k,ia,ia2,it,iep,ic,jc,jcy
      integer nepa,iepa,jepa,ncypa,icya,jcya,kcya
      integer ncyep,icyep,jcyep,ncyold,nused,lookv
      integer aic(maxepa),aia(maxepa),aep(maxepa),av(2,maxepa)
      integer ncyepa(maxcypa),cyepa(mxcyep,maxcypa)
      real*8 anorm,anaa,factor
      real*8 acvect(3,maxepa),aavect(3,maxepa)
      real*8 pole(3),unvect(3),acr(maxepa)
      logical ptincy,epused(maxepa),cycy(maxcypa,maxcypa)
      logical cyused(maxcypa),samef(maxcypa,maxcypa)
c
c
c     zero out the number of cycles and convex faces
c
      ncy = 0
      nfp = 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
         nepa = 0
c
c     pointer to first edge
c
         iep = afe(ia)
   10    continue
c
c     check whether finished gathering
c
         if (iep .le. 0)  goto 20
c
c     one more edge
c
         nepa = nepa + 1
         if (nepa .gt. maxepa) then
            call cerror ('Too many Convex Edges for Atom')
         end if
c
c      store vertices of edge
c
         av(1,nepa) = epv(1,iep)
         av(2,nepa) = epv(2,iep)
c
c     store convex edge number
c
         aep(nepa) = iep
         ic = epc(iep)
c
c     store circle number
c
         aic(nepa) = 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(nepa) = 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,nepa) = c(k,ic) - a(k,ia)
            aavect(k,nepa) = a(k,ia2) - a(k,ia)
         end do
c
c     circle radius
c
         acr(nepa) = cr(ic)
c
c     pointer to next edge
c
         iep = epnext(iep)
         goto 10
   20    continue
         if (nepa .le. 0) then
            call cerror ('No Edges for Non-buried, Non-free Atom')
         end if
c
c
c     form cycles; initialize all the
c     convex edges as not used in cycle
c
         do iepa = 1, nepa
            epused(iepa) = .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 iepa = 1, nepa
            if (.not. epused(iepa))  goto 40
         end do
c
c     cannot find starting edge, finished
c
         goto 80
   40    continue
c
c     pointer to edge
c
         iep = aep(iepa)
c
c     one edge so far for this cycle
c
         ncyep = 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
         epused(iepa) = .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
         cyepa(ncyep,ncypa) = iepa
c
c     store in molecule cycle array a pointer to edge
c
         cyep(ncyep,ncy) = iep
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,iepa)
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 jepa = 1, nepa
            if (epused(jepa))  goto 60
c
c     check second vertex of iepa versus first vertex of jepa
c
            if (av(1,jepa) .ne. lookv)  goto 60
c
c     edges are connected
c     pointer to edge
c
            iep = aep(jepa)
c
c     one more edge for this cycle
c
            ncyep = ncyep + 1
            if (ncyep .gt. mxcyep) then
               call cerror ('Too many Edges per Cycle')
            end if
            epused(jepa) = .true.
            nused = nused + 1
c
c     store index in local edge array
c
            cyepa(ncyep,ncypa) = jepa
c
c     store pointer to edge
c
            cyep(ncyep,ncy) = iep
c
c     new vertex to look for
c
            lookv = av(2,jepa)
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,iepa)) then
            call cerror ('Cycle does not Close')
         end if
   70    continue
c
c     this cycle is finished
c     store number of edges in cycle
c
         ncyepa(ncypa) = ncyep
         cynep(ncy) = ncyep
         if (nused .ge. nepa)  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
c
c     initialize
c
               cycy(icya,jcya) = .true.
c
c     check for same cycle
c
               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 (ncyepa(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 icyep = 1, ncyepa(icya)
                  iepa = cyepa(icyep,icya)
                  ic = aic(iepa)
                  do jcyep = 1, ncyepa(jcya)
                     jepa = cyepa(jcyep,jcya)
                     jc = aic(jepa)
                     if (ic .eq. jc) then
                        cycy(icya,jcya) = .false.
                        goto 90
                     end if
                  end do
               end do
               iepa = cyepa(1,icya)
               anaa = anorm(aavect(1,iepa))
               factor = ar(ia) / anaa
c
c     north pole and unit vector pointing south
c
               do k = 1, 3
                  pole(k) = factor*aavect(k,iepa) + a(k,ia)
                  unvect(k) = -aavect(k,iepa) / 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
            nfp = nfp + 1
            if (nfp .gt. maxfp) then
               call cerror ('Too many Convex Faces')
            end if
c
c     clear number of cycles for face
c
            fpncy(nfp) = 0
c
c     pointer from face to atom
c
            fpa(nfp) = 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
               fpncy(nfp) = fpncy(nfp) + 1
               if (fpncy(nfp) .gt. mxfpcy) then
                  call cerror ('Too many Cycles bounding Convex Face')
               end if
               i = fpncy(nfp)
c
c     store cycle number
c
               fpcy(i,nfp) = 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
         nfp = nfp + 1
         if (nfp .gt. maxfp) then
            call cerror ('Too many Convex Faces')
         end if
         fpa(nfp) = ia
         fpncy(nfp) = 0
  130    continue
      end do
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine vam  --  volumes and areas of molecules  ##
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 volume and surface area
c
c
      subroutine vam (volume,area)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      integer maxdot,maxop,nscale
      parameter (maxdot=1000)
      parameter (maxop=100)
      parameter (nscale=20)
      integer k,ke,ke2,kv,ia,ic,ip,it,ien,iep
      integer ifn,ifp,ifs,iv,iv1,iv2,isc,jfn
      integer ndots,idot,nop,iop,nate,neat,neatmx
      integer ivs(3),ispind(3),ispnd2(3)
      integer nlap(maxfn),ifnop(maxop),enfs(maxen)
      integer fnt(3,maxfn),nspt(3,maxfn)
      real*8 volume,area
      real*8 atmarea(maxatm),alens,vint,vcone,vpyr,vlens
      real*8 hedron,totap,totvp,totas,totvs,totasp,totvsp
      real*8 totan,totvn,alenst,alensn,vlenst,vlensn,prism
      real*8 areap,volp,areas,vols,areasp,volsp,arean,voln
      real*8 depth,triple,dist2,areado,voldo,dot,dota
      real*8 ds2,dij2,dt,dpp,rm,rat,rsc,rho
      real*8 sumsc,sumsig,sumlam,stq,scinc,coran,corvn
      real*8 depths(maxfn),alts(3,maxfn),fncen(3,maxfn)
      real*8 cora(maxfn),corv(maxfn),cenop(3,maxop)
      real*8 sdot(3),dotv(nscale),fnvect(3,3,maxfn)
      real*8 tau(3),ppm(3),xpnt1(3),xpnt2(3)
      real*8 qij(3),qji(3),vects(3,3)
      real*8 vect1(3),vect2(3),vect3(3),vect4(3)
      real*8 vect5(3),vect6(3),vect7(3),vect8(3)
      real*8 upp(3),thetaq(3),sigmaq(3)
      real*8 umq(3),upq(3),uc(3),uq(3),uij(3)
      real*8 dots(3,maxdot),tdots(3,maxdot)
      logical fcins(3,maxfn),fcint(3,maxfn)
      logical cinsp,cintp,usenum,vip(3),ate(maxop)
      logical spindl,alli,allj,anyi,anyj,case1,case2
      logical fntrev(3,maxfn),badav(maxfn),badt(maxfn)
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     compute the area and volume due to convex faces
c     as well as the area partitioned among the atoms
c
      totap = 0.0d0
      totvp = 0.0d0
      do ia = 1, na
         atmarea(ia) = 0.0d0
      end do
      do ifp = 1, nfp
         call measfp (ifp,areap,volp)
         ia = fpa(ifp)
         atmarea(ia) = atmarea(ia) + areap
         totap = totap + areap
         totvp = totvp + volp
      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)
            iep = fsep(1,ifs)
            ic = epc(iep)
            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) = v(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) = v(k,iv1) - fncen(k,ifn)
                  vect4(k) = v(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) = v(k,iv1) - fncen(k,jfn)
                     vect8(k) = v(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) = v(k,iv1) - fncen(k,ifn)
                  vect4(k) = v(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) = v(k,iv1) - fncen(k,jfn)
                     vect8(k) = v(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) = v(k,iv) - fncen(k,ifn)
               end do
               call vnorm (vect1,vect1)
               do ke = 1, 3
                  dt = dot(fnvect(1,ke,ifn),v(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 each Atom :',/)
         k = 1
         dowhile (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)  nfp,totap,totvp
  170    format (/,' Convex Faces :',i12,5x,'Area :',f13.3,
     &              4x,'Volume :',f13.3)
         write (iout,180)  nfs,totas,totvs
  180    format (' Saddle Faces :',i12,5x,'Area :',f13.3,
     &              4x,'Volume :',f13.3)
         write (iout,190)  nfn,totan,totvn
  190    format (' Concave Faces :',i11,5x,'Area :',f13.3,
     &              4x,'Volume :',f13.3)
         write (iout,200)  hedron
  200    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,210)  -totasp,-totvsp
  210       format (/,' Spindle Correction :',11x,'Area :',f13.3,
     &                 4x,'Volume :',f13.3)
            write (iout,220)  -alenst-alensn,vlenst-vlensn
  220       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,230)  alensn,vlensn
  230       format (' Lens Numerical Correction :',4x,'Area :',f13.3,
     &                 4x,'Volume :',f13.3)
         end if
      end if
c
c     finally, compute the total area and total volume
c
      area = totap + totas + totan - totasp - alenst
      volume = totvp + totvs + totvn + hedron - totvsp + vlenst
      return
      end
c
c
c     ######################
c     ##                  ##
c     ##  function depth  ##
c     ##                  ##
c     ######################
c
c
      function depth (ip,alt)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      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) = a(k,ia1) - a(k,ia3)
         vect2(k) = a(k,ia2) - a(k,ia3)
         vect3(k) = p(k,ip) - a(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)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer k,ke,ien,iv,ia,ip,ifn
      real*8 prism,height,pav(3,3)
      real*8 vect1(3),vect2(3),vect3(3)
c
c
      height = 0.0d0
      do ke = 1, 3
         ien = fnen(ke,ifn)
         iv = env(1,ien)
         ia = va(iv)
         height = height + a(3,ia)
         ip = vp(iv)
         do k = 1, 3
            pav(k,ke) = a(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 = height * vect3(3) / 2.0d0
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine measfp  ##
c     ##                     ##
c     #########################
c
c
      subroutine measfp (ifp,areap,volp)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      include 'math.i'
      integer k,ke,ifp,iep,ia,ia2,ic,it,iv1,iv2
      integer ncycle,ieuler,icyptr,icy,nedge
      real*8 areap,volp,dot,dt,gauss
      real*8 vecang,angle,geo,pcurve,gcurve
      real*8 vect1(3),vect2(3),acvect(3),aavect(3)
      real*8 tanv(3,2,mxcyep),radial(3,mxcyep)
c
c
      ia = fpa(ifp)
      pcurve = 0.0d0
      gcurve = 0.0d0
      ncycle = fpncy(ifp)
      if (ncycle .gt. 0) then
         ieuler = 2 - ncycle
      else
         ieuler = 2
      end if
      do icyptr = 1, ncycle
         icy = fpcy(icyptr,ifp)
         nedge = cynep(icy)
         do ke = 1, nedge
            iep = cyep(ke,icy)
            ic = epc(iep)
            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) - a(k,ia)
               aavect(k) = a(k,ia2) - a(k,ia)
            end do
            call vnorm (aavect,aavect)
            dt = dot(acvect,aavect)
            geo = -dt / (ar(ia)*cr(ic))
            iv1 = epv(1,iep)
            iv2 = epv(2,iep)
            if (iv1.eq.0 .or. iv2.eq.0) then
               angle = 2.0d0 * pi
            else
               do k = 1, 3
                  vect1(k) = v(k,iv1) - c(k,ic)
                  vect2(k) = v(k,iv2) - c(k,ic)
                  radial(k,ke) = v(k,iv1) - a(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 MEASFP')
                  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 MEASFP')
            end if
            pcurve = pcurve + angle
         end if
      end do
      gauss = 2.0d0*pi*ieuler - pcurve - gcurve
      areap = gauss * (ar(ia)**2)
      volp = areap * ar(ia) / 3.0d0
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine measfs  ##
c     ##                     ##
c     #########################
c
c
      subroutine measfs (ifs,areas,vols,areasp,volsp)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      include 'math.i'
      integer k,ifs,iep,ic,ic1,ic2,it,ia1,ia2,iv1,iv2
      real*8 areas,vols,areasp,volsp,vecang,phi
      real*8 dot,d1,d2,w1,w2,theta1,theta2,rat,thetaq
      real*8 cone1,cone2,term1,term2,term3,spin,volt
      real*8 vect1(3),vect2(3),aavect(3)
      logical cusp
c
c
      iep = fsep(1,ifs)
      ic = epc(iep)
      it = ct(ic)
      ia1 = ta(1,it)
      ia2 = ta(2,it)
      do k = 1, 3
         aavect(k) = a(k,ia2) - a(k,ia1)
      end do
      call vnorm (aavect,aavect)
      iv1 = epv(1,iep)
      iv2 = epv(2,iep)
      if (iv1.eq.0 .or. iv2.eq.0) then
         phi = 2.0d0 * pi
      else
         do k = 1, 3
            vect1(k) = v(k,iv1) - c(k,ic)
            vect2(k) = v(k,iv2) - c(k,ic)
         end do
         phi = vecang(vect1,vect2,aavect,1.0d0)
      end if
      do k = 1, 3
         vect1(k) = a(k,ia1) - t(k,it)
         vect2(k) = a(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
      iep = fsep(1,ifs)
      ic2 = epc(iep)
      iep = fsep(2,ifs)
      ic1 = epc(iep)
      if (ca(ic1) .ne. ia1) then
         call cerror ('IA1 Inconsistency in MEASFS')
      end if
      do k = 1, 3
         vect1(k) = c(k,ic1) - a(k,ia1)
         vect2(k) = c(k,ic2) - a(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)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      include 'math.i'
      integer k,ke,je,ifn,ien,iv,ia,ip
      real*8 arean,voln,vecang,triple,defect,simplx
      real*8 pvv(3,3),pav(3,3),planev(3,3),angle(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) = v(k,iv) - p(k,ip)
            pav(k,ke) = a(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)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer k,ke,icy,ia,nedge,iep,iv
      real*8 dot,dt,f,polev(3),pnt(3)
      real*8 unvect(3),spv(3,mxcyep)
      logical fail
c
c
      fail = .false.
      nedge = cynep(icy)
      do ke = 1, cynep(icy)
c
c     vertex number (use first vertex of edge)
c
         iep = cyep(ke,icy)
         iv = epv(1,iep)
         if (iv .ne. 0) then
c
c     vector from north pole to vertex
c
            do k = 1, 3
               polev(k) = v(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)
      implicit none
      include 'sizes.i'
      include 'faces.i'
      integer k,ke,icy,iep,ic,it,iatom,iaoth,nedge
      real*8 unvect(3),dot,rotang,totang
      real*8 spv(3,mxcyep),epu(3,mxcyep)
      real*8 pnt(3),acvect(3),cpvect(3)
      logical ptincy,fail
c
c
c     check for eaten by neighbor
c
      do ke = 1, cynep(icy)
         iep = cyep(ke,icy)
         ic = epc(iep)
         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) = a(k,iaoth) - a(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 (cynep(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 epuclc (spv,nedge,epu)
      totang = rotang(epu,nedge,unvect)
      ptincy = (totang .gt. 0.0d0)
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine epuclc  ##
c     ##                     ##
c     #########################
c
c
      subroutine epuclc (spv,nedge,epu)
      implicit none
      integer k,ke,ke2,le,nedge
      real*8 anorm,epun
      real*8 spv(3,nedge)
      real*8 epu(3,nedge)
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
            epu(k,ke) = spv(k,ke2) - spv(k,ke)
         end do
         epun = anorm(epu(1,ke))
c        if (epun .le. 0.0d0)  call cerror ('Null Edge in Cycle')
c
c     normalize
c
         if (epun .gt. 0.0d0) then
            do k = 1, 3
               epu(k,ke) = epu(k,ke) / epun
            end do
         else
            do k = 1, 3
               epu(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(epu(1,ke)) .le. 0.0d0) then
            le = ke - 1
            if (le .le. 0)  le = nedge
            do k = 1, 3
               epu(k,ke) = epu(k,le)
            end do
         end if
      end do
      return
      end
c
c
c     #######################
c     ##                   ##
c     ##  function rotang  ##
c     ##                   ##
c     #######################
c
c
      function rotang (epu,nedge,unvect)
      implicit none
      integer ke,nedge
      real*8 rotang,totang,dot,dt,ang
      real*8 epu(3,nedge),unvect(3),crs(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(epu(1,ke),epu(1,ke+1))
            call vcross (epu(1,ke),epu(1,ke+1),crs)
         else
c
c     closing edge of cycle
c
            dt = dot(epu(1,ke),epu(1,1))
            call vcross (epu(1,ke),epu(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  ##
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  ##
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 x(3),xn(3),ax,anorm
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,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,x(3),y(3),z(3),xy(3),dot
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)
      implicit none
      include 'math.i'
      real*8 vecang,v1(3),v2(3),axis(3),hand
      real*8 angle,a1,a2,a12,dt
      real*8 anorm,dot,triple
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  ##
c     ##                     ##
c     #########################
c
c
      subroutine cirpln (circen,cirrad,cirvec,plncen,plnvec,
     &                        cinsp,cintp,xpnt1,xpnt2)
      implicit none
      integer k
      real*8 anorm,dot,dcp,dir,ratio,rlen
      real*8 circen(3),cirrad,cirvec(3)
      real*8 plncen(3),plnvec(3)
      real*8 xpnt1(3),xpnt2(3),cpvect(3),pnt1(3)
      real*8 vect1(3),vect2(3),uvect1(3),uvect2(3)
      logical cinsp,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)
      implicit none
      include 'math.i'
      integer i,j,k,ndots
      integer nequat,nvert,nhoriz
      real*8 fi,fj,x,y,z,xy
      real*8 xcenter,ycenter,zcenter
      real*8 radius,dots(3,ndots)
c
c
      nequat = sqrt(pi*dble(ndots))
      nvert = 0.5d0 * 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 = 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)
      implicit none
      include 'iounit.i'
      integer i,leng,trimtext
      character*60 string
c
c
c     find the length of the message string
c
      leng = trimtext(string)
c
c     write out the error message and quit
c
      write (iout,10)  (string(i:i),i=1,leng)
   10 format (/,' CONNOLLY  --  ',60a1)
      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
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'keys.i'
      include 'output.i'
      integer i,next
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     set default values for information and output variables
c
      digits = 4
      abort = .false.
      verbose = .false.
      debug = .false.
      holdup = .false.
      archive = .false.
      noversion = .false.
      overwrite = .false.
      cyclesave = .false.
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:80)
            read (string,*,err=10)  digits
         else if (keyword(1:8) .eq. 'VERBOSE ') then
            verbose = .true.
         else if (keyword(1:6) .eq. 'DEBUG ') then
            debug = .true.
            verbose = .true.
         else if (keyword(1:11) .eq. 'EXIT-PAUSE ') then
            holdup = .true.
         else if (keyword(1:8) .eq. 'ARCHIVE ') then
            archive = .true.
         else if (keyword(1:10) .eq. 'NOVERSION ') then
            noversion = .false.
         else if (keyword(1:10) .eq. 'OVERWRITE ') then
            overwrite = .false.
         else if (keyword(1:11) .eq. 'SAVE-CYCLE ') then
            cyclesave = .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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      integer maxsite,maxblock,maxframe
      parameter (maxsite=1000)
      parameter (maxblock=1000)
      parameter (maxframe=20000)
      integer i,j,k,m
      integer n1,n2,dt,trimtext
      integer first,last,step
      integer start,stop
      integer nfile,nblock,maxgap
      integer blksize,blkgap,blkdiff
      integer t1(maxblock)
      integer t2(maxblock)
      integer icorr(0:maxframe)
      real*8 value,property
      real*8 vcorr(0:maxframe)
      real*8 ucorr(0:maxframe)
      real*8 x1(maxsite,maxblock)
      real*8 y1(maxsite,maxblock)
      real*8 z1(maxsite,maxblock)
      real*8 x2(maxsite,maxblock)
      real*8 y2(maxsite,maxblock)
      real*8 z2(maxsite,maxblock)
      logical exist,query,normal
      character*1 letter
      character*80 string
c
c
c     get the base name of user specified input structures
c
      call initial
      call nextarg (filename,exist)
      if (.not. exist) then
         write (iout,10)
   10    format (/,' Enter Cartesian Coordinate File Name :  ',$)
         read (input,20)  filename
   20    format (a60)
      end if
c
c     remove any extension from the filename
c
      leng = trimtext (filename)
      last = leng
      do i = 1, leng
         letter = filename(i:i)
         if (letter .eq. '/')  last = leng
c        if (letter .eq. '\')  last = leng
         if (ichar(letter) .eq. 92)  last = leng
         if (letter .eq. ']')  last = leng
         if (letter .eq. ':')  last = leng
         if (letter .eq. '~')  last = leng
         if (letter .eq. '.')  last = i - 1
      end do
      leng = min(leng,last)
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=30,end=30)  first
         query = .false.
      end if
      call nextarg (string,exist)
      if (exist)  read (string,*,err=30,end=30)  last
      call nextarg (string,exist)
      if (exist)  read (string,*,err=30,end=30)  step
   30 continue
      if (query) then
         write (iout,40)
   40    format (/,' Numbers of First & Last File and Step',
     &              ' Increment :  ',$)
         read (input,50)  string
   50    format (a80)
         read (string,*,err=60,end=60)  first,last,step
   60    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=70,end=70)  maxgap
         query = .false.
      end if
   70 continue
      if (query) then
         write (iout,80)
   80    format (/,' Maximum Frame Separation to be Used in',
     &              ' Correlation [ALL] :  ',$)
         read (input,90)  string
   90    format (a80)
         read (string,*,err=100,end=100)  maxgap
  100    continue
      end if
      if (maxgap .eq. 0)  maxgap = last - first
c
c     get the number of file blocks from the total files
c
      nfile = 1 + (last-first)/step
      nblock = 1 + (nfile-1)/maxblock
      blksize = maxblock * step
      blkgap = 1 + (maxgap-1)/blksize
      write (iout,110)  nblock,min(nfile,maxblock)
  110 format (/,' Correlation Function Computed using',i5,
     &           ' Blocks of',i6,' Frames')
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 (start,stop,step,n1,t1,x1,y1,z1)
         write (iout,120)  i
  120    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 (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 (start,stop,step,n2,t2,x2,y2,z2)
            write (iout,130)  i,j
  130       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 (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
c
c     get the normalized correlation function if applicable
c
      normal = .false.
      if (vcorr(0) .ne. 0.0d0)  normal = .true.
      if (normal) then
         do i = 0, maxgap
            ucorr(i) = vcorr(i) / vcorr(0)
         end do
      end if
c
c     print the final values of the correlation function
c
      if (normal) then
         write (iout,140)
  140    format (/,3x,'Separation',7x,'Samples',8x,'Average Value',
     &              7x,'Normalized',/)
         do i = 0, maxgap
            if (icorr(i) .ne. 0) then
               write (iout,150)  i*step,icorr(i),vcorr(i),ucorr(i)
  150          format (i9,6x,i10,6x,2f17.6)
            end if
         end do
      else
         write (iout,160)
  160    format (/,3x,'Separation',7x,'Samples',8x,'Average Value',/)
         do i = 0, maxgap
            if (icorr(i) .ne. 0) then
               write (iout,170)  i*step,icorr(i),vcorr(i)
  170          format (i9,6x,i10,6x,f17.6)
            end if
         end do
      end if
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 (start,stop,step,nb,tb,xb,yb,zb)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'iounit.i'
      integer maxsite,maxblock
      parameter (maxsite=1000)
      parameter (maxblock=1000)
      integer i,k,ixyz
      integer start,stop
      integer next,label
      integer step,lext
      integer nt,nb,freeunit
      integer tb(maxblock)
      real*8 xb(maxsite,maxblock)
      real*8 yb(maxsite,maxblock)
      real*8 zb(maxsite,maxblock)
      logical exist
      character*7 ext
      character*60 xyzfile
      character*80 record
      character*80 string
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)
         xyzfile = filename(1:leng)//'.'//ext(1:lext)
         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 (a80)
            read (record,*)  n
c
c     check for too many correlation sites in the frame
c
            if (n .gt. maxsite) then
               write (iout,20)  maxsite
   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,40)  record
   40          format (a80)
               read (record,*)  label
               call getword (record,name(k),next)
               string = record(next:80)
               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 (i,xi,yi,zi,k,xk,yk,zk)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer maxsite,maxblock
      parameter (maxsite=1000)
      parameter (maxblock=1000)
      integer i,j,k
      real*8 property,value
      real*8 x1(maxsite)
      real*8 y1(maxsite)
      real*8 z1(maxsite)
      real*8 x2(maxsite)
      real*8 y2(maxsite)
      real*8 z2(maxsite)
      real*8 xi(maxsite,maxblock)
      real*8 yi(maxsite,maxblock)
      real*8 zi(maxsite,maxblock)
      real*8 xk(maxsite,maxblock)
      real*8 yk(maxsite,maxblock)
      real*8 zk(maxsite,maxblock)
c
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
      do j = 1, n
         value = value + x1(j)*x2(j) + y1(j)*y2(j) + z1(j)*z2(j)
      end do
c
c     sample code to find the rms deviation upon superposition
c
c     call impose (n,x1,y1,z1,n,x2,y2,z2,value)
c
c     set property value to be returned for this frame pair
c
      property = value
      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 program which converts between
c     fractional and Cartesian coordinates, and can generate
c     full unit cells from asymmetric units
c
c
      program crystal
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'iounit.i'
      include 'files.i'
      include 'math.i'
      integer maxspace
      parameter (maxspace=24)
      integer i,ixyz,mode
      integer na,nb,nc
      integer next,freeunit
      logical exist,query
      character*1 answer
      character*10 sgroup(maxspace)
      character*60 coordfile
      character*80 record,string
      data sgroup / 'P1        ', 'P1(-)     ', 'P21       ',
     &              'Cc        ', 'P21/a     ', 'P21/n     ',
     &              'P21/c     ', 'C2/c      ', 'P212121   ',
     &              'Pca21     ', 'Pna21     ', 'Pn21a     ',
     &              'Cmc21     ', 'Pccn      ', 'Pbcn      ',
     &              'Pbca      ', 'P41       ', 'I41/a     ',
     &              'P4(-)21c  ', 'P4(-)m2   ', 'R3c       ',
     &              'P6(3)/mmc ', 'Fm3(-)m   ', 'Im3(-)m   '/
c
c
c     get and read the Cartesian coordinates file
c
      call initial
      call getxyz
c
c     find out which unitcell manipulation 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 Crystal Facility can Provide :',
     &           //,4x,'(1) Convert Fractional to Cartesian Coords',
     &           /,4x,'(2) Convert Cartesian to Fractional Coords',
     &           /,4x,'(3) Translate the Molecules into Unit Cell',
     &           /,4x,'(4) Make a Unit Cell from Asymmetric Unit',
     &           /,4x,'(5) Make a Big Block from Single Unit Cell')
         dowhile (mode.lt.1 .or. mode.gt.5)
            write (iout,30)
   30       format (/,' Enter the Number of the Desired Choice :  ',$)
            read (input,40)  mode
   40       format (i10)
         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 90
         end do
   50    continue
         write (iout,60)  (sgroup(i),i=1,maxspace)
   60    format (/,' Listing of the Available Space Groups :',
     &           //,'   (1) ',a10,'  (2) ',a10,'  (3) ',a10,
     &           /,'   (4) ',a10,'  (5) ',a10,'  (6) ',a10,
     &           /,'   (7) ',a10,'  (8) ',a10,'  (9) ',a10,
     &           /,'  (10) ',a10,' (11) ',a10,' (12) ',a10,
     &           /,'  (13) ',a10,' (14) ',a10,' (15) ',a10,
     &           /,'  (16) ',a10,' (17) ',a10,' (18) ',a10,
     &           /,'  (19) ',a10,' (20) ',a10,' (21) ',a10,
     &           /,'  (22) ',a10,' (23) ',a10,' (24) ',a10)
         write (iout,70)
   70    format (/,' Enter the Number of the Desired Choice :  ',$)
         read (input,80)  i
   80    format (i10)
         if (i.lt.1 .or. i.gt.maxspace)  goto 50
         spacegrp = sgroup(i)
   90    continue
      end if
c
c     if not in keyfile, get the unit cell axis lengths
c
      dowhile (xbox .eq. 0.0d0)
         write (iout,100)
  100    format (/,' Enter Unit Cell Axis Lengths :  ',$)
         read (input,110)  record
  110    format (a80)
         read (record,*,err=120,end=120)  xbox,ybox,zbox
  120    continue
         if (ybox .eq. 0.0d0)  ybox = xbox
         if (zbox .eq. 0.0d0)  zbox = xbox
         use_bounds = .true.
      end do
c
c     if not in keyfile, get the unit cell angle values
c
      dowhile (alpha .eq. 0.0d0)
         write (iout,130)
  130    format (/,' Enter Unit Cell Axis Angles :   ',$)
         read (input,140)  record
  140    format (a80)
         read (record,*,err=150,end=150)  alpha,beta,gamma
  150    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,160)  xbox,ybox,zbox,alpha,beta,gamma
  160 format (/,' Unit Cell Dimensions :      a    =',f10.4,
     &        /,'                             b    =',f10.4,
     &        /,'                             c    =',f10.4,
     &        /,'                            Alpha =',f10.4,
     &        /,'                            Beta  =',f10.4,
     &        /,'                            Gamma =',f10.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,170)  spacegrp
  170    format (/,' Space Group Symbol :',12x,a10)
         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,180)
  180    format (/,' Enter Number of Replicates along a-, b- and',
     &              ' c-Axes [1 1 1] :   ',$)
         read (input,190)  record
  190    format (a80)
         read (record,*,err=200,end=200)  na,nb,nc
  200    continue
         if (na .eq. 0)  na = 1
         if (nb .eq. 0)  nb = na
         if (nc .eq. 0)  nc = na
         call bigblock (na,nb,nc)
         write (iout,210)  na,nb,nc,dble(na)*xbox,dble(nb)*ybox,
     &                     dble(nc)*zbox
  210    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     translate any stray molecules back into the unit cell
c
      if (mode .eq. 3) then
         call field
         call katom
         call molecule
         call bounds
      end if
c
c     center unit cell at the origin and move molecules into cell
c
      if (mode .eq. 4) then
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,220)
  220       format (/,' Center on Origin and Move Molecules into',
     &                 ' Unit Cell [Y] :   ',$)
            read (input,230)  record
  230       format (a80)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .ne. 'N') 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
            call field
            call katom
            call molecule
            call bounds
         end if
      end if
c
c     write out the new coordinates to a file
c
      ixyz = freeunit ()
      if (mode .eq. 2) then
         coordfile = filename(1:leng)//'.cel'
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,status='new')
      else
         coordfile = filename(1:leng)//'.xyz'
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,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 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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      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
c     cell to give a larger block of repeated units
c
c
      subroutine bigblock (na,nb,nc)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,j,k
      integer ii,jj,nsym
      integer na,nb,nc
      real*8 trans(3,maxcell)
c
c
c     construct translation offsets for the replicated cells
c
      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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,j,ii,jj,nsym
      real*8 one3,two3
      character*10 spacegrp
c
c
c     P1 space group  (Intl. Tables 1)
c
      if (spacegrp .eq. 'P1        ') then
         nsym = 1
         do i = 1, n
            x(i) = x(i) - 0.5d0
            y(i) = y(i) - 0.5d0
            z(i) = z(i) - 0.5d0
         end do
c
c     P1(-) space group  (Intl. Tables 2)
c
      else if (spacegrp .eq. 'P1(-)     ') then
         nsym = 2
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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  (Intl. Tables 4)
c
      else if (spacegrp .eq. 'P21       ') then
         nsym = 2
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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     Cc space group  (Intl. Tables 9)
c
      else if (spacegrp .eq. 'Cc        ') then
         nsym = 4
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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) = 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  (Intl. Tables 14)
c
      else if (spacegrp .eq. 'P21/a     ') then
         nsym = 4
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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     P21/n space group  (Intl. Tables 14)
c
      else if (spacegrp .eq. 'P21/n     ') then
         nsym = 4
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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/c space group  (Intl. Tables 14)
c
      else if (spacegrp .eq. 'P21/c     ') then
         nsym = 4
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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     C2/c space group  (Intl. Tables 15)
c
      else if (spacegrp .eq. 'C2/c      ') then
         nsym = 8
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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)
               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) = 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) = 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     P212121 space group  (Intl. Tables 19)
c
      else if (spacegrp .eq. 'P212121   ') then
         nsym = 4
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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     Pca21 space group  (Intl. Tables 29)
c
      else if (spacegrp .eq. 'Pca21     ') then
         nsym = 4
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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     Pna21 space group  (Intl. Tables 33)
c
      else if (spacegrp .eq. 'Pna21     ') then
         nsym = 4
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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  (Intl. Tables 33)
c
      else if (spacegrp .eq. 'Pn21a     ') then
         nsym = 4
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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     Cmc21 space group  (Intl. Tables 36)
c
      else if (spacegrp .eq. 'Cmc21     ') then
         nsym = 8
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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) = 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) = 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) = 0.5d0 + 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) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Pccn space group  (Intl. Tables 56)
c
      else if (spacegrp .eq. 'Pccn      ') then
         nsym = 8
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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     Pbcn space group  (Intl. Tables 60)
c
      else if (spacegrp .eq. 'Pbcn      ') then
         nsym = 8
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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  (Intl. Tables 61)
c
      else if (spacegrp .eq. 'Pbca      ') then
         nsym = 8
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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     P41 space group  (Intl. Tables 76)
c
      else if (spacegrp .eq. 'P41       ') then
         nsym = 4
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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     I41/a space group  (Intl. Tables 88)
c
      else if (spacegrp .eq. 'I41/a     ') then
         nsym = 16
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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) = -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) = 0.75d0 - y(j)
                  y(jj) = 0.25d0 + x(j)
                  z(jj) = 0.25d0 + z(j)
               else if (i .eq. 6) then
                  x(jj) = 0.25d0 - y(j)
                  y(jj) = 0.75d0 + x(j)
                  z(jj) = 0.75d0 + z(j)
               else if (i .eq. 7) then
                  x(jj) = 0.75d0 + y(j)
                  y(jj) = 0.75d0 - x(j)
                  z(jj) = 0.75d0 + z(j)
               else if (i .eq. 8) then
                  x(jj) = 0.25d0 + y(j)
                  y(jj) = 0.25d0 - x(j)
                  z(jj) = 0.25d0 + z(j)
               else if (i .eq. 9) then
                  x(jj) = -x(j)
                  y(jj) = -y(j)
                  z(jj) = -z(j)
               else if (i .eq. 10) then
                  x(jj) = 0.5d0 - x(j)
                  y(jj) = 0.5d0 - y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 11) then
                  x(jj) = 0.5d0 + x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 - z(j)
               else if (i .eq. 12) then
                  x(jj) = x(j)
                  y(jj) = 0.5d0 + y(j)
                  z(jj) = -z(j)
               else if (i .eq. 13) then
                  x(jj) = 0.25d0 + y(j)
                  y(jj) = 0.75d0 - x(j)
                  z(jj) = 0.75d0 - z(j)
               else if (i .eq. 14) then
                  x(jj) = 0.75d0 + y(j)
                  y(jj) = 0.25d0 - x(j)
                  z(jj) = 0.25d0 - z(j)
               else if (i .eq. 15) then
                  x(jj) = 0.25d0 - y(j)
                  y(jj) = 0.25d0 + x(j)
                  z(jj) = 0.25d0 - z(j)
               else if (i .eq. 16) then
                  x(jj) = 0.75d0 - y(j)
                  y(jj) = 0.75d0 + x(j)
                  z(jj) = 0.75d0 - z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     P4(-)21c space group  (Intl. Tables 114)
c
      else if (spacegrp .eq. 'P4(-)21c  ') then
         nsym = 8
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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  (Intl. Tables 115)
c
      else if (spacegrp .eq. 'P4(-)m2   ') then
         nsym = 8
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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     R3c space group  (Intl. Tables 161)
c
      else if (spacegrp .eq. 'R3c       ') then
         nsym = 18
         one3 = 1.0d0 / 3.0d0
         two3 = 2.0d0 / 3.0d0
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               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(j)
                  y(jj) = x(j) - y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 6) then
                  x(jj) = y(j) - x(j)
                  y(jj) = y(j)
                  z(jj) = 0.5d0 + z(j)
               else if (i .eq. 7) then
                  x(jj) = x(j) + one3
                  y(jj) = y(j) + two3
                  z(jj) = z(j) + two3
               else if (i .eq. 8) then
                  x(jj) = -y(j) + one3
                  y(jj) = x(j) - y(j) + two3
                  z(jj) = z(j) + two3
               else if (i .eq. 9) then
                  x(jj) = y(j) - x(j) + one3
                  y(jj) = -x(j) + two3
                  z(jj) = z(j) + two3
               else if (i .eq. 10) then
                  x(jj) = -y(j) + one3
                  y(jj) = -x(j) + two3
                  z(jj) = 0.5d0 + z(j) + two3
               else if (i .eq. 11) then
                  x(jj) = x(j) + one3
                  y(jj) = x(j) - y(j) + two3
                  z(jj) = 0.5d0 + z(j) + two3
               else if (i .eq. 12) then
                  x(jj) = y(j) - x(j) + one3
                  y(jj) = y(j) + two3
                  z(jj) = 0.5d0 + z(j) + two3
               else if (i .eq. 13) then
                  x(jj) = x(j) + two3
                  y(jj) = y(j) + one3
                  z(jj) = z(j) + one3
               else if (i .eq. 14) then
                  x(jj) = -y(j) + two3
                  y(jj) = x(j) - y(j) + one3
                  z(jj) = z(j) + one3
               else if (i .eq. 15) then
                  x(jj) = y(j) - x(j) + two3
                  y(jj) = -x(j) + one3
                  z(jj) = z(j) + one3
               else if (i .eq. 16) then
                  x(jj) = -y(j) + two3
                  y(jj) = -x(j) + one3
                  z(jj) = 0.5d0 + z(j) + one3
               else if (i .eq. 17) then
                  x(jj) = x(j) + two3
                  y(jj) = x(j) - y(j) + one3
                  z(jj) = 0.5d0 + z(j) + one3
               else if (i .eq. 18) then
                  x(jj) = y(j) - x(j) + two3
                  y(jj) = y(j) + one3
                  z(jj) = 0.5d0 + z(j) + one3
               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. 'P6(3)/mmc ') then
         nsym = 2
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 2) then
                  x(jj) = x(j) + 0.5d0
                  y(jj) = y(j)
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Fm3m space group  (Intl. Tables 225, Face Centered Cubic)
c
      else if (spacegrp .eq. 'Fm3(-)m   ') then
         nsym = 4
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 2) then
                  x(jj) = x(j)
                  y(jj) = y(j) + 0.5d0
                  z(jj) = z(j) + 0.5d0
               else if (i .eq. 3) then
                  x(jj) = x(j) + 0.5d0
                  y(jj) = y(j)
                  z(jj) = z(j) + 0.5d0
               else if (i .eq. 4) then
                  x(jj) = x(j) + 0.5d0
                  y(jj) = y(j) + 0.5d0
                  z(jj) = z(j)
               end if
               call cellatom (jj,j)
            end do
         end do
c
c     Im3m space group  (Intl. Tables 229, Body Centered Cubic)
c
      else if (spacegrp .eq. 'Im3(-)m   ') then
         nsym = 2
         do i = 2, nsym
            ii = (i-1) * n
            do j = 1, n
               jj = j + ii
               if (i .eq. 2) then
                  x(jj) = x(j) + 0.5d0
                  y(jj) = y(j) + 0.5d0
                  z(jj) = z(j) + 0.5d0
               end if
               call cellatom (jj,j)
            end do
         end do
      end if
c
c     set the total number of atoms to include full unitcell
c
      n = nsym * n
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine cutoffs  --  set distance and Hessian cutoffs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "cutoffs" initializes and stores spherical energy cutoff
c     distance windows, Hessian element and Ewald sum cutoffs,
c     and the pairwise neighbor generation method
c
c
      subroutine cutoffs
      implicit none
      include 'sizes.i'
      include 'bound.i'
      include 'cutoff.i'
      include 'hescut.i'
      include 'keys.i'
      integer i,next
      real*8 big,value
      logical truncate
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     set defaults for spherical energy cutoff distances
c
      big = 1.0d12
      if (use_bounds) then
         vdwcut = 9.0d0
         chgcut = 9.0d0
         dplcut = 9.0d0
         mpolecut = 9.0d0
         ewaldcut = 9.0d0
      else
         vdwcut = big
         chgcut = big
         dplcut = big
         mpolecut = big
         ewaldcut = big
      end if
c
c     set defaults for switching function starting distance
c
      vdwtaper = 0.90d0
      chgtaper = 0.65d0
      dpltaper = 0.75d0
      mpoletaper = 0.65d0
c
c     set default for Hessian element magnitude cutoff
c
      hesscut = 0.0d0
c
c     set default tapering style, method of lights and Ewald
c
      truncate = .false.
      use_lights = .false.
      use_ewald = .false.
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)
c
c     get values related to use of Ewald summation
c
         if (keyword(1:6) .eq. 'EWALD ') then
            if (use_bounds)  use_ewald = .true.
         else if (keyword(1:13) .eq. 'EWALD-CUTOFF ') then
            string= record(next:80)
            read (string,*,err=10)  ewaldcut
c
c     get values for to tapering style and method of lights
c
         else if (keyword(1:9) .eq. 'TRUNCATE ') then
            truncate = .true.
         else if (keyword(1:7) .eq. 'LIGHTS ') then
            use_lights = .true.
c
c     get cutoff for the magnitude of Hessian elements
c
         else if (keyword(1:12) .eq. 'HESS-CUTOFF ') then
            string = record(next:80)
            read (string,*,err=10)  hesscut
c
c     get the cutoff radii for potential energy functions
c
         else if (keyword(1:7) .eq. 'CUTOFF ') then
            string = record(next:80)
            read (string,*,err=10)  value
            vdwcut = value
            chgcut = value
            dplcut = value
            mpolecut = value
            ewaldcut = value
         else if (keyword(1:11) .eq. 'VDW-CUTOFF ') then
            string = record(next:80)
            read (string,*,err=10)  vdwcut
         else if (keyword(1:11) .eq. 'CHG-CUTOFF ') then
            string = record(next:80)
            read (string,*,err=10)  chgcut
         else if (keyword(1:11) .eq. 'DPL-CUTOFF ') then
            string = record(next:80)
            read (string,*,err=10)  dplcut
         else if (keyword(1:13) .eq. 'MPOLE-CUTOFF ') then
            string = record(next:80)
            read (string,*,err=10)  mpolecut
c
c     get distance for initialization of energy switching
c
         else if (keyword(1:6) .eq. 'TAPER ') then
            string = record(next:80)
            read (string,*,err=10)  value
            vdwtaper = value
            chgtaper = value
            dpltaper = value
            mpoletaper = value
         else if (keyword(1:10) .eq. 'VDW-TAPER ') then
            string = record(next:80)
            read (string,*,err=10)  vdwtaper
         else if (keyword(1:10) .eq. 'CHG-TAPER ') then
            string = record(next:80)
            read (string,*,err=10)  chgtaper
         else if (keyword(1:10) .eq. 'DPL-TAPER ') then
            string= record(next:80)
            read (string,*,err=10)  dpltaper
         else if (keyword(1:12) .eq. 'MPOLE-TAPER ') then
            string= record(next:80)
            read (string,*,err=10)  mpoletaper
         end if
   10    continue
      end do
c
c     convert any distance percentages to absolute distances
c
      if (vdwtaper .lt. 1.0d0)  vdwtaper = vdwtaper * vdwcut
      if (chgtaper .lt. 1.0d0)  chgtaper = chgtaper * chgcut
      if (dpltaper .lt. 1.0d0)  dpltaper = dpltaper * dplcut
      if (mpoletaper .lt. 1.0d0)  mpoletaper = mpoletaper * mpolecut
c
c     apply truncation cutoffs if they were requested
c
      if (truncate) then
         vdwtaper = big
         chgtaper = big
         dpltaper = big
         mpoletaper = big
      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 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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      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 :',i8)
      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 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 the efficiency and accuracy
c
c     variables and parameters:
c
c     n         logical dimension of the matrix to be diagonalized
c     np        physical dimension of the matrix storage area
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   some temporary work vectors of dimension (np+1)
c     ta,tb,y   more temporary work vectors of dimension (np+1)
c
c     literature reference:
c
c     adapted from an original program written by Bernie Brooks,
c     National Institutes of Health, Bethesda, MD
c
c
      subroutine diagq (n,np,nv,dd,ev,vec,a,b,p,w,ta,tb,y)
      implicit none
      include 'inform.i'
      include 'iounit.i'
      integer i,j,k,m,n
      integer ia,ii,ji
      integer mi,mj,mk
      integer nn,nm,np,nv
      integer nom,nomtch,ntot
      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 elapsed,bx
      real*8 elim1,elim2
      real*8 epr,f0,factor
      real*8 rvalue,rand1
      real*8 rpower,rpow1
      real*8 root,rootx
      real*8 s,sgn,sum1,t
      real*8 term,temp
      real*8 trial,xnorm
      real*8 dd(np*(np+1)/2)
      real*8 ev(np),vec(np,np)
      real*8 a(np+1),b(np+1)
      real*8 p(np+1),w(np+1)
      real*8 ta(np+1),tb(np+1)
      real*8 y(np+1)
      logical done
c
c
c     initialization and scaling of the input matrix
c
      if (debug)  call setime
      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
      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
      if (debug) then
         call getime (elapsed)
         write (iout,10)  elapsed
   10    format (' DIAGQ  --  Time for Initial Setup :',f13.2)
         call setime
      end if
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)
         if (ji .eq. n) then
            b(i) = bx
            dd(mi+ji) = 0.0d0
            mi = mi + mi1
            mi1 = mi1 - 1
         else
            do j = ji+1, n
               ipt = ipt + 1
               sum1 = sum1 + dd(ipt)*dd(ipt)
            end do
            if (sum1 .gt. gamma) then
               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
               mi = mi + mi1
               mi1 = mi1 - 1
            end if
         end if
      end do
      if (debug) then
         call getime (elapsed)
         write (iout,20)  elapsed
   20    format (' DIAGQ  --  Time to Tridiagonalize :',f13.2)
         call setime
      end if
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))
         dowhile (abs(trial-root).ge.eps .and. abs(trial-ev(i)).ge.eps)
            nomtch = n
            j = 1
            dowhile (j .le. n)
               f0 = a(j) - trial
               dowhile (abs(f0) .ge. zeta)
                  if (f0 .ge. 0.0d0)  nomtch = nomtch - 1
                  j = j + 1
                  if (j .gt. n)  goto 30
                  f0 = a(j) - trial - b(j-1)/f0
               end do
               j = j + 2
               nomtch = nomtch - 1
            end do
   30       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
      if (debug) then
         call getime (elapsed)
         write (iout,40)  elapsed
   40    format (' DIAGQ  --  Time for Eigenvalues :',f15.2)
         call setime
      end if
c
c     find the eigenvectors via a backtransformation step
c
      do i = 1, nv
         root = ev(i)
         do j = 1, n
            y(j) = 1.0d0
         end do
         if (i.eq.1 .or. abs(ev(i-1)-root).ge.eps) then
            ia = 0
         else
            ia = ia + 1
         end if
         elim1 = a(1) - root
         elim2 = w(1)
         do j = 1, nn
            if (abs(elim1) .gt. abs(w(j))) then
               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)
            else
               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)
            end if
            b(j) = temp
         end do
         ta(n) = elim1
         tb(n) = 0.0d0
         p(n) = 0.0d0
         p(nn) = 0.0d0
         iter = 1
         if (ia .ne. 0)  goto 70
   50    continue
         m = n + 1
         do j = 1, n
            m = m - 1
            done = .false.
            dowhile (.not. done)
               done = .true.
               if (n-m-1 .lt. 0) then
                  elim1 = y(m)
               else
                  if (n-m-1 .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
               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 80
         iter = iter + 1
   60    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 50
   70    continue
         do j = 1, n
            rand1 = mod(rvalue*rand1,rpower)
            y(j) = rand1/rpow1 - 1.0d0
         end do
         goto 50
   80    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 60
         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
      if (debug) then
         call getime (elapsed)
         write (iout,90)  elapsed
   90    format (' DIAGQ  --  Time for Eigenvectors :',f14.2)
         call setime
      end if
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
         nm = n - 2
         do j = 1, nm
            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
      if (debug) then
         call getime (elapsed)
         write (iout,100)  elapsed
  100    format (' DIAGQ  --  Time for Normalization :',f13.2)
      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 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     derivs    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,derivs)
      include 'sizes.i'
      include 'iounit.i'
      integer maxgda,maxstep
      real*8 tiny
      parameter (maxgda=4*maxatm)
      parameter (maxstep=1000)
      parameter (tiny=1.0d-30)
      integer i,nvar,nstep
      integer nok,nbad
      real*8 x1,x2,eps,h1,hmin
      real*8 x,h,hdid,hnext
      real*8 y(maxgda)
      real*8 dydx(maxgda)
      real*8 yscal(maxgda)
      logical terminate
      character*7 status
      external derivs
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
c
c     perform a series of individual integration steps
c
      dowhile (.not. terminate)
         call derivs (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,derivs)
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
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine bsstep  --  Bulirsch-Stoer integration step  ##
c     ##                                                          ##
c     ##############################################################
c
c
      subroutine bsstep (nv,x,dydx,y,htry,eps,yscal,hdid,hnext,derivs)
      include 'sizes.i'
      include 'iounit.i'
      integer maxgda,kmaxx,imax
      real*8 safe1,safe2,redmax,redmin,tiny,scalmx
      parameter (maxgda=4*maxatm)
      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,km,kmax,kopt
      integer nv,nseq(imax)
      real*8 eps,hdid,hnext,htry,x
      real*8 eps1,epsold,errmax,fact,h,red
      real*8 scale,work,wrkmin,xest,xnew
      real*8 dydx(maxgda),y(maxgda),yscal(maxgda)
      real*8 a(imax),alf(kmaxx,kmaxx),err(kmaxx)
      real*8 yerr(maxgda),ysav(maxgda),yseq(maxgda)
      logical first,reduct
      save a,alf,epsold,first,kmax,kopt,nseq,xnew
      external derivs
      data first  / .true. /
      data epsold / -1.0d0 /
      data nseq   / 2,4,6,8,10,12,14,16,18 /
c
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
            if (a(kopt+1) .gt. a(kopt)*alf(kopt-1,kopt))  goto 10
         end do
   10    continue
         kmax = kopt
      end if
      h = htry
      do i = 1, nv
         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,nv,x,dydx,ysav,yseq,derivs)
         xest = (h/dble(nseq(k)))**2
         call pzextr (k,nv,xest,yseq,y,yerr)
         if (k .ne. 1) then
            errmax = tiny
            do i = 1, nv
               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
      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,derivs)
      include 'sizes.i'
      integer maxgda
      parameter (maxgda=4*maxatm)
      integer i,k,nstep,nvar
      real*8 xs,x,htot,h,h2,temp
      real*8 y(maxgda)
      real*8 yout(maxgda)
      real*8 dydx(maxgda)
      real*8 ym(maxgda)
      real*8 yn(maxgda)
      external derivs
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     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 derivs (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 derivs (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
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine pzextr  --  polynomial extrapolation method  ##
c     ##                                                          ##
c     ##############################################################
c
c
      subroutine pzextr (iest,nvar,xest,yest,yz,dy)
      include 'sizes.i'
      integer maxgda,imax
      parameter (maxgda=4*maxatm)
      parameter (imax=13)
      integer i,j,iest,nvar
      real*8 xest,delta,f1,f2,q
      real*8 yz(maxgda),dy(maxgda)
      real*8 yest(maxgda),d(maxgda)
      real*8 x(imax),qcol(maxgda,imax)
      save x,qcol
c
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
      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 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 square displacements as a function of the time
c     separation
c
c     diffusion values for very large time separation are inaccurate
c     due to the small amount of data; the current version requires
c     an orthogonal unit cell
c
c
      program diffuse
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'iounit.i'
      include 'molcul.i'
      integer maxmol,maxframe
      parameter (maxmol=800)
      parameter (maxframe=2000)
      integer i,j,k,m
      integer iarc,nframe
      integer next,freeunit
      integer ntime(maxframe)
      real*8 xmid,ymid,zmid
      real*8 xold,yold,zold
      real*8 xdiff,ydiff,zdiff
      real*8 dx,dy,dz,weight
      real*8 tstep,dunits,delta
      real*8 xvalue,yvalue,zvalue
      real*8 rvalue,dvalue,counts
      real*8 xmsd(maxframe)
      real*8 ymsd(maxframe)
      real*8 zmsd(maxframe)
      real*8 xcm(maxmol,maxframe)
      real*8 ycm(maxmol,maxframe)
      real*8 zcm(maxmol,maxframe)
      logical exist
      character*60 arcfile
      character*120 record
      character*120 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 (arcfile,exist)
      if (exist) then
         call basefile (arcfile)
         call suffix (arcfile,'arc')
         call version (arcfile,'old')
         inquire (file=arcfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      dowhile (.not. exist)
         write (iout,10)
   10    format (/,' Enter Name of the Coordinate Archive File :  ',$)
         read (input,20)  arcfile
   20    format (a60)
         call basefile (arcfile)
         call suffix (arcfile,'arc')
         call version (arcfile,'old')
         inquire (file=arcfile,exist=exist)
      end do
c
c     read the first coordinate set in the archive
c
      iarc = freeunit ()
      open (unit=iarc,file=arcfile,status='old')
      call readxyz (iarc)
      nframe = 1
c
c     get the time increment between frames in picoseconds
c
      tstep = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=30,end=30)  tstep
   30 continue
      if (tstep .le. 0.0d0) then
         write (iout,40)
   40    format (/,' Enter the Time Increment in Picoseconds',
     &              ' [1.0] :  ',$)
         read (input,50)  tstep
   50    format (f20.0)
      end if
      if (tstep .le. 0.0d0)  tstep = 1.0d0
c
c     get the unit cell axis lengths from keyfile or user
c
      call unitcell
      dowhile (xbox .eq. 0.0d0)
         write (iout,60)
   60    format (/,' Enter Unit Cell Axis Lengths :  ',$)
         read (input,70)  record
   70    format (a80)
         read (record,*,err=80,end=80)  xbox,ybox,zbox
   80    continue
         if (ybox .eq. 0.0d0)  ybox = xbox
         if (zbox .eq. 0.0d0)  zbox = xbox
      end do
c
c     set the half width values for the periodic box
c
      xbox2 = 0.5d0 * xbox
      ybox2 = 0.5d0 * ybox
      zbox2 = 0.5d0 * zbox
c
c     assign the atom parameters and count the molecules
c
      call field
      call katom
      call molecule
c
c     check for too many iudividual molecules in the system
c
      if (nmol .gt. maxmol) then
         write (iout,90)  maxmol
   90    format (/,' DIFFUSE  --  The Maximum of',i6,' Molecules',
     &              ' has been Exceeded')
         call fatal
      end if
c
c     store each molecular center of mass for the first frame
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)
            weight = mass(k)
            xmid = xmid + x(k)*weight
            ymid = ymid + y(k)*weight
            zmid = zmid + z(k)*weight
         end do
         weight = molmass(i)
         xmid = xmid / weight
         ymid = ymid / weight
         zmid = zmid / weight
         xcm(i,nframe) = xmid
         ycm(i,nframe) = ymid
         zcm(i,nframe) = zmid
      end do
c
c     get the archived coordinates for each frame in turn
c
      write (iout,100)
  100 format (/,' Reading the Dynamics Trajectory Archive File :',/)
      dowhile (.true.)
         read (iarc,110,err=150,end=150)
  110    format ()
         do i = 1, n
            next = 1
            read (iarc,120)  record
  120       format (a120)
            read (record,*)  tag(i)
            call getword (record,name(i),next)
            string = record(next:120)
            read (string,*)  x(i),y(i),z(i)
         end do
         nframe = nframe + 1
         if (nframe .gt. maxframe) then
            write (iout,130)  maxframe
  130       format (/,' DIFFUSE  --  The Maximum of',i6,' Frames',
     &                 ' has been Exceeded')
            call fatal
         end if
c
c     unfold each molecule to get its corrected center of mass
c
         do i = 1, nmol
            xold = xcm(i,nframe-1)
            yold = ycm(i,nframe-1)
            zold = zcm(i,nframe-1)
            xmid = 0.0d0
            ymid = 0.0d0
            zmid = 0.0d0
            do j = imol(1,i), imol(2,i)
               k = kmol(j)
               weight = mass(k)
               xmid = xmid + x(k)*weight
               ymid = ymid + y(k)*weight
               zmid = zmid + z(k)*weight
            end do
            weight = molmass(i)
            xmid = xmid / weight
            ymid = ymid / weight
            zmid = zmid / weight
            dx = xmid - xold
            dy = ymid - yold
            dz = zmid - zold
            dowhile (dx .gt. xbox2)
               dx = dx - xbox
            end do
            dowhile (dx .lt. -xbox2)
               dx = dx + xbox
            end do
            dowhile (dy .gt. ybox2)
               dy = dy - ybox
            end do
            dowhile (dy .lt. -ybox2)
               dy = dy + ybox
            end do
            dowhile (dz .gt. zbox2)
               dz = dz - zbox
            end do
            dowhile (dz .lt. -zbox2)
               dz = dz + zbox
            end do
            xcm(i,nframe) = xold + dx
            ycm(i,nframe) = yold + dy
            zcm(i,nframe) = zold + dz
         end do
c
c     print a message after each group of frames is processed
c
         if (mod(nframe,100) .eq. 0) then
            write (iout,140)  nframe
  140       format (4x,'Processing Trajectory Frame',i11)
         end if
      end do
  150 continue
      close (unit=iarc)
      write (iout,160)  nframe
  160 format (/,' Total Number of Trajectory Frames',i8)
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     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,170)
  170 format (/,' Mean Squared Diffusion Distance and Self-Diffusion',
     &           ' Constant :',
     &        //,5x,'Time Step',5x,'X MSD',7x,'Y MSD',7x,'Z MSD',
     &           7x,'R MSD',4x,'Diff Const',/)
      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
         write (iout,180)  delta,xvalue,yvalue,zvalue,rvalue,dvalue
  180    format (f12.2,4f12.2,f12.4)
      end do
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     ##  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
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'disgeo.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kgeoms.i'
      include 'math.i'
      include 'refer.i'
      include 'tors.i'
      integer i,j,k,ia,ib,ic,id,ja,kb
      integer swap,lext,next,freeunit
      integer igeo,ngeo,nhydro
      integer r1,r2,r3,r4,b1,b2
      real*8 angle,hbond1,hbond2
      real*8 bndfac,angfac,weight
      real*8 radi,rmsvalue,secs
      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,letter
      character*7 ext
      character*60 title,geofile
      character*80 record,string
c
c
c     get the input structure file for the embedding
c
      call initial
      call getxyz
c
c     quit if there are too many atoms for distance geometry
c
      if (n .gt. maxgeo) then
         write (iout,10)
   10    format (/,' DISTGEOM  --  Too many Distance Geometry Atoms;',
     &              ' Increase MAXGEO')
         call fatal
      end if
c
c     set the lists of attached atoms and local interactions
c
      call attach
      call active
      call bonds
      call angles
      call torsions
c
c     store the input structure for later comparison
c
      call makeref
c
c     assign approximate radii to each of the atoms
c
      do i = 1, n
         letter = name(i)(1:1)
         if (name(i) .eq. 'CH ') then
            vdwrad(i) = 1.5d0
         else if (name(i) .eq. 'CH2') then
            vdwrad(i) = 1.6d0
c           vdwrad(i) = 0.000001d0
         else if (name(i) .eq. 'CH3') then
            vdwrad(i) = 1.7d0
c           vdwrad(i) = 0.000001d0
         else if (letter .eq. 'H') then
            vdwrad(i) = 0.95d0
         else if (letter .eq. 'C') then
            vdwrad(i) = 1.45d0
         else if (letter .eq. 'N') then
            vdwrad(i) = 1.35d0
         else if (letter .eq. 'O') then
            vdwrad(i) = 1.35d0
         else if (letter .eq. 'P') then
            vdwrad(i) = 1.8d0
         else if (letter .eq. 'S') then
            vdwrad(i) = 1.8d0
         else
            vdwrad(i) = 0.5d0
         end if
      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 = vdwrad(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=20,end=20)  ngeo
   20 continue
      if (ngeo .le. 0) then
         write (iout,30)
   30    format (/,' Number of Distance Geometry Structures',
     &              ' Desired [1] :  ',$)
         read (input,40)  ngeo
   40    format (i10)
         if (ngeo .le. 0)  ngeo = 1
      end if
c
c     enforce the original chirality of tetravalent atoms
c
      nchir = 0
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,50)
   50    format (/,' Impose Chirality Constraints on Tetrahedral',
     &              ' Atoms [Y] :  ',$)
         read (input,60)  record
   60    format (a80)
         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,70)
   70       format (/,' Use "Floating" Chirality for -XH2- and -XH3',
     &                 ' Groups [N] :  ',$)
            read (input,80)  record
   80       format (a80)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         do i = 1, n
            if (n12(i) .eq. 4) then
               nhydro = 0
               if (answer .eq. 'Y') then
                  do j = 1, 4
                     letter = name(i12(j,i))(1:1)
                     if (letter .eq. 'H')  nhydro = nhydro + 1
                  end do
               end if
               if (nhydro .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,90)
   90    format (/,' Impose Planarity and/or Chirality of Trigonal',
     &              ' Atoms [Y] :  ',$)
         read (input,100)  record
  100    format (a80)
         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,110)
  110    format (/,' Impose Torsional Planarity on Adjacent Trigonal',
     &              ' Atoms [Y] :  ',$)
         read (input,120)  record
  120    format (a80)
         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,130)
  130    format (/,' Do You Wish to Examine or Alter the Bounds',
     &              ' Matrix [N] :  ',$)
         read (input,140)  record
  140    format (a80)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'Y')  query = .true.
c
c     set the type of refinement to be used after embedding
c
      use_invert = .false.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,150)
  150    format (/,' Select the Enantiomer closest to the Input',
     &              ' Structure [N] :  ',$)
         read (input,160)  record
  160    format (a80)
         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,170)
  170    format (/,' Refinement via Minimization or Annealing',
     &              ' [M or A, <CR>=A] :  ',$)
         read (input,180)  record
  180    format (a80)
         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     get any distance bound and torsional angle restraints
c
      call kgeom
c
c     change the default distance restraint force constant
c
      do i = 1, ndfix
         if (dfix(3,i) .eq. 100.0d0)  dfix(3,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)
            bndmin = dfix(1,i)
            bndmax = dfix(2,i)
            weight = dfix(3,i)
            if (header) then
               header = .false.
               write (iout,190)
  190          format (/,' Interatomic Distance Bound Restraints :',
     &                 //,12x,'Atom Numbers',7x,'LowerBound',
     &                    4x,'UpperBound',7x,'Weight',/)
            end if
            if (weight .eq. 1.0d0) then
               write (iout,200)  i,ia,ib,bndmin,bndmax
  200          format (i6,5x,2i6,3x,2f14.4)
            else
               write (iout,210)  i,ia,ib,bndmin,bndmax,weight
  210          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)
            tormin = tfix(1,i)
            tormax = tfix(2,i)
            weight = tfix(3,i)
            if (header) then
               header = .false.
               write (iout,220)
  220          format (/,' Intramolecular Torsional Angle Restraints :',
     &                 //,18x,'Atom Numbers',16x,'Torsion Range',
     &                    9x,'Weight',/)
            end if
            write (iout,230)  i,ia,ib,ic,id,tormin,tormax,weight
  230       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
         bnd(i,i) = 0.0d0
      end do
      uppermax = 1000000.0d0
      do i = 1, n
         do j = 1, i-1
            bnd(j,i) = uppermax
         end do
      end do
      do i = 1, n-1
         radi = vdwrad(i)
         do j = i+1, n
            bnd(j,i) = radi + vdwrad(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
            bnd(ia,ib) = bndmin
            bnd(ib,ia) = bndmax
         else
            bnd(ia,ib) = bndmax
            bnd(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)
         angle = acos((rab**2+rbc**2-rac**2) / (2.0d0*rab*rbc))
         cosmin = cos(angle*(1.0d0-angfac))
         cosmax = cos(min(pi,angle*(1.0d0+angfac)))
         qab = min(bnd(ia,ib),bnd(ib,ia))
         qbc = min(bnd(ic,ib),bnd(ib,ic))
         bndmin = qab**2 + qbc**2 - 2.0d0*qab*qbc*cosmin
         bndmin = sqrt(max(0.0d0,bndmin))
         qab = max(bnd(ia,ib),bnd(ib,ia))
         qbc = max(bnd(ic,ib),bnd(ib,ic))
         bndmax = qab**2 + qbc**2 - 2.0d0*qab*qbc*cosmax
         bndmax = sqrt(max(0.0d0,bndmax))
         if (ia .gt. ic) then
            bnd(ia,ic) = bndmin
            bnd(ic,ia) = bndmax
         else
            bnd(ia,ic) = bndmax
            bnd(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(1,j) / radian
               t2 = tfix(2,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 240
            end if
         end do
  240    continue
         qab = min(bnd(ia,ib),bnd(ib,ia))
         qbc = min(bnd(ib,ic),bnd(ic,ib))
         qcd = min(bnd(ic,id),bnd(id,ic))
         qac = min(bnd(ia,ic),bnd(ic,ia))
         qbd = min(bnd(ib,id),bnd(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(bnd(ia,ib),bnd(ib,ia))
         qbc = max(bnd(ib,ic),bnd(ic,ib))
         qcd = max(bnd(ic,id),bnd(id,ic))
         qac = max(bnd(ia,ic),bnd(ic,ia))
         qbd = max(bnd(ib,id),bnd(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
            bnd(ia,id) = bndmin
            bnd(id,ia) = bndmax
         else
            bnd(ia,id) = bndmax
            bnd(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(1,i)
         bndmax = dfix(2,i)
         if (ia .gt. ib) then
            bnd(ia,ib) = bndmin
            bnd(ib,ia) = bndmax
         else
            bnd(ia,ib) = bndmax
            bnd(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
                        bnd(j,i) = min(hbond1,bnd(j,i))
                     else
                        bnd(i,j) = min(hbond1,bnd(i,j))
                     end if
                     if (k .gt. i) then
                        bnd(k,i) = min(hbond2,bnd(k,i))
                     else
                        bnd(i,k) = min(hbond2,bnd(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,maxgeo,bnd,title)
      end if
      write (iout,250)
  250 format (/,' Bounds Smoothing via Triangle and Inverse',
     &           ' Triangle Inequality :')
      if (verbose)  call setime
      call geodesic
c     call triangle
      if (verbose) then
         call getime (secs)
         write (iout,260)  secs
  260    format (/,' Time Required for Bounds Smoothing :',4x,
     &              f12.2,' seconds')
      end if
c
c     allow interactive alteration of the bounds matrix
c
      done = .false.
      dowhile (query .and. .not.done)
         done = .true.
         write (iout,270)
  270    format (/,' Enter an Atom Pair to Display Bounds',
     &              ' [<CR> When Done] :  ',$)
         read (input,280)  record
  280    format (a80)
         read (record,*,err=330,end=330)  b1,b2
         done = .false.
         if (b1.lt.1 .or. b2.gt.n .or. b1.eq.b2)  goto 330
         if (b1 .gt. b2) then
            swap = b1
            b1 = b2
            b2 = swap
         end if
         write (iout,290)  bnd(b2,b1),bnd(b1,b2)
  290    format (/,' Lower Bound :',f8.3,8x,'Upper Bound :',f8.3)
  300    continue
         write (iout,310)
  310    format (/,' Enter New Bounds or <CR> to Leave Unchanged :  ',$)
         read (input,320)  record
  320    format (a80)
         read (record,*,err=330,end=330)  bndmin,bndmax
         if (bndmin .gt. bndmax)  goto 300
         bnd(b2,b1) = bndmin
         bnd(b1,b2) = bndmax
         call trifix (b1,b2)
  330    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,maxgeo,bnd,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. bnd(j,i))  pathmax = bnd(j,i)
         end do
      end do
      write (iout,340)  pathmax
  340 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 (bnd(j,i) .ne. uppermax)  goto 360
         end do
         do j = i+1, n
            if (bnd(i,j) .ne. uppermax)  goto 360
         end do
         quit = .true.
         write (iout,350)  i
  350    format (/,' DISTGEOM  --  Atom',i6,' has no Distance',
     &              ' Constraints')
  360    continue
      end do
      if (quit)  call fatal
c
c     generate the desired number of distance geometry structures
c
      do j = 1, ngeo
         write (iout,370)  j
  370    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)  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 code
c     modules or common blocks, an index of routines called by each
c     source code module, a listing of all valid keywords, a list of
c     include file dependencies as needed by a Unix-style Makefile,
c     or a formatted force field parameter set summary
c
c     note the logical variable "guide" should be set true to make
c     output suitable for inclusion in the TINKER User's Guide
c
c
      program document
      implicit none
      integer maxline
      integer maxunit
      integer maxword
      integer maxfunc
      parameter (maxline=100)
      parameter (maxunit=1000)
      parameter (maxword=1000)
      parameter (maxfunc=63)
      include 'iounit.i'
      integer i,j,k,mode
      integer idoc,isrc
      integer nkey,nunit
      integer next,leng
      integer start,last
      integer freeunit
      integer trimtext
      integer nexttext
      integer nline(maxunit)
      integer link(maxunit)
      logical exist,done,guide
      character*20 module
      character*20 keyword,keylast
      character*20 fname1,fname2
      character*20 routine(maxunit)
      character*20 key(maxword)
      character*20 fname(maxfunc)
      character*60 docfile,srcfile
      character*80 record,string
      character*80 info(maxline,maxunit)
      character*2048 field
c
c     list of the Fortran functions in the TINKER package
c
      data fname / 'ADJACENT',  'ANORM',     'BETACF',    'BETAI',
     &             'BMAX',      'BNDERR',    'CHIRER',    'CJKM',
     &             'D1D2',      'DEPTH',     'DIST2',     'DOT',
     &             'ENERGY',    'ERF',       'ERFC',      'ERFINV',
     &             'FREEUNIT',  'GAMMLN',    'GDA1',      'GDA2',
     &             'GEOMETRY',  'INITERR',   'INVBETA',   'LOCERR',
     &             'MAXWELL',   'MIDERR',    'MINIMIZ1',  'MINIROT1',
     &             'MINRIGID1', 'NEWTON1',   'NEWTROT1',  'NEXTTEXT',
     &             'NORMAL',    'NUMBER',    'OPTIMIZ1',  'OPTIROT1',
     &             'OPTRIGID1', 'PATH1',     'POTNRG',    'PRECISE',
     &             'PROPERTY',  'PSS1',      'PSSRGD1',   'PSSROT1',
     &             'PTINCY',    'RANDOM',    'RMSFIT',    'ROTANG',
     &             'ROTCHECK',  'SADDLE1',   'SCAN1',     'SIGMOID',
     &             'SNIFFER1',  'TORSER',    'TOTERR',    'TRANSIT',
     &             'TRIMTEXT',  'TRIPLE',    'VDWERR',    'VECANG',
     &             'WATSON1',   'XTALLAT1',  'XTALMOL1' /
c
c
c     set flag to create output formatted for TINKER User's Guide
c
      guide = .true.
c
c     find out what documentation the user wants to generate
c
      call initial
      write (iout,10)
   10 format (/,' The TINKER Document Facility can Provide :',
     &        //,4x,'(1) List of Routines from a Source File',
     &        /,4x,'(2) List of Calls made by each Routine',
     &        /,4x,'(3) List of Common Blocks from Source',
     &        /,4x,'(4) List of the TINKER Option Keywords',
     &        /,4x,'(5) List of Include File Dependencies',
     &        /,4x,'(6) Documentation from a Parameter File')
      mode = 0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=20,end=20)  mode
   20 continue
      dowhile (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')
            call version (srcfile,'old')
            inquire (file=srcfile,exist=exist)
         end if
         dowhile (.not. exist)
            write (iout,50)
   50       format (/,' Enter Name of Source Code Listing File :  ',$)
            read (input,60)  srcfile
   60       format (a60)
            call suffix (srcfile,'txt')
            call version (srcfile,'old')
            inquire (file=srcfile,exist=exist)
         end do
         open (unit=isrc,file=srcfile,status='old')
      end if
c
c     get a list of routines and descriptions from source code
c
      if (mode .eq. 1) then
         nunit = 0
         dowhile (.true.)
            read (isrc,70,err=100,end=100)  record
   70       format (a80)
            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.
                  dowhile (.not. done)
                     read (isrc,90,err=100,end=100)  record
   90                format (a80)
                     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)
         idoc = freeunit ()
         docfile = 'routines.doc'
         call version (docfile,'new')
         open (unit=idoc,file=docfile,status='new')
         do i = 1, nunit
            string = routine(i)
            leng = trimtext (string)
            write (idoc,110)  string(1:leng)
  110       format (a,/)
            last = 0
            j = link(i)
            do k = 1, nline(j)
               string = info(k,j)
               if (guide) then
                  if (k .eq. 1) then
                     leng = trimtext (string)
                     field(1:leng) = string(1:leng)
                     last = leng
                  else
                     last = last + 1
                     field(last:last) = ' '
                     leng = trimtext (string)
                     field(last+1:last+leng) = string(1:leng)
                     last = last + leng
                  end if
               else
                  string = info(k,j)
                  leng = trimtext (string)
                  write (idoc,120)  string(1:leng)
  120             format (a)
               end if
            end do
            if (guide .and. last.ne.0) then
               write (idoc,130)  field(1:last)
  130          format (a)
            end if
            if (nline(j) .ne. 0) then
               write (idoc,140)
  140          format ()
            end if
         end do
         close (unit=idoc)
         write (iout,150)  docfile(1:trimtext(docfile))
  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
         dowhile (.true.)
            read (isrc,160,err=170,end=170)  record
  160       format (a80)
            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)
         idoc = freeunit ()
         docfile = 'calls.doc'
         call version (docfile,'new')
         open (unit=idoc,file=docfile,status='new')
         do i = 1, nunit
            string = routine(i)
            leng = trimtext (string)
            j = link(i)
            call sort9 (nline(j),info(1,j))
            if (guide) then
               field = string(1:leng)
               do k = 1, nline(j)
                  leng = trimtext (info(k,j))
                  last = trimtext (field)
                  field = field(1:last)//'    '//info(k,j)(1:leng)
               end do
               leng = trimtext (field)
               write (idoc,180)  field(1:leng)
  180          format (a)
            else
               write (idoc,190)  string(1:leng)
  190          format (a)
               do k = 1, nline(j)
                  string = info(k,j)
                  leng = trimtext (string)
                  write (idoc,200)  string(1:leng)
  200             format (5x,a)
               end do
            end if
         end do
         close (unit=idoc)
         write (iout,210)  docfile(1:trimtext(docfile))
  210    format (/,' Source Documentation Written To:  ',a)
      end if
c
c     get a list of common block contents from source code
c
      if (mode .eq. 3) then
         nunit = 0
         dowhile (.true.)
            read (isrc,220,err=250,end=250)  record
  220       format (a80)
            if (record(1:9) .eq. 'c     ## ') then
               next = index (record,'.i  --')
               if (next .ne. 0) then
                  nunit = nunit + 1
                  leng = trimtext (record)
                  call upcase (record(11:next-1))
                  string = record(11:next-1)
                  start = 20
                  if (guide)  start = trimtext(string) + 5
                  string(start:80) = record(next+8:leng-4)
                  routine(nunit) = string
                  read (isrc,230,err=250,end=250)
  230             format (///)
                  k = 0
                  done = .false.
                  dowhile (.not. done)
                     read (isrc,240,err=250,end=250)  record
  240                format (a80)
                     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 = 20
                        if (guide)  start = trimtext(string) + 5
                        string(start:80) = record(next:leng)
                        info(k,nunit) = string
                     end if
                  end do
                  nline(nunit) = k
               end if
            end if
         end do
  250    continue
         close (unit=isrc)
         call sort7 (nunit,routine,link)
         idoc = freeunit ()
         docfile = 'common.doc'
         call version (docfile,'new')
         open (unit=idoc,file=docfile,status='new')
         do i = 1, nunit
            string = routine(i)
            leng = trimtext (string)
            write (idoc,260)  string(1:leng)
  260       format (a,/)
            j = link(i)
            do k = 1, nline(j)
               string = info(k,j)
               leng = trimtext (string)
               write (idoc,270)  string(1:leng)
  270          format (a)
            end do
            if (nline(j) .ne. 0) then
               write (idoc,280)
  280          format ()
            end if
         end do
         close (unit=idoc)
         write (iout,290)  docfile(1:trimtext(docfile))
  290    format (/,' Source Documentation Written To:  ',a)
      end if
c
c     get the keyword values from the source code listing
c
      if (mode .eq. 4) then
         nkey = 0
         dowhile (.true.)
            read (isrc,300,err=310,end=310)  record
  300       format (a80)
            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 = '                    '
         idoc = freeunit ()
         docfile = 'keyword.doc'
         call version (docfile,'new')
         open (unit=idoc,file=docfile,status='new')
         do i = 1, nkey
            keyword = key(i)
            leng = trimtext (keyword)
            if (keyword .ne. keylast) then
               write (idoc,320)  keyword(1:leng)
  320          format (a)
               keylast = keyword
            end if
         end do
         close (unit=idoc)
         write (iout,330)  docfile(1:trimtext(docfile))
  330    format (/,' Keyword Listing Written To:  ',a)
      end if
c
c     get the included files from the source code listing
c
      if (mode .eq. 5) then
         nkey = 0
         dowhile (.true.)
            read (isrc,340,err=350,end=350)  record
  340       format (a80)
            next = 1
            call getword (record,keyword,next)
            if (keyword .eq. 'include') then
               call gettext (record,keyword,next)
               keyword = keyword(2:trimtext(keyword)-1)
               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     get a force field parameter file and write a listing
c
      if (mode .eq. 6) then
         call getprm
         idoc = freeunit ()
         docfile = 'parameter.doc'
         call version (docfile,'new')
         open (unit=idoc,file=docfile,status='new')
         call prtprm (idoc)
         close (unit=idoc)
         write (iout,380)  docfile(1:trimtext(docfile))
  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)  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 dynamics trajectory in any of
c     several statistical mechanical ensembles with optional periodic
c     boundaries and optional coupling to temperature and pressure baths
c     alternatively a stochastic dynamics trajectory can be generated
c
c
      program dynamic
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bath.i'
      include 'bond.i'
      include 'bound.i'
      include 'inform.i'
      include 'iounit.i'
      include 'mdstuf.i'
      include 'potent.i'
      include 'solute.i'
      include 'stodyn.i'
      include 'usage.i'
      integer istep,nstep
      integer mode,modstep
      real*8 dt,dtdump
      logical exist,query
      character*80 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     initialize the simulation length as number of time steps
c
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  nstep
         query = .false.
      end if
   10 continue
      if (query) then
         write (iout,20)
   20    format (/,' Enter the Number of Dynamics Steps to be',
     &              ' Taken :  ',$)
         read (input,30)  nstep
   30    format (i10)
      end if
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=40,end=40)  dt
   40 continue
      if (dt .le. 0.0d0) then
         write (iout,50)
   50    format (/,' Enter the Time Step Length in Femtoseconds',
     &              ' [1.0] :  ',$)
         read (input,60)  dt
   60    format (f20.0)
      end if
      if (dt .le. 0.0d0)  dt = 1.0d0
      dt = 1.0d-3 * dt
c
c     set bounds on the thermostat coupling time parameters
c
      tautemp = max(tautemp,dt)
      taupres = max(taupres,dt)
      if (integrate .eq. 'STOCHASTIC') then
         tautemp = max(0.5d0/friction,dt)
      end if
c
c     set the time between trajectory snapshot coordinate dumps
c
      dtdump = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=70,end=70)  dtdump
   70 continue
      if (dtdump .le. 0.0d0) then
         write (iout,80)
   80    format (/,' Enter Time between Dumps in Picoseconds',
     &              ' [0.1] :  ',$)
         read (input,90)  dtdump
   90    format (f20.0)
      end if
      if (dtdump .le. 0.0d0)  dtdump = 0.1d0
      iwrite = nint(dtdump/dt)
c
c     get choice of statistical ensemble for periodic system
c
      if (use_bounds) then
         mode = 0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=100,end=100)  mode
  100    continue
         if (mode.lt.1 .or. mode.gt.4) then
            write (iout,110)
  110       format (/,' Possible 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,120)  mode
  120       format (i10)
         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=130,end=130)  kelvin
  130       continue
            if (kelvin .le. 0.0d0) then
               write (iout,140)
  140          format (/,' Enter the Desired Temperature in Degrees',
     &                    ' K [298] :  ',$)
               read (input,150)  kelvin
  150          format (f20.0)
            end if
            if (kelvin .le. 0.0d0)  kelvin = 298.0d0
         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=160,end=160)  atmsph
  160       continue
            if (atmsph .le. 0.0d0) then
               write (iout,170)
  170          format (/,' Enter the Desired Pressure in Atm',
     &                    ' [1.0] :  ',$)
               read (input,180)  atmsph
  180          format (f20.0)
            end if
            if (atmsph .le. 0.0d0)  atmsph = 1.0d0
         end if
      end if
c
c     get desired temperature for nonperiodic system
c
      if (.not. use_bounds) then
         isothermal = .true.
         kelvin = -1.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=190,end=190)  kelvin
  190    continue
         if (kelvin .le. 0.0d0) then
            write (iout,200)
  200       format (/,' Enter the Desired Temperature in Degrees',
     &                 ' K [298] :  ',$)
            read (input,210)  kelvin
  210       format (f20.0)
         end if
         if (kelvin .le. 0.0d0)  kelvin = 298.0d0
      end if
c
c     initialize any rattle constraints and setup dynamics
c
      call shakeup
      call mdinit
c
c     print out a header line for the dynamics computation
c
      if (integrate .eq. 'VERLET') then
         write (iout,220)
  220    format (/,' Molecular Dynamics Trajectory via',
     &              ' Velocity Verlet Algorithm')
      else if (integrate .eq. 'STOCHASTIC') then
         write (iout,230)
  230    format (/,' Stochastic Dynamics Trajectory via',
     &              ' Velocity Verlet Algorithm')
      else if (integrate .eq. 'RIGIDBODY') then
         write (iout,240)
  240    format (/,' Molecular Dynamics Trajectory via',
     &              ' Rigid Body Algorithm')
      else
         write (iout,250)
  250    format (/,' Molecular Dynamics Trajectory via',
     &              ' Modified Beeman Algorithm')
      end if
c
c     take the desired total number of dynamics steps
c
      do istep = 1, nstep
         modstep = mod(istep,iprint)
         if (verbose .and. modstep.eq.1) then
            if (integrate .eq. 'STOCHASTIC') then
               write (iout,260)
  260          format (/,'    SD Step      E Total   E Potential',
     &                    '   E Kinetic       Temp',/)
            else if (isobaric) then
               write (iout,270)
  270          format (/,'    MD Step      E Total   E Potential',
     &                    '   E Kinetic       Temp       Pres',/)
            else
               write (iout,280)
  280          format (/,'    MD Step      E Total   E Potential',
     &                    '   E Kinetic       Temp',/)
            end if
         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. 'STOCHASTIC') then
            call sdstep (istep,dt)
         else if (integrate .eq. 'RIGIDBODY') then
            call rgdstep (istep,dt)
         else
            call beeman (istep,dt)
         end if
         if (modstep.eq.0 .and. nuse.eq.n) then
            if (integrate .ne. 'STOCHASTIC')  call mdrest
         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
      implicit none
      include 'sizes.i'
      include 'angang.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'math.i'
      include 'usage.i'
      integer i,k,iangang
      integer ia,ib,ic,id,ie
      real*8 e,dt1,dt2,fgrp
      real*8 angle,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
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,5,ia,ib,ic,id,ie)
         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,0)
               call image (xcb,ycb,zcb,0)
               call image (xdb,ydb,zdb,0)
               call image (xeb,yeb,zeb,0)
            end if
            rab2 = xab*xab + yab*yab + zab*zab
            rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
            rdb2 = xdb*xdb + ydb*ydb + zdb*zdb
            reb2 = xeb*xeb + yeb*yeb + zeb*zeb
            if (rab2*rcb2*rdb2*reb2 .ne. 0.0d0) then
               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 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 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
      implicit none
      include 'sizes.i'
      include 'angang.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'math.i'
      include 'usage.i'
      include 'virial.i'
      integer i,k,iangang
      integer ia,ib,ic,id,ie
      real*8 e,angle,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
      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
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,5,ia,ib,ic,id,ie)
         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,0)
               call image (xcb,ycb,zcb,0)
               call image (xdb,ydb,zdb,0)
               call image (xeb,yeb,zeb,0)
            end if
            rab2 = xab*xab + yab*yab + zab*zab
            rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
            rdb2 = xdb*xdb + ydb*ydb + zdb*zdb
            reb2 = xeb*xeb + yeb*yeb + zeb*zeb
            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(xp*xp + yp*yp + zp*zp)
            rq = sqrt(xq*xq + yq*yq + zq*zq)
            if (rp*rq .ne. 0.0d0) then
               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 diagonal components
c
               virx = virx + xab*dedxia + xcb*dedxic
     &                     + xdb*dedxid + xeb*dedxie
               viry = viry + yab*dedyia + ycb*dedyic
     &                     + ydb*dedyid + yeb*dedyie
               virz = virz + zab*dedzia + zcb*dedzic
     &                     + zdb*dedzid + zeb*dedzie
            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 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)
      implicit none
      include 'sizes.i'
      include 'angang.i'
      include 'angle.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'group.i'
      include 'hessn.i'
      integer i,j,k,iangang
      integer ia,ib,ic,id,ie
      real*8 eps,fgrp
      real*8 old,term
      real*8 d0(3,maxatm)
      logical proceed
c
c
c     set stepsize for derivatives and default group weight
c
      eps = 1.0d-7
      fgrp = 1.0d0
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,5,ia,ib,ic,id,ie)
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
c
c     find first derivatives for the base structure
c
            term = fgrp / eps
            call eangang2a (iangang)
            do j = 1, 3
               d0(j,ia) = deaa(j,ia)
               d0(j,ib) = deaa(j,ib)
               d0(j,ic) = deaa(j,ic)
               d0(j,id) = deaa(j,id)
               if (ie .ne. 0)  d0(j,ie) = deaa(j,ie)
            end do
c
c     find numerical x-components via perturbed structures
c
            old = x(i)
            x(i) = x(i) + eps
            call eangang2a (iangang)
            x(i) = old
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + term*(deaa(j,ia)-d0(j,ia))
               hessx(j,ib) = hessx(j,ib) + term*(deaa(j,ib)-d0(j,ib))
               hessx(j,ic) = hessx(j,ic) + term*(deaa(j,ic)-d0(j,ic))
               hessx(j,id) = hessx(j,id) + term*(deaa(j,id)-d0(j,id))
               if (ie .ne. 0)
     &            hessx(j,ie) = hessx(j,ie) + term*(deaa(j,ie)-d0(j,ie))
            end do
c
c     find numerical y-components via perturbed structures
c
            old = y(i)
            y(i) = y(i) + eps
            call eangang2a (iangang)
            y(i) = old
            do j = 1, 3
               hessy(j,ia) = hessy(j,ia) + term*(deaa(j,ia)-d0(j,ia))
               hessy(j,ib) = hessy(j,ib) + term*(deaa(j,ib)-d0(j,ib))
               hessy(j,ic) = hessy(j,ic) + term*(deaa(j,ic)-d0(j,ic))
               hessy(j,id) = hessy(j,id) + term*(deaa(j,id)-d0(j,id))
               if (ie .ne. 0)
     &            hessy(j,ie) = hessy(j,ie) + term*(deaa(j,ie)-d0(j,ie))
            end do
c
c     find numerical z-components via perturbed structures
c
            old = z(i)
            z(i) = z(i) + eps
            call eangang2a (iangang)
            z(i) = old
            do j = 1, 3
               hessz(j,ia) = hessz(j,ia) + term*(deaa(j,ia)-d0(j,ia))
               hessz(j,ib) = hessz(j,ib) + term*(deaa(j,ib)-d0(j,ib))
               hessz(j,ic) = hessz(j,ic) + term*(deaa(j,ic)-d0(j,ic))
               hessz(j,id) = hessz(j,id) + term*(deaa(j,id)-d0(j,id))
               if (ie .ne. 0)
     &            hessz(j,ie) = hessz(j,ie) + term*(deaa(j,ie)-d0(j,ie))
            end do
         end if
      end do
      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)
      implicit none
      include 'sizes.i'
      include 'angang.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'math.i'
      integer i,j,k
      integer ia,ib,ic,id,ie
      real*8 angle,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
c
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
      deaa(1,ia) = 0.0d0
      deaa(2,ia) = 0.0d0
      deaa(3,ia) = 0.0d0
      deaa(1,ib) = 0.0d0
      deaa(2,ib) = 0.0d0
      deaa(3,ib) = 0.0d0
      deaa(1,ic) = 0.0d0
      deaa(2,ic) = 0.0d0
      deaa(3,ic) = 0.0d0
      deaa(1,id) = 0.0d0
      deaa(2,id) = 0.0d0
      deaa(3,id) = 0.0d0
      deaa(1,ie) = 0.0d0
      deaa(2,ie) = 0.0d0
      deaa(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,0)
         call image (xcb,ycb,zcb,0)
         call image (xdb,ydb,zdb,0)
         call image (xeb,yeb,zeb,0)
      end if
      rab2 = xab*xab + yab*yab + zab*zab
      rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
      rdb2 = xdb*xdb + ydb*ydb + zdb*zdb
      reb2 = xeb*xeb + yeb*yeb + zeb*zeb
      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(xp*xp + yp*yp + zp*zp)
      rq = sqrt(xq*xq + yq*yq + zq*zq)
      if (rp*rq .ne. 0.0d0) then
         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
         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
      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 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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'angang.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'usage.i'
      integer i,k,iangang
      integer ia,ib,ic,id,ie
      real*8 e,dt1,dt2,fgrp
      real*8 angle,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
      header = .true.
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,5,ia,ib,ic,id,ie)
         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,0)
               call image (xcb,ycb,zcb,0)
               call image (xdb,ydb,zdb,0)
               call image (xeb,yeb,zeb,0)
            end if
            rab2 = xab*xab + yab*yab + zab*zab
            rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
            rdb2 = xdb*xdb + ydb*ydb + zdb*zdb
            reb2 = xeb*xeb + yeb*yeb + zeb*zeb
            if (rab2*rcb2*rdb2*reb2 .ne. 0.0d0) then
               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,10)
   10                format (/,' Individual Angle-Angle Cross',
     &                          ' Term Interactions :',
     &                       //,' Type',9x,'Center',5x,'Angle1'
     &                          ,5x,'Angle2',4x,'dAngle1'
     &                          ,3x,'dAngle2',6x,'Energy',/)
                  end if
                  write (iout,20)  ib,name(ib),ia,ic,id,ie,dt1,dt2,e
   20             format (' AngAng',5x,i5,'-',a3,1x,2i5,1x,2i5,
     &                       2f10.4,f12.4)
               end if
            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 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 or Fourier
c     angle bending terms are optionally used
c
c
      subroutine eangle
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'math.i'
      include 'usage.i'
      integer i,ia,ib,ic,id
      real*8 e,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
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,4,ia,ib,ic,id,0)
            if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                                 use(ic) .or. use(id))
         else
            if (use_group)  call groups (proceed,fgrp,3,ia,ib,ic,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,0)
                  call image (xcb,ycb,zcb,0)
               end if
               rab2 = xab*xab + yab*yab + zab*zab
               rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
               if (rab2.ne.0.0d0 .and. rcb2.ne.0.0d0) then
                  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. 'FOURIER') then
                     fold = afld(i)
                     factor = 2.0d0 * (radian/fold)**2
                     e = angunit * force * factor
     &                      * (1.0d0 + cos((fold*angle-ideal)/radian))
                  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
               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,0)
                  call image (xbd,ybd,zbd,0)
                  call image (xcd,ycd,zcd,0)
               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,0)
                  call image (xcp,ycp,zcp,0)
               end if
               rap2 = xap*xap + yap*yap + zap*zap
               rcp2 = xcp*xcp + ycp*ycp + zcp*zcp
               if (rap2.ne.0.0d0 .and. rcp2.ne.0.0d0) then
                  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 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 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 or Fourier angle
c     bending terms are optionally used
c
c
      subroutine eangle1
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'math.i'
      include 'usage.i'
      include 'virial.i'
      integer i,ia,ib,ic,id
      real*8 e,ideal,force
      real*8 fold,factor
      real*8 dot,cosine
      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
      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
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,4,ia,ib,ic,id,0)
            if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                                 use(ic) .or. use(id))
         else
            if (use_group)  call groups (proceed,fgrp,3,ia,ib,ic,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,0)
                  call image (xcb,ycb,zcb,0)
               end if
               rab2 = xab*xab + yab*yab + zab*zab
               rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
               if (rab2.ne.0.0d0 .and. rcb2.ne.0.0d0) then
                  xp = ycb*zab - zcb*yab
                  yp = zcb*xab - xcb*zab
                  zp = xcb*yab - ycb*xab
                  rp = sqrt(xp*xp + yp*yp + zp*zp)
                  rp = max(rp,0.000001d0)
                  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. 'FOURIER') then
                     fold = afld(i)
                     factor = 2.0d0 * (radian/fold)**2
                     e = angunit * force * factor
     &                      * (1.0d0 + cos((fold*angle-ideal)/radian))
                     deddt = -angunit * force * factor * fold
     &                          * sin((fold*angle-ideal)/radian)
                  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 diagonal components
c
                  virx = virx + xab*dedxia + xcb*dedxic
                  viry = viry + yab*dedyia + ycb*dedyic
                  virz = virz + zab*dedzia + zcb*dedzic
               end if
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,0)
                  call image (xbd,ybd,zbd,0)
                  call image (xcd,ycd,zcd,0)
               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,0)
                  call image (xcp,ycp,zcp,0)
               end if
               rap2 = xap*xap + yap*yap + zap*zap
               rcp2 = xcp*xcp + ycp*ycp + zcp*zcp
               if (rap2.ne.0.0d0 .and. rcp2.ne.0.0d0) then
                  xm = ycp*zap - zcp*yap
                  ym = zcp*xap - xcp*zap
                  zm = xcp*yap - ycp*xap
                  rm = sqrt(xm*xm + ym*ym + zm*zm)
                  rm = max(rm,0.000001d0)
                  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 diagonal components
c
                  virx = virx + xad*dedxia + xbd*dedxib + xcd*dedxic
                  viry = viry + yad*dedyia + ybd*dedyib + ycd*dedyic
                  virz = virz + zad*dedzia + zbd*dedzib + zcd*dedzic
               end if
            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 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 or Fourier angle bending terms are optionally used
c
c
      subroutine eangle2 (i)
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'group.i'
      include 'hessn.i'
      integer i,j,k
      integer ia,ib,ic,id
      real*8 eps,fgrp
      real*8 old,term
      real*8 d0(3,maxatm)
      logical proceed
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-7
      fgrp = 1.0d0
c
c     compute 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,4,ia,ib,ic,id,0)
         end if
c
c     find first derivatives for the base structure
c
         if (proceed) then
            term = fgrp / eps
            call eangle2b (k)
            do j = 1, 3
               d0(j,ia) = dea(j,ia)
               d0(j,ib) = dea(j,ib)
               d0(j,ic) = dea(j,ic)
               d0(j,id) = dea(j,id)
            end do
c
c     find numerical x-components via perturbed structures
c
            old = x(i)
            x(i) = x(i) + eps
            call eangle2b (k)
            x(i) = old
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + term*(dea(j,ia)-d0(j,ia))
               hessx(j,ib) = hessx(j,ib) + term*(dea(j,ib)-d0(j,ib))
               hessx(j,ic) = hessx(j,ic) + term*(dea(j,ic)-d0(j,ic))
               hessx(j,id) = hessx(j,id) + term*(dea(j,id)-d0(j,id))
            end do
c
c     find numerical y-components via perturbed structures
c
            old = y(i)
            y(i) = y(i) + eps
            call eangle2b (k)
            y(i) = old
            do j = 1, 3
               hessy(j,ia) = hessy(j,ia) + term*(dea(j,ia)-d0(j,ia))
               hessy(j,ib) = hessy(j,ib) + term*(dea(j,ib)-d0(j,ib))
               hessy(j,ic) = hessy(j,ic) + term*(dea(j,ic)-d0(j,ic))
               hessy(j,id) = hessy(j,id) + term*(dea(j,id)-d0(j,id))
            end do
c
c     find numerical z-components via perturbed structures
c
            old = z(i)
            z(i) = z(i) + eps
            call eangle2b (k)
            z(i) = old
            do j = 1, 3
               hessz(j,ia) = hessz(j,ia) + term*(dea(j,ia)-d0(j,ia))
               hessz(j,ib) = hessz(j,ib) + term*(dea(j,ib)-d0(j,ib))
               hessz(j,ic) = hessz(j,ic) + term*(dea(j,ic)-d0(j,ic))
               hessz(j,id) = hessz(j,id) + term*(dea(j,id)-d0(j,id))
            end do
         end if
      end do
      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)
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'group.i'
      include 'hessn.i'
      include 'math.i'
      integer i,iatom
      integer ia,ib,ic
      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 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rcb2
      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
c
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,3,ia,ib,ic,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,0)
                  call image (xcb,ycb,zcb,0)
               end if
               rab2 = xab*xab + yab*yab + zab*zab
               rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
               if (rab2.ne.0.0d0 .and. rcb2.ne.0.0d0) then
                  xp = ycb*zab - zcb*yab
                  yp = zcb*xab - xcb*zab
                  zp = xcb*yab - ycb*xab
                  rp = sqrt(xp*xp + yp*yp + zp*zp)
                  rp = max(rp,0.000001d0)
                  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. 'FOURIER') then
                     fold = afld(i)
                     factor = -2.0d0 * fold * (radian/fold)**2
                     deddt = angunit * force * factor
     &                          * sin((fold*angle-ideal)/radian)
                     d2eddt2 = angunit * force * factor * fold
     &                            * cos((fold*angle-ideal)/radian)
                  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     first derivatives of bond angle with respect to coordinates
c
                  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
               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)
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'math.i'
      integer i,ia,ib,ic,id
      real*8 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
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
      dea(1,ia) = 0.0d0
      dea(2,ia) = 0.0d0
      dea(3,ia) = 0.0d0
      dea(1,ib) = 0.0d0
      dea(2,ib) = 0.0d0
      dea(3,ib) = 0.0d0
      dea(1,ic) = 0.0d0
      dea(2,ic) = 0.0d0
      dea(3,ic) = 0.0d0
      dea(1,id) = 0.0d0
      dea(2,id) = 0.0d0
      dea(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,0)
         call image (xbd,ybd,zbd,0)
         call image (xcd,ycd,zcd,0)
      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,0)
         call image (xcp,ycp,zcp,0)
      end if
      rap2 = xap*xap + yap*yap + zap*zap
      rcp2 = xcp*xcp + ycp*ycp + zcp*zcp
      if (rap2.ne.0.0d0 .and. rcp2.ne.0.0d0) then
         xm = ycp*zap - zcp*yap
         ym = zcp*xap - xcp*zap
         zm = xcp*yap - ycp*xap
         rm = sqrt(xm*xm + ym*ym + zm*zm)
         rm = max(rm,0.000001d0)
         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
         dea(1,ia) = dedxia
         dea(2,ia) = dedyia
         dea(3,ia) = dedzia
         dea(1,ib) = dedxib
         dea(2,ib) = dedyib
         dea(3,ib) = dedzib
         dea(1,ic) = dedxic
         dea(2,ic) = dedyic
         dea(3,ic) = dedzic
         dea(1,id) = dedxid
         dea(2,id) = dedyid
         dea(3,id) = dedzid
      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 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 or Fourier angle bending terms
c     are optionally used
c
c
      subroutine eangle3
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'usage.i'
      integer i,ia,ib,ic,id
      real*8 e,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
      header = .true.
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,4,ia,ib,ic,id,0)
            if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                                 use(ic) .or. use(id))
         else
            if (use_group)  call groups (proceed,fgrp,3,ia,ib,ic,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,0)
                  call image (xcb,ycb,zcb,0)
               end if
               rab2 = xab*xab + yab*yab + zab*zab
               rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
               if (rab2.ne.0.0d0 .and. rcb2.ne.0.0d0) then
                  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. 'FOURIER') then
                     fold = afld(i)
                     factor = 2.0d0 * (radian/fold)**2
                     e = angunit * force * factor
     &                      * (1.0d0 + cos((fold*angle-ideal)/radian))
                  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,10)
   10                   format (/,' Individual Angle Bending',
     &                             ' Interactions :',
     &                          //,' Type',17x,'Atom Names',16x,
     &                             'Ideal',4x,'Actual',6x,'Energy',/)
                     end if
                     label = 'Angle    '
                     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,20)  label,ia,name(ia),ib,name(ib),
     &                                ic,name(ic),ideal,angle,e
   20                format (1x,a9,2x,i5,'-',a3,1x,i5,'-',a3,
     &                         1x,i5,'-',a3,2x,2f10.4,f12.4)
                  end if
               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,0)
                  call image (xbd,ybd,zbd,0)
                  call image (xcd,ycd,zcd,0)
               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,0)
                  call image (xcp,ycp,zcp,0)
               end if
               rap2 = xap*xap + yap*yap + zap*zap
               rcp2 = xcp*xcp + ycp*ycp + zcp*zcp
               if (rap2.ne.0.0d0 .and. rcp2.ne.0.0d0) then
                  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,30)
   30                   format (/,' Individual Angle Bending',
     &                             ' Interactions :',
     &                          //,' Type',17x,'Atom Names',16x,
     &                             'Ideal',4x,'Actual',6x,'Energy',/)
                     end if
                     write (iout,40)  ia,name(ia),ib,name(ib),ic,
     &                                name(ic),ideal,angle,e
   40                format (' Angle-IP',3x,i5,'-',a3,1x,i5,'-',a3,
     &                          1x,i5,'-',a3,2x,2f10.4,f12.4)
                  end if
               end if
            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 ebond  --  bond stretch potential energy  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "ebond" calculates the bond stretching energy
c
c
      subroutine ebond
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bndpot.i'
      include 'bond.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'usage.i'
      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
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,2,ia,ib,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,0)
            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
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bndpot.i'
      include 'bond.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'usage.i'
      include 'virial.i'
      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
      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
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,2,ia,ib,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,0)
            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 diagonal components
c
            virx = virx + xab*dedx
            viry = viry + yab*dedy
            virz = virz + zab*dedz
         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 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)
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atoms.i'
      include 'bndpot.i'
      include 'bond.i'
      include 'bound.i'
      include 'couple.i'
      include 'group.i'
      include 'hessn.i'
      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     compute the Hessian elements of the bond stretch energy
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,2,ia,ib,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,0)
            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 non-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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bndpot.i'
      include 'bond.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'usage.i'
      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
      header = .true.
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,2,ia,ib,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,0)
            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,10)
   10             format (/,' Individual Bond Stretching',
     &                       ' Interactions :',
     &                    //,' Type',13x,'Atom Names',20x,'Ideal',
     &                       4x,'Actual',6x,'Energy',/)
               end if
               write (iout,20)  ia,name(ia),ib,name(ib),ideal,rab,e
   20          format (' Bond',7x,i5,'-',a3,1x,i5,'-',a3,
     &                    12x,2f10.4,f12.4)
            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 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
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call ebuck0b
      else
         call ebuck0a
      end if
      return
      end
c
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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      real*8 e,rv,eps,rdn
      real*8 p,p2,p6,p12,fgrp
      real*8 xi,yi,zi,xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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
      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 = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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
      end do
      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 to locate neighboring atoms
c
c
      subroutine ebuck0b
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'iounit.i'
      include 'light.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      real*8 e,rv,eps,rdn
      real*8 p,p2,p6,p12,fgrp
      real*8 xi,yi,zi,xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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 (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
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         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 ebuck1  --  Buckingham 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
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call ebuck1b
      else
         call ebuck1a
      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 with respect to Cartesian coordinates
c     using a pairwise double loop
c
c
      subroutine ebuck1a
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'virial.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      real*8 e,rv,eps,rdn
      real*8 p,p2,p6,p12,fgrp
      real*8 xi,yi,zi,xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz,de
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 taper,dtaper,rvterm
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
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
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
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     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)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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 diagonal components
c
                     virx = virx + xr*dedx
                     viry = viry + yr*dedy
                     virz = virz + zr*dedz
c
c     increment the total intermolecular energy
c
                     einter = einter + e
                  end if
               end do
            end if
         end do
      end do
      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 with respect to Cartesian coordinates
c     using the method of lights to locate neighboring atoms
c
c
      subroutine ebuck1b
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'iounit.i'
      include 'light.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'virial.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      real*8 e,rv,eps,rdn
      real*8 p,p2,p6,p12,fgrp
      real*8 xi,yi,zi,xr,yr,zr
      real*8 redi,rediv
      real*8 redk,redkv
      real*8 dedx,dedy,dedz,de
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 taper,dtaper,rvterm
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
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
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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 (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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         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 ebuck2  --  atom-by-atom Buckingham 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 (iatom,xred,yred,zred)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'group.i'
      include 'hessn.i'
      include 'shunt.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,jcell
      integer ii,kk,iatom
      integer iv,kv,it,kt
      integer nlist,list(5)
      integer iv14(maxatm)
      real*8 e,de,d2e,fgrp
      real*8 p,p2,p6,p12,eps,rv
      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 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed
c
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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     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)
         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
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         do j = 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 = 1, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (k .ne. i)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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 non-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
      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)
         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
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         do j = 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 = 1, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               kt = class(k)
               do jcell = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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 non-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
      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 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
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call ebuck3b
      else
         call ebuck3a
      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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      real*8 e,rv,eps,rdn
      real*8 p,p2,p6,p12,fgrp
      real*8 xi,yi,zi,xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
      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
      header = .true.
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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
                  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,10)
   10                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',13x,'Atom Names',
     &                             18x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,20)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   20                format (' VDW-Buck',3x,i5,'-',a3,1x,i5,
     &                          '-',a3,12x,2f10.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, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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)  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
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,30)
   30                      format (/,' Individual van der Waals',
     &                                ' Interactions :',
     &                             //,' Type',13x,'Atom Names',
     &                                18x,'Minimum',4x,'Actual',
     &                                6x,'Energy',/)
                        end if
                        write (iout,40)  i,name(i),k,name(k),
     &                                   rv,sqrt(rik2),e
   40                   format (' VDW-Buck',3x,i5,'-',a3,1x,i5,'-',
     &                             a3,3x,'(XTAL)',3x,2f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ebuck3b  --  Buckingham analysis via lights  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ebuck3b" calculates the Buckingham exp-6 van der Waals energy
c     and also partitions the energy among the atoms using the method
c     of lights to locate neighboring atoms
c
c
      subroutine ebuck3b
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'light.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      real*8 e,rv,eps,rdn
      real*8 p,p2,p6,p12,fgrp
      real*8 xi,yi,zi,xr,yr,zr
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,taper
      real*8 expcut,expcut2
      real*8 expterm,expmerge
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
      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
      header = .true.
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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 (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)  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.and.e.ne.0.0d0)
     &                  .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,21)
   21                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',13x,'Atom Names',
     &                             18x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,31)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   31                format (' VDW-Buck',3x,i5,'-',a3,1x,i5,'-',
     &                          a3,12x,2f10.4,f12.4)
                  end if
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         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 echarge  --  charge-charge potential energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "echarge" calculates the charge-charge interaction energy
c
c
      subroutine echarge
      implicit none
      include 'sizes.i'
      include 'cutoff.i'
      include 'warp.i'
c
c
c     choose pairwise double loop, method of lights, potential
c     smoothing or Ewald summation version
c
      if (use_ewald) then
         call echarge0d
      else if (use_deform) then
         call echarge0c
      else if (use_lights) then
         call echarge0b
      else
         call echarge0a
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k
      integer ii,kk
      integer in,kn
      integer ic,kc
      real*8 e,r,r2,fgrp
      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 cscale(maxatm)
      logical proceed,iuse
c
c
c     zero out the charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     set conversion factor and switching function coefficients
c
      f = electric / dielec
      call switch ('CHARGE')
c
c     calculate the charge interaction energy term
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(ii)
         ic = kion(ii)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(ii)
         iuse = (use(i) .or. use(ic))
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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(kk)
            kc = kion(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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_image)  call image (xc,yc,zc,0)
               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)
                  fik = fi * pchg(kk) * cscale(kn)
                  e = fik / r
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     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall charge-charge energy component
c
                  ec = ec + 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)
         in = jion(ii)
         ic = kion(ii)
         iuse = (use(i) .or. use(ic))
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(ii)
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 1, ncell
                  xc = xic - x(kc)
                  yc = yic - y(kc)
                  zc = zic - z(kc)
                  call image (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)
                     fik = fi * pchg(kk)
                     if (use_polymer) then
                        if (r2 .le. polycut2)  fik = fik * cscale(kn)
                     end if
                     e = fik / r
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     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
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
      end do
      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 to locate neighboring atoms
c
c
      subroutine echarge0b
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'iounit.i'
      include 'light.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k,ii,kk
      integer in,ic,kn,kc
      integer kgy,kgz
      integer start,stop
      integer map(maxlight)
      real*8 e,r,r2,fgrp
      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 cscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
c
c
c     zero out the charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     set conversion factor and switching function coefficients
c
      f = electric / dielec
      call switch ('CHARGE')
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nion
         k = kion(i)
         xsort(i) = x(k)
         ysort(i) = y(k)
         zsort(i) = z(k)
      end do
c
c     use the method of lights to generate neighbors
c
      call lights (nion,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(ii)
         ic = kion(ii)
         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(ii)
         iuse = (use(i) .or. use(ic))
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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
         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 = iion(map(kk))
            kn = jion(map(kk))
            kc = kion(map(kk))
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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_image) 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)
                  fik = fi * pchg(map(kk)) * cscale(kn)
                  if (use_polymer) then
                     if (r2 .gt. polycut2)  fik = fi * pchg(map(kk))
                  end if
                  e = fik / r
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     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
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
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine echarge0c  --  charge energy for smoothing  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "echarge0c" calculates the charge-charge interaction energy
c     for use with potential smoothing methods
c
c
      subroutine echarge0c
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'units.i'
      include 'usage.i'
      include 'warp.i'
      integer i,j,k
      integer ii,kk
      integer in,kn
      real*8 e,r,r2,fgrp
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 erf,width,wterm
      real*8 cscale(maxatm)
      logical proceed,iuse
      external erf
c
c
c     zero out the charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     set the energy units conversion factor
c
      f = electric / dielec
c
c     scale extent of smoothing by the diffusion coefficient
c
      width = deform
      if (width .ne. 0.0d0)  width = 0.5d0 / sqrt(diffc*width)
c     if (use_gda)  wterm = sqrt(3.0d0/diffc)
      if (use_gda)  wterm = sqrt(3.0d0/(2.0d0*diffc))
c
c     calculate the charge interaction energy term
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(ii)
         iuse = (use(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do j = ii+1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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)
               fik = fi * pchg(kk) * cscale(kn)
               e = fik / r
c
c     transform the potential via diffusional smoothing
c
               if (use_gda) then
                  width = m2(i) + m2(k)
                  if (width .ne. 0.0d0)  width = wterm / sqrt(width)
               end if
               if (width .ne. 0.0d0)  e = e * erf(width*r)
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the overall charge-charge energy component
c
               ec = ec + e
            end if
         end do
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echarge0d  --  Ewald summation 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'ewald.i'
      include 'group.i'
      include 'math.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k
      integer ii,kk
      integer in,kn
      real*8 e,fs,fgrp
      real*8 f,fi,fik
      real*8 r,r2,rew
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 scale,scaleterm
      real*8 cscale(maxatm)
      logical proceed,iuse
      external erfc
c
c
c     zero out the Ewald charge interaction energy
c
      ec = 0.0d0
      if (nion .eq. 0)  return
c
c     set conversion factor, cutoff and scaling coefficients
c
      f = electric / dielec
      call switch ('EWALD')
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -electric * aewald / sqrtpi
      do ii = 1, nion
         e = fs * pchg(ii)**2
         ec = ec + e
      end do
c
c     compute the reciprocal space part of the Ewald summation
c
      call epme
c
c     compute the cell dipole boundary correction term
c
      if (.not. tinfoil) then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(ii)*x(i)
            yd = yd + pchg(ii)*y(i)
            zd = zd + pchg(ii)*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 real space portion of the Ewald summation
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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(kk)
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (iuse .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)
               if (use_image)  call image (xr,yr,zr,0)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  fik = fi * pchg(kk)
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  scaleterm = scale - 1.0d0
                  e = (fik/r) * (erfterm+scaleterm)
c
c     increment the overall charge-charge energy component
c
                  ec = ec + 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 real space portion involving other unit cells
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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)
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (iuse .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 1, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call image (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     fik = fi * pchg(kk)
                     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
                     scaleterm = scale - 1.0d0
                     e = (fik/r) * (erfterm+scaleterm)
c
c     increment the overall charge-charge energy component;
c     interaction of an atom with its own image counts half
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ec = ec + e
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine epme  --  PM Ewald reciprocal space energy  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "epme" computes the reciprocal space energy for a particle
c     mesh Ewald summation over 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
      subroutine epme
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'energi.i'
      include 'ewald.i'
      include 'math.i'
      include 'pme.i'
      include 'units.i'
      integer i,j,k,m,ii
      integer i0,j0,k0
      integer it1,it2,it3
      integer k1,k2,k3
      integer m1,m2,m3
      integer nf1,nf2,nf3
      integer nff,npoint
      integer ndim1,ndim2,ndim3
      integer ntable,nwork,ngrid
      real*8 xi,yi,zi
      real*8 w,chg,denom
      real*8 e,term,expterm
      real*8 pterm,volterm
      real*8 f,hsq,struc2
      real*8 t1,t2,t3
      real*8 h1,h2,h3
      real*8 r1,r2,r3
      real*8 fr1(maxatm)
      real*8 fr2(maxatm)
      real*8 fr3(maxatm)
      real*8 theta1(maxorder,maxatm)
      real*8 theta2(maxorder,maxatm)
      real*8 theta3(maxorder,maxatm)
      real*8 work(2*maxfft)
c
c
c     initialization of some array dimensions
c
      ndim1 = 2*(nfft1/2) + 1
      ndim2 = 2*(nfft2/2) + 1
      ndim3 = 2*(nfft3/2) + 1
      ntable = maxtable
      nwork = maxfft
      ngrid = maxgrid
      f = sqrt(electric/dielec)
c
c     zero out the 3-dimensional charge grid array
c
      do k = 1, ndim3
         do j = 1, ndim2
            do i = 1, ndim1
               qgrid(1,i,j,k) = 0.0d0
               qgrid(2,i,j,k) = 0.0d0
            end do
         end do
      end do
c
c     get the scaled and shifted fractional coordinates
c
      do ii = 1, nion
         i = iion(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         w = xi*recip(1,1) + yi*recip(2,1) + zi*recip(3,1)
         fr1(i) = nfft1 * (w-dble(nint(w))+0.5d0)
         w = xi*recip(1,2) + yi*recip(2,2) + zi*recip(3,2)
         fr2(i) = nfft2 * (w-dble(nint(w))+0.5d0)
         w = xi*recip(1,3) + yi*recip(2,3) + zi*recip(3,3)
         fr3(i) = nfft3 * (w-dble(nint(w))+0.5d0)
c
c     get the B-spline coefficients and their first derivatives
c
         w = fr1(i) - dble(int(fr1(i)))
         call bspline (w,bsorder,theta1(1,i))
         w = fr2(i) - dble(int(fr2(i)))
         call bspline (w,bsorder,theta2(1,i))
         w = fr3(i) - dble(int(fr3(i)))
         call bspline (w,bsorder,theta3(1,i))
      end do
c
c     fill the 3-dimensional charge grid array
c
      do ii = 1, nion
         m = iion(ii)
         chg = f * pchg(ii)
         k0 = int(fr3(m)) - bsorder
         do it3 = 1, bsorder
            t3 = theta3(it3,m) * chg
            k0 = k0 + 1
            k = k0 + 1 + (nfft3-sign(nfft3,k0))/2
            j0 = int(fr2(m)) - bsorder
            do it2 = 1, bsorder
               t2 = theta2(it2,m)
               term = t2 * t3
               j0 = j0 + 1
               j = j0 + 1 + (nfft2-sign(nfft2,j0))/2
               i0 = int(fr1(m)) - bsorder
               do it1 = 1, bsorder
                  t1 = theta1(it1,m)
                  i0 = i0 + 1
                  i = i0 + 1 + (nfft1-sign(nfft1,i0))/2
                  qgrid(1,i,j,k) = qgrid(1,i,j,k) + term*t1
               end do
            end do
         end do
      end do
c
c     perform the 3-D FFT forward transformation
c
      call fftfront (nfft1,nfft2,nfft3,ngrid,ngrid,ngrid,
     &                  ntable,nwork,table,work,qgrid)
c
c     sum the reciprocal space interaction energy components
c
      npoint = nfft1 * nfft2 * nfft3
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nff = nfft1 * nfft2
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      do i = 1, npoint-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
         h2 = recip(2,1)*r1 + recip(2,2)*r2
         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
            struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2
            e = 0.5d0 * expterm * struc2
            ec = ec + e
         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
      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
      implicit none
      include 'sizes.i'
      include 'cutoff.i'
      include 'warp.i'
c
c
c     choose pairwise double loop, method of lights, potential
c     smoothing or Ewald summation version
c
      if (use_ewald) then
         call echarge1d
      else if (use_deform) then
         call echarge1c
      else if (use_lights) then
         call echarge1b
      else
         call echarge1a
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      include 'virial.i'
      integer i,j,k
      integer ii,kk
      integer in,kn
      integer ic,kc
      real*8 e,de,dc
      real*8 f,fi,fik
      real*8 r,r2,fgrp
      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 cscale(maxatm)
      logical proceed,iuse
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     set conversion factor and switching function coefficients
c
      f = electric / dielec
      call switch ('CHARGE')
c
c     compute the charge interaction energy and first derivatives
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(ii)
         ic = kion(ii)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(ii)
         iuse = (use(i) .or. use(ic))
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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(kk)
            kc = kion(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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_image)  call image (xc,yc,zc,0)
               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)
                  fik = fi * pchg(kk) * cscale(kn)
                  e = fik / r
                  de = -fik / r2
                  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 diagonal components
c
                  virx = virx + xr*dedx + xc*dedxc
                  viry = viry + yr*dedy + yc*dedyc
                  virz = virz + zr*dedz + zc*dedzc
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     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(ii)
         ic = kion(ii)
         iuse = (use(i) .or. use(ic))
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(ii)
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 1, ncell
                  xc = xic - x(kc)
                  yc = yic - y(kc)
                  zc = zic - z(kc)
                  call image (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)
                     fik = fi * pchg(kk)
                     if (use_polymer) then
                        if (r2 .le. polycut2)  fik = fik * cscale(kn)
                     end if
                     e = fik / r
                     de = -fik / r2
                     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 diagonal components
c
                     virx = virx + xr*dedx + xc*dedxc
                     viry = viry + yr*dedy + yc*dedyc
                     virz = virz + zr*dedz + zc*dedzc
c
c     increment the total intermolecular energy
c
                     einter = einter + e
                  end if
               end do
            end if
         end do
      end do
      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 to locate neighboring atoms
c
c
      subroutine echarge1b
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'iounit.i'
      include 'light.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      include 'virial.i'
      integer i,j,k,ii,kk
      integer in,ic,kn,kc
      integer kgy,kgz
      integer start,stop
      integer map(maxlight)
      real*8 e,de,dc
      real*8 f,fi,fik
      real*8 r,r2,fgrp
      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 cscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
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     set conversion factor and switching function coefficients
c
      f = electric / dielec
      call switch ('CHARGE')
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nion
         k = kion(i)
         xsort(i) = x(k)
         ysort(i) = y(k)
         zsort(i) = z(k)
      end do
c
c     use the method of lights to generate neighbors
c
      call lights (nion,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(ii)
         ic = kion(ii)
         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(ii)
         iuse = (use(i) .or. use(ic))
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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
         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 = iion(map(kk))
            kn = jion(map(kk))
            kc = kion(map(kk))
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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_image) 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)
                  fik = fi * pchg(map(kk)) * cscale(kn)
                  if (use_polymer) then
                     if (r2 .gt. polycut2)  fik = fi * pchg(map(kk))
                  end if
                  e = fik / r
                  de = -fik / r2
                  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 diagonal components
c
                  virx = virx + xr*dedx + xc*dedxc
                  viry = viry + yr*dedy + yc*dedyc
                  virz = virz + zr*dedz + zc*dedzc
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
      end do
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine echarge1c  --  charge derivatives for smoothing  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "echarge1c" 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 echarge1c
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'math.i'
      include 'molcul.i'
      include 'units.i'
      include 'usage.i'
      include 'warp.i'
      integer i,j,k
      integer ii,kk
      integer in,kn
      real*8 e,de,r,r2,fgrp
      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 width,wterm
      real*8 cscale(maxatm)
      logical proceed,iuse
      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     set the energy units conversion factor
c
      f = electric / dielec
      expcut = -50.0d0
c
c     scale extent of smoothing by the diffusion coefficient
c
      width = deform
      if (width .ne. 0.0d0)  width = 0.5d0 / sqrt(diffc*width)
c     if (use_gda)  wterm = sqrt(3.0d0/diffc)
      if (use_gda)  wterm = sqrt(3.0d0/(2.0d0*diffc))
c
c     compute the charge interaction energy and first derivatives
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(ii)
         iuse = (use(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do j = ii+1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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)
               fik = fi * pchg(kk) * cscale(kn)
               e = fik / r
               de = -fik / r2
c
c     transform the potential via diffusional smoothing
c
               if (use_gda) then
                  width = m2(i) + m2(k)
                  if (width .ne. 0.0d0)  width = wterm / sqrt(width)
               end if
               if (width .ne. 0.0d0) then
                  erfterm = erf(width*r)
                  expterm = -r2 * width**2
                  if (expterm .gt. expcut) then
                     expterm = 2.0d0*fik*width*exp(expterm)
     &                                 / (sqrtpi*r)
                  else
                     expterm = 0.0d0
                  end if
                  e = e * erfterm
                  de = de*erfterm + expterm
               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
               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 echarge1d  --  Ewald summation 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'ewald.i'
      include 'group.i'
      include 'inter.i'
      include 'math.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      include 'virial.i'
      integer i,j,k
      integer ii,kk
      integer in,kn
      real*8 e,de,eintra
      real*8 f,fi,fik,fs
      real*8 r,r2,rew
      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 scale,scaleterm
      real*8 dedx,dedy,dedz
      real*8 cscale(maxatm)
      logical proceed,iuse
      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     zero out the intramolecular portion of the Ewald energy
c
      eintra = 0.0d0
c
c     set conversion factor, cutoff and scaling coefficients
c
      f = electric / dielec
      call switch ('EWALD')
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -electric * aewald / sqrtpi
      do ii = 1, nion
         e = fs * pchg(ii)**2
         ec = ec + e
      end do
c
c     compute reciprocal space Ewald energy and first derivatives
c
      call epme1
c
c     compute the cell dipole boundary correction term
c
      if (.not. tinfoil) then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(ii)*x(i)
            yd = yd + pchg(ii)*y(i)
            zd = zd + pchg(ii)*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(ii)
            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 the real space Ewald energy and first derivatives
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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(kk)
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (iuse .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     increment the total intramolecular energy
c
               if (molcule(i) .eq. molcule(k)) then
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  fik = fi * pchg(kk) * cscale(kn)
                  e = fik / r
                  eintra = eintra + e
               end if
c
c     find minimum image and check the real space cutoff
c
               if (use_image)  call image (xr,yr,zr,0)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  fik = fi * pchg(kk)
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  scaleterm = scale - 1.0d0
                  e = (fik/r) * (erfterm+scaleterm)
                  de = -fik * ((erfterm+scaleterm)/r2
     &                    + (2.0d0*aewald/sqrtpi)*exp(-rew**2)/r)
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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
               end if
            end if
         end do
      end do
c
c     intermolecular energy is total minus intramolecular part
c
      einter = einter + ec - eintra
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(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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)
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (iuse .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 1, 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 image (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     fik = fi * pchg(kk)
                     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
                     scaleterm = scale - 1.0d0
                     e = (fik/r) * (erfterm+scaleterm)
                     de = -fik * ((erfterm+scaleterm)/r2
     &                       + (2.0d0*aewald/sqrtpi)*exp(-rew**2)/r)
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 diagonal components
c
                     virx = virx + xr*dedx
                     viry = viry + yr*dedy
                     virz = virz + zr*dedz
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine epme1  --  PME reciprocal space energy & derivs  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "epme1" computes the reciprocal space energy and first
c     derivatives for a particle mesh Ewald summation
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
      subroutine epme1
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'deriv.i'
      include 'energi.i'
      include 'ewald.i'
      include 'math.i'
      include 'pme.i'
      include 'units.i'
      include 'virial.i'
      integer i,j,k,m,ii
      integer i0,j0,k0
      integer it1,it2,it3
      integer k1,k2,k3
      integer m1,m2,m3
      integer nf1,nf2,nf3
      integer nff,npoint
      integer ndim1,ndim2,ndim3
      integer ntable,nwork,ngrid
      real*8 xi,yi,zi
      real*8 w,chg,denom
      real*8 e,term,expterm
      real*8 vterm,pterm
      real*8 volterm
      real*8 f,hsq,struc2
      real*8 de1,de2,de3
      real*8 dn1,dn2,dn3
      real*8 t1,t2,t3
      real*8 dt1,dt2,dt3
      real*8 h1,h2,h3
      real*8 r1,r2,r3
      real*8 fr1(maxatm)
      real*8 fr2(maxatm)
      real*8 fr3(maxatm)
      real*8 theta1(maxorder,maxatm)
      real*8 theta2(maxorder,maxatm)
      real*8 theta3(maxorder,maxatm)
      real*8 dtheta1(maxorder,maxatm)
      real*8 dtheta2(maxorder,maxatm)
      real*8 dtheta3(maxorder,maxatm)
      real*8 work(2*maxfft)
c
c
c     initialization of some array dimensions and parameters
c
      ndim1 = 2*(nfft1/2) + 1
      ndim2 = 2*(nfft2/2) + 1
      ndim3 = 2*(nfft3/2) + 1
      ntable = maxtable
      nwork = maxfft
      ngrid = maxgrid
      f = sqrt(electric/dielec)
c
c     zero out the 3-dimensional charge grid array
c
      do k = 1, ndim3
         do j = 1, ndim2
            do i = 1, ndim1
               qgrid(1,i,j,k) = 0.0d0
               qgrid(2,i,j,k) = 0.0d0
            end do
         end do
      end do
c
c     get the scaled and shifted fractional coordinates
c
      do ii = 1, nion
         i = iion(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         w = xi*recip(1,1) + yi*recip(2,1) + zi*recip(3,1)
         fr1(i) = nfft1 * (w-dble(nint(w))+0.5d0)
         w = xi*recip(1,2) + yi*recip(2,2) + zi*recip(3,2)
         fr2(i) = nfft2 * (w-dble(nint(w))+0.5d0)
         w = xi*recip(1,3) + yi*recip(2,3) + zi*recip(3,3)
         fr3(i) = nfft3 * (w-dble(nint(w))+0.5d0)
c
c     get the B-spline coefficients and their first derivatives
c
         w = fr1(i) - dble(int(fr1(i)))
         call bspline1 (w,bsorder,theta1(1,i),dtheta1(1,i))
         w = fr2(i) - dble(int(fr2(i)))
         call bspline1 (w,bsorder,theta2(1,i),dtheta2(1,i))
         w = fr3(i) - dble(int(fr3(i)))
         call bspline1 (w,bsorder,theta3(1,i),dtheta3(1,i))
      end do
c
c     fill the 3-dimensional charge grid array
c
      do ii = 1, nion
         m = iion(ii)
         chg = f * pchg(ii)
         k0 = int(fr3(m)) - bsorder
         do it3 = 1, bsorder
            t3 = theta3(it3,m) * chg
            k0 = k0 + 1
            k = k0 + 1 + (nfft3-sign(nfft3,k0))/2
            j0 = int(fr2(m)) - bsorder
            do it2 = 1, bsorder
               t2 = theta2(it2,m)
               term = t2 * t3
               j0 = j0 + 1
               j = j0 + 1 + (nfft2-sign(nfft2,j0))/2
               i0 = int(fr1(m)) - bsorder
               do it1 = 1, bsorder
                  t1 = theta1(it1,m)
                  i0 = i0 + 1
                  i = i0 + 1 + (nfft1-sign(nfft1,i0))/2
                  qgrid(1,i,j,k) = qgrid(1,i,j,k) + term*t1
               end do
            end do
         end do
      end do
c
c     perform the 3-D FFT forward transformation
c
      call fftfront (nfft1,nfft2,nfft3,ngrid,ngrid,ngrid,
     &                  ntable,nwork,table,work,qgrid)
c
c     sum the reciprocal space energy and virial components
c
      npoint = nfft1 * nfft2 * nfft3
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nff = nfft1 * nfft2
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      do i = 1, npoint-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
         h2 = recip(2,1)*r1 + recip(2,2)*r2
         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
            struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2
            e = 0.5d0 * expterm * struc2
            ec = ec + e
            vterm = 2.0d0 * (1.0d0-term) / hsq
            virx = virx + e*(vterm*h1*h1-1.0d0)
            viry = viry + e*(vterm*h2*h2-1.0d0)
            virz = virz + e*(vterm*h3*h3-1.0d0)
         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     perform the 3-D FFT backward transformation
c
      call fftback (nfft1,nfft2,nfft3,ngrid,ngrid,ngrid,
     &                 ntable,nwork,table,work,qgrid)
c
c     get first derivatives of the reciprocal space energy
c
      dn1 = dble(nfft1)
      dn2 = dble(nfft2)
      dn3 = dble(nfft3)
      do ii = 1, nion
         m = iion(ii)
         chg = f * pchg(ii)
         de1 = 0.0d0
         de2 = 0.0d0
         de3 = 0.0d0
         k0 = int(fr3(m)) - bsorder
         do it3 = 1, bsorder
            t3 = theta3(it3,m)
            dt3 = dn3 * dtheta3(it3,m)
            k0 = k0 + 1
            k = k0 + 1 + (nfft3-sign(nfft3,k0))/2
            j0 = int(fr2(m)) - bsorder
            do it2 = 1, bsorder
               t2 = theta2(it2,m)
               dt2 = dn2 * dtheta2(it2,m)
               j0 = j0 + 1
               j = j0 + 1 + (nfft2-sign(nfft2,j0))/2
               i0 = int(fr1(m)) - bsorder
               do it1 = 1, bsorder
                  t1 = theta1(it1,m)
                  dt1 = dn1 * dtheta1(it1,m)
                  i0 = i0 + 1
                  i = i0 + 1 + (nfft1-sign(nfft1,i0))/2
                  term = qgrid(1,i,j,k)
                  de1 = de1 + term*dt1*t2*t3
                  de2 = de2 + term*dt2*t1*t3
                  de3 = de3 + term*dt3*t1*t2
               end do
            end do
         end do
         dec(1,m) = dec(1,m) + chg*(recip(1,1)*de1)
         dec(2,m) = dec(2,m) + chg*(recip(2,1)*de1+recip(2,2)*de2)
         dec(3,m) = dec(3,m) + chg*(recip(3,1)*de1+recip(3,2)*de2
     &                                   +recip(3,3)*de3)
      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 echarge2  --  atom-wise 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)
      implicit none
      include 'sizes.i'
      include 'cutoff.i'
      include 'warp.i'
      integer i
c
c
c     choose pairwise double loop, potential smoothing or
c     Ewald summation version
c
      if (use_ewald) then
         call echarge2c (i)
      else if (use_deform) then
         call echarge2b (i)
      else
         call echarge2a (i)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine echarge2a  --  charge Hessian via double loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echarge2a" calculates second derivatives of the charge-charge
c     interaction energy for a single atom using a pairwise double loop
c
c
      subroutine echarge2a (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'group.i'
      include 'hessn.i'
      include 'shunt.i'
      include 'units.i'
      integer i,j,k,kk
      integer in,kn,jcell
      real*8 e,de,d2e
      real*8 fi,fik,fgrp
      real*8 d2edx,d2edy,d2edz
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 shift,taper,trans
      real*8 dtaper,dtrans
      real*8 d2taper,d2trans
      real*8 r,r2,r3,r4
      real*8 r5,r6,r7
      real*8 term(3,3)
      real*8 cscale(maxatm)
      logical proceed
c
c
c     first see if the atom of interest carries a charge
c
      do k = 1, nion
         if (iion(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     set the list of interactions to be scaled
c
      do j = 1, nion
         cscale(iion(j)) = 1.0d0
      end do
      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
      call switch ('CHARGE')
c
c     calculate the charge interaction energy Hessian elements
c
      do kk = 1, nion
         k = iion(kk)
         kn = jion(kk)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,2,i,k,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)
            if (use_image)  call image (xr,yr,zr,0)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. off2) then
               r = sqrt(r2)
               fik = fi * pchg(kk) * cscale(kn)
c
c     compute chain rule terms for Hessian matrix elements
c
               de = -fik / r2
               d2e = -2.0d0 * de/r
c
c     use shifted energy switching if near the cutoff distance
c
               if (r2 .gt. cut2) then
                  e = fik / r
                  shift = fik / (0.5d0*(off+cut))
                  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     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 non-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(kk)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
c
c     compute the energy contribution for this interaction
c
         if (proceed) then
            do jcell = 1, ncell
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr,jcell)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  fik = fi * pchg(kk)
                  if (use_polymer) then
                     if (r2 .le. polycut2)  fik = fik * cscale(kn)
                  end if
c
c     compute chain rule terms for Hessian matrix elements
c
                  de = -fik / r2
                  d2e = -2.0d0 * de/r
c
c     use shifted energy switching if near the cutoff distance
c
                  if (r2 .gt. cut2) then
                     e = fik / r
                     shift = fik / (0.5d0*(off+cut))
                     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     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 non-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
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine echarge2b  --  charge Hessian for smoothing  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "echarge2b" calculates second derivatives of the charge-charge
c     interaction energy for a single atom for use with potential
c     smoothing methods
c
c
      subroutine echarge2b (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'group.i'
      include 'hessn.i'
      include 'math.i'
      include 'units.i'
      include 'warp.i'
      integer i,j,k,kk
      integer in,kn
      real*8 fi,fik,fgrp
      real*8 r,r2,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 width,wterm
      real*8 term(3,3)
      real*8 cscale(maxatm)
      logical proceed
      external erf
c
c
c     first see if the atom of interest carries a charge
c
      do k = 1, nion
         if (iion(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     set the list of interactions to be scaled
c
      do j = 1, nion
         cscale(iion(j)) = 1.0d0
      end do
      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     scale extent of smoothing by the diffusion coefficient
c
      width = deform
      if (width .ne. 0.0d0)  width = 0.5d0 / sqrt(diffc*width)
c     if (use_gda)  wterm = sqrt(3.0d0/diffc)
      if (use_gda)  wterm = sqrt(3.0d0/(2.0d0*diffc))
c
c     calculate the charge interaction energy Hessian elements
c
      do kk = 1, nion
         k = iion(kk)
         kn = jion(kk)
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,2,i,k,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)
            fik = fi * pchg(kk) * cscale(kn)
c
c     compute chain rule terms for Hessian matrix elements
c
            de = -fik / r2
            d2e = -2.0d0 * de/r
c
c     transform the potential via diffusional smoothing
c
            if (use_gda) then
               width = m2(i) + m2(k)
               if (width .ne. 0.0d0)  width = wterm / sqrt(width)
            end if
            if (width .ne. 0.0d0) then
               erfterm = erf(width*r)
               expterm = -r2 * width**2
               if (expterm .gt. expcut) then
                  expterm = 2.0d0*fik*width*exp(expterm) / (sqrtpi*r)
               else
                  expterm = 0.0d0
               end if
               de = de*erfterm + expterm
               d2e = -2.0d0 * (de/r + expterm*r*width**2)
            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 non-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     ##                                                            ##
c     ##  subroutine echarge2c  --  Ewald summation charge Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "echarge2c" calculates second derivatives of the charge-charge
c     interaction energy for a single atom using a particle mesh
c     Ewald summation
c
c     note this version does not incorporate the reciprocal space
c     contribution to the Hessian calculation
c
c
      subroutine echarge2c (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'cutoff.i'
      include 'ewald.i'
      include 'group.i'
      include 'hessn.i'
      include 'math.i'
      include 'units.i'
      integer i,j,k,kk
      integer in,kn,jcell
      real*8 fi,fik,fgrp
      real*8 r,r2,de,d2e
      real*8 d2edx,d2edy,d2edz
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rew,erfc,cut2
      real*8 erfterm,expterm
      real*8 scale,scaleterm
      real*8 term(3,3)
      real*8 cscale(maxatm)
      logical proceed
      external erfc
c
c
c     first see if the atom of interest carries a charge
c
      do k = 1, nion
         if (iion(k) .eq. i) then
            fi = electric * pchg(k) / dielec
            in = jion(k)
            cut2 = ewaldcut * ewaldcut
            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 list of interactions to be scaled
c
      do j = 1, nion
         cscale(iion(j)) = 1.0d0
      end do
      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(kk)
         if (use_group)  call groups (proceed,fgrp,2,i,k,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)
            if (use_image)  call image (xr,yr,zr,0)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. cut2) then
               r = sqrt(r2)
               fik = fi * pchg(kk) * cscale(kn)
               rew = aewald * r
               erfterm = erfc (rew)
               expterm = exp(-rew**2)
               scale = cscale(kn)
               if (use_group)  scale = scale * fgrp
               scaleterm = scale - 1.0d0
c
c     compute chain rule terms for Hessian matrix elements
c
               de = -fik * ((erfterm+scaleterm)/r2
     &                        + (2.0d0*aewald/sqrtpi)*expterm/r)
               d2e = -2.0d0*de/r + 2.0d0*(fik/(r*r2))*scaleterm
     &                  + (4.0d0*fik*aewald**3/sqrtpi)*expterm
     &                  + 2.0d0*(fik/(r*r2))*scaleterm
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 non-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(kk)
         if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
         proceed = .true.
c
c     compute the energy contribution for this interaction
c
         if (proceed) then
            do jcell = 1, ncell
               xr = xi - x(k)
               yr = yi - y(k)
               zr = zi - z(k)
               call image (xr,yr,zr,jcell)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. cut2) then
                  r = sqrt(r2)
                  fik = fi * pchg(kk)
                  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
                  scaleterm = scale - 1.0d0
c
c     compute chain rule terms for Hessian matrix elements
c
                  de = -fik * ((erfterm+scaleterm)/r2
     &                    + (2.0d0*aewald/sqrtpi)*exp(-rew**2)/r)
                  d2e = -2.0d0*de/r + 2.0d0*(fik/(r*r2))*scaleterm
     &                     + (4.0d0*fik*aewald**3/sqrtpi)*expterm
     &                     + 2.0d0*(fik/(r*r2))*scaleterm
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 non-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
      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
      implicit none
      include 'sizes.i'
      include 'cutoff.i'
      include 'warp.i'
c
c
c     choose pairwise double loop, method of lights, potential
c     smoothing or Ewald summation version
c
      if (use_ewald) then
         call echarge3d
      else if (use_deform) then
         call echarge3c
      else if (use_lights) then
         call echarge3b
      else
         call echarge3a
      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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k
      integer ii,kk
      integer in,kn
      integer ic,kc
      real*8 e,r,r2,fgrp
      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 cscale(maxatm)
      logical proceed,iuse
      logical header,huge
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
      header = .true.
c
c     set conversion factor and switching function coefficients
c
      f = electric / dielec
      call switch ('CHARGE')
c
c     compute and partition the charge interaction energy
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(ii)
         ic = kion(ii)
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(ii)
         iuse = (use(i) .or. use(ic))
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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(kk)
            kc = kion(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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_image)  call image (xc,yc,zc,0)
               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)
                  fik = fi * pchg(kk) * cscale(kn)
                  e = fik / r
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     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall charge-charge energy component
c
                  nec = nec + 1
                  ec = ec + e
                  aec(i) = aec(i) + 0.5d0*e
                  aec(k) = aec(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 = (abs(e) .gt. 100.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,10)
   10                   format (/,' Individual Charge-Charge',
     &                             ' Interactions :',
     &                          //,' Type',13x,'Atom Names',
     &                             16x,'Charges',5x,'Distance',
     &                             5x,'Energy',/)
                     end if
                     write (iout,20)  i,name(i),k,name(k),
     &                                pchg(ii),pchg(kk),r,e
   20                format (' Charge',5x,i5,'-',a3,1x,i5,'-',
     &                          a3,8x,2f7.2,f10.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)
         in = jion(ii)
         ic = kion(ii)
         iuse = (use(i) .or. use(ic))
         xic = x(ic)
         yic = y(ic)
         zic = z(ic)
         xi = x(i) - xic
         yi = y(i) - yic
         zi = z(i) - zic
         fi = f * pchg(ii)
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kc))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 1, ncell
                  xc = xic - x(kc)
                  yc = yic - y(kc)
                  zc = zic - z(kc)
                  call image (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)
                     fik = fi * pchg(kk)
                     if (use_polymer) then
                        if (r2 .le. polycut2)  fik = fik * cscale(kn)
                     end if
                     e = fik / r
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     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall charge-charge energy component
c
                     if (i .eq. k)  e = 0.5d0 * e
                     if (e .ne. 0.0d0)  nec = nec + 1
                     ec = ec + e
                     aec(i) = aec(i) + 0.5d0*e
                     aec(k) = aec(k) + 0.5d0*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. 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',13x,'Atom Names',
     &                                16x,'Charges',5x,'Distance',
     &                                5x,'Energy',/)
                        end if
                        write (iout,40)  i,name(i),k,name(k),
     &                                   pchg(ii),pchg(kk),r,e
   40                   format (' Charge',5x,i5,'-',a3,1x,i5,'-',a3,
     &                             1x,'(XTAL)',1x,2f7.2,f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
      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 to locate neighboring atoms
c
c
      subroutine echarge3b
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'light.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k,ii,kk
      integer in,ic,kn,kc
      integer kgy,kgz
      integer start,stop
      integer map(maxlight)
      real*8 e,r,r2,fgrp
      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 cscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
      logical header,huge
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
      header = .true.
c
c     set conversion factor and switching function coefficients
c
      f = electric / dielec
      call switch ('CHARGE')
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nion
         k = kion(i)
         xsort(i) = x(k)
         ysort(i) = y(k)
         zsort(i) = z(k)
      end do
c
c     use the method of lights to generate neighbors
c
      call lights (nion,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nion
         i = iion(ii)
         in = jion(ii)
         ic = kion(ii)
         iuse = (use(i) .or. use(ic))
         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(ii)
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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
         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 40
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 40
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 40
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 40
            end if
            k = iion(map(kk))
            kn = jion(map(kk))
            kc = kion(map(kk))
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kc))
            if (proceed)  proceed = (cscale(kc) .ne. 0.0d0)
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_image) 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)
                  fik = fi * pchg(map(kk)) * cscale(kn)
                  if (use_polymer) then
                     if (r2 .gt. polycut2)  fik = fi * pchg(map(kk))
                  end if
                  e = fik / r
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     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall charge-charge energy component
c
                  if (e .ne. 0.0d0)  nec = nec + 1
                  ec = ec + e
                  aec(i) = aec(i) + 0.5d0*e
                  aec(k) = aec(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 = (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',13x,'Atom Names',
     &                             16x,'Charges',5x,'Distance',
     &                             5x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),pchg(ii),
     &                                pchg(map(kk)),r,e
   30                format (' Charge',5x,i5,'-',a3,1x,i5,'-',
     &                          a3,8x,2f7.2,f10.4,f12.4)
                  end if
               end if
            end if
   40       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine echarge3c  --  charge analysis for smoothing  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "echarge3c" calculates the charge-charge interaction energy
c     and partitions the energy among the atoms for use with
c     potential smoothing methods
c
c
      subroutine echarge3c
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'units.i'
      include 'usage.i'
      include 'warp.i'
      integer i,j,k
      integer ii,kk
      integer in,kn
      real*8 e,r,r2,fgrp
      real*8 f,fi,fik
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 erf,width,wterm
      real*8 cscale(maxatm)
      logical proceed,iuse
      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
      header = .true.
c
c     set the energy units conversion factor
c
      f = electric / dielec
c
c     scale extent of smoothing by the diffusion coefficient
c
      width = deform
      if (width .ne. 0.0d0)  width = 0.5d0 / sqrt(diffc*width)
c     if (use_gda)  wterm = sqrt(3.0d0/diffc)
      if (use_gda)  wterm = sqrt(3.0d0/(2.0d0*diffc))
c
c     compute and partition the charge interaction energy
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(ii)
         iuse = (use(i))
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do j = ii+1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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(kk)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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)
               fik = fi * pchg(kk) * cscale(kn)
               e = fik / r
c
c     transform the potential via diffusional smoothing
c
               if (use_gda) then
                  width = m2(i) + m2(k)
                  if (width .ne. 0.0d0)  width = wterm / sqrt(width)
               end if
               if (width .ne. 0.0d0)  e = e * erf(width*r)
c
c     scale the interaction based on its group membership
c
               if (use_group)  e = e * fgrp
c
c     increment the overall charge-charge energy component
c
               nec = nec + 1
               ec = ec + e
               aec(i) = aec(i) + 0.5d0*e
               aec(k) = aec(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 = (abs(e) .gt. 100.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,10)
   10                format (/,' Individual Charge-Charge',
     &                          ' Interactions :',
     &                       //,' Type',11x,'Atom Names',
     &                          16x,'Charges',5x,'Distance',
     &                          5x,'Energy',/)
                  end if
                  write (iout,20)  i,name(i),k,name(k),pchg(ii),
     &                             pchg(kk),r,e
   20             format (' Charge',5x,i5,'-',a3,1x,i5,'-',
     &                       a3,8x,2f7.2,f10.4,f12.4)
               end if
            end if
         end do
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine echarge3d  --  Ewald summation charge analysis  ##
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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'ewald.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'math.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k
      integer ii,kk
      integer in,kn
      real*8 e,eintra
      real*8 f,fi,fik,fs
      real*8 r,r2,rew,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xd,yd,zd
      real*8 erfc,erfterm
      real*8 scale,scaleterm
      real*8 cscale(maxatm)
      logical proceed,iuse
      logical header,huge
      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
      header = .true.
c
c     zero out the intramolecular portion of the Ewald energy
c
      eintra = 0.0d0
c
c     set conversion factor and cutoff coefficients
c
      f = electric / dielec
      call switch ('EWALD')
c
c     compute the Ewald self-energy term over all the atoms
c
      fs = -electric * aewald / sqrtpi
      do ii = 1, nion
         e = fs * pchg(ii)**2
         ec = ec + e
      end do
c
c     compute the reciprocal space part of the Ewald summation
c
      call epme3
c
c     compute the cell dipole boundary correction term
c
      if (.not. tinfoil) then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         do ii = 1, nion
            i = iion(ii)
            xd = xd + pchg(ii)*x(i)
            yd = yd + pchg(ii)*y(i)
            zd = zd + pchg(ii)*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 real space portion of the Ewald summation
c
      do ii = 1, nion-1
         i = iion(ii)
         in = jion(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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(kk)
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (iuse .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     increment the total intramolecular energy
c
               if (molcule(i) .eq. molcule(k)) then
                  r2 = xr*xr + yr*yr + zr*zr
                  r = sqrt(r2)
                  fik = fi * pchg(kk) * cscale(kn)
                  e = fik / r
                  eintra = eintra + e
               end if
c
c     find minimum image and check the real space cutoff
c
               if (use_image)  call image (xr,yr,zr,0)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. off2) then
                  r = sqrt(r2)
                  fik = fi * pchg(kk)
                  rew = aewald * r
                  erfterm = erfc (rew)
                  scale = cscale(kn)
                  if (use_group)  scale = scale * fgrp
                  scaleterm = scale - 1.0d0
                  e = (fik/r) * (erfterm+scaleterm)
c
c     increment the overall charge-charge energy component
c
                  nec = nec + 1
                  ec = ec + e
                  aec(i) = aec(i) + 0.5d0*e
                  aec(k) = aec(k) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
                  huge = (abs(e) .gt. 100.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,10)
   10                   format (/,' Individual Real Space Ewald',
     &                             ' Charge-Charge Interactions :',
     &                          //,' Type',13x,'Atom Names',
     &                             16x,'Charges',5x,'Distance',
     &                             5x,'Energy',/)
                     end if
                     write (iout,20)  i,name(i),k,name(k),
     &                                pchg(ii),pchg(kk),r,e
   20                format (' Charge',5x,i5,'-',a3,1x,i5,'-',
     &                          a3,8x,2f7.2,f10.4,f12.4)
                  end if
               end if
            end if
         end do
      end do
c
c     intermolecular energy is total minus intramolecular part
c
      einter = einter + ec - eintra
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(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do j = 1, nion
            cscale(iion(j)) = 1.0d0
         end do
         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)
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (iuse .or. use(k))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 1, ncell
                  xr = xi - x(k)
                  yr = yi - y(k)
                  zr = zi - z(k)
                  call image (xr,yr,zr,j)
                  r2 = xr*xr + yr*yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     fik = fi * pchg(kk)
                     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
                     scaleterm = scale - 1.0d0
                     e = (fik/r) * (erfterm+scaleterm)
c
c     increment the overall charge-charge energy component
c
                     if (i .eq. k)  e = 0.5d0 * e
                     if (e .ne. 0.0d0)  nec = nec + 1
                     ec = ec + e
                     aec(i) = aec(i) + 0.5d0*e
                     aec(k) = aec(k) + 0.5d0*e
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 Real Space Ewald',
     &                                ' Charge-Charge Interactions :',
     &                             //,' Type',13x,'Atom Names',
     &                                16x,'Charges',5x,'Distance',
     &                                5x,'Energy',/)
                        end if
                        write (iout,40)  i,name(i),k,name(k),
     &                                   pchg(ii),pchg(kk),r,e
   40                   format (' Charge',5x,i5,'-',a3,1x,i5,'-',a3,
     &                             1x,'(XTAL)',1x,2f7.2,f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine epme3  --  PM Ewald recip energy & analysis  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "epme3" computes the reciprocal space energy for a particle
c     mesh Ewald summation over partial charges and prints information
c     about the energy over the charge grid points
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
      subroutine epme3
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'energi.i'
      include 'ewald.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'pme.i'
      include 'units.i'
      integer i,j,k,m,ii
      integer i0,j0,k0
      integer it1,it2,it3
      integer k1,k2,k3
      integer m1,m2,m3
      integer nf1,nf2,nf3
      integer nff,npoint
      integer ndim1,ndim2,ndim3
      integer ntable,nwork,ngrid
      real*8 xi,yi,zi
      real*8 w,chg,denom
      real*8 e,term,expterm
      real*8 pterm,volterm
      real*8 f,hsq,struc2
      real*8 t1,t2,t3
      real*8 h1,h2,h3
      real*8 r1,r2,r3
      real*8 fr1(maxatm)
      real*8 fr2(maxatm)
      real*8 fr3(maxatm)
      real*8 theta1(maxorder,maxatm)
      real*8 theta2(maxorder,maxatm)
      real*8 theta3(maxorder,maxatm)
      real*8 work(2*maxfft)
      logical header,huge
c
c
c     initialization of some array dimensions
c
      ndim1 = 2*(nfft1/2) + 1
      ndim2 = 2*(nfft2/2) + 1
      ndim3 = 2*(nfft3/2) + 1
      ntable = maxtable
      nwork = maxfft
      ngrid = maxgrid
      f = sqrt(electric/dielec)
c
c     zero out the 3-dimensional charge grid array
c
      do k = 1, ndim3
         do j = 1, ndim2
            do i = 1, ndim1
               qgrid(1,i,j,k) = 0.0d0
               qgrid(2,i,j,k) = 0.0d0
            end do
         end do
      end do
c
c     get the scaled and shifted fractional coordinates
c
      do ii = 1, nion
         i = iion(ii)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         w = xi*recip(1,1) + yi*recip(2,1) + zi*recip(3,1)
         fr1(i) = nfft1 * (w-dble(nint(w))+0.5d0)
         w = xi*recip(1,2) + yi*recip(2,2) + zi*recip(3,2)
         fr2(i) = nfft2 * (w-dble(nint(w))+0.5d0)
         w = xi*recip(1,3) + yi*recip(2,3) + zi*recip(3,3)
         fr3(i) = nfft3 * (w-dble(nint(w))+0.5d0)
c
c     get the B-spline coefficients and their first derivatives
c
         w = fr1(i) - dble(int(fr1(i)))
         call bspline (w,bsorder,theta1(1,i))
         w = fr2(i) - dble(int(fr2(i)))
         call bspline (w,bsorder,theta2(1,i))
         w = fr3(i) - dble(int(fr3(i)))
         call bspline (w,bsorder,theta3(1,i))
      end do
c
c     fill the 3-dimensional charge grid array
c
      do ii = 1, nion
         m = iion(ii)
         chg = f * pchg(ii)
         k0 = int(fr3(m)) - bsorder
         do it3 = 1, bsorder
            t3 = theta3(it3,m) * chg
            k0 = k0 + 1
            k = k0 + 1 + (nfft3-sign(nfft3,k0))/2
            j0 = int(fr2(m)) - bsorder
            do it2 = 1, bsorder
               t2 = theta2(it2,m)
               term = t2 * t3
               j0 = j0 + 1
               j = j0 + 1 + (nfft2-sign(nfft2,j0))/2
               i0 = int(fr1(m)) - bsorder
               do it1 = 1, bsorder
                  t1 = theta1(it1,m)
                  i0 = i0 + 1
                  i = i0 + 1 + (nfft1-sign(nfft1,i0))/2
                  qgrid(1,i,j,k) = qgrid(1,i,j,k) + term*t1
               end do
            end do
         end do
      end do
c
c     perform the 3-D FFT forward transformation
c
      call fftfront (nfft1,nfft2,nfft3,ngrid,ngrid,ngrid,
     &                  ntable,nwork,table,work,qgrid)
c
c     sum the reciprocal space interaction energy components
c
      header = .true.
      npoint = nfft1 * nfft2 * nfft3
      pterm = (pi/aewald)**2
      volterm = pi * volbox
      nff = nfft1 * nfft2
      nf1 = (nfft1+1) / 2
      nf2 = (nfft2+1) / 2
      nf3 = (nfft3+1) / 2
      do i = 1, npoint-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
         h2 = recip(2,1)*r1 + recip(2,2)*r2
         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
            struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2
            e = 0.5d0 * expterm * struc2
            nec = nec + 1
            ec = ec + e
         end if
         qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3)
         qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3)
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,10)
   10          format (/,' Reciprocal Space Ewald',
     &                    ' Charge-Charge Interactions :',
     &                 //,' Type',15x,'K-Vector',18x,'Fraction',
     &                    15x,'Energy',/)
            end if
            write (iout,20)  m1,m2,m3,hsq,e
   20       format (' Charge',7x,3i5,16x,f8.4,10x,f12.4)
         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 echgdpl  --  charge-dipole potential energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "echgdpl" calculates the charge-dipole interaction energy
c
c
      subroutine echgdpl
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'dipole.i'
      include 'energi.i'
      include 'group.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k
      integer i1,k1,k2
      integer skip(maxatm)
      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
c
c
c     zero out the overall charge-dipole interaction energy
c
      ecd = 0.0d0
      if (ndipole.eq.0 .or. nion.eq.0)  return
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)
      call switch ('CHGDPL')
c
c     get the total energy by looping over each charge-dipole pair
c
      do i = 1, nion
         i1 = iion(i)
         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(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,3,i1,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(k1) .or. use(k2))
            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
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               xr = xi - x(k1) - xk*sdpl(k)
               yr = yi - y(k1) - yk*sdpl(k)
               zr = zi - z(k1) - zk*sdpl(k)
               if (use_image)  call image (xr,yr,zr,0)
               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 i = 1, nion
         i1 = iion(i)
         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(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,3,i1,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(k1) .or. use(k2))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 1, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  xr = xi - x(k1) - xk*sdpl(k)
                  yr = yi - y(k1) - yk*sdpl(k)
                  zr = zi - z(k1) - zk*sdpl(k)
                  call image (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.i1 .or. skip(k2).ne.i1)
     &                        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
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'deriv.i'
      include 'dipole.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      include 'virial.i'
      integer i,j,k
      integer i1,k1,k2
      integer skip(maxatm)
      real*8 e,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 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,r2,r3,r4,r5
      real*8 taper,dtaper
      real*8 dtaperx,dtapery,dtaperz
      logical proceed
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 (ndipole.eq.0 .or. nion.eq.0)  return
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)
      call switch ('CHGDPL')
c
c     get energy and derivs by looping over each charge-dipole pair
c
      do i = 1, nion
         i1 = iion(i)
         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(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,3,i1,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(k1) .or. use(k2))
            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(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               xr = xi - x(k1) - xk*sk2
               yr = yi - y(k1) - yk*sk2
               zr = zi - z(k1) - zk*sk2
               if (use_image)  call image (xr,yr,zr,0)
               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,i1) = decd(1,i1) + dedxi1
                  decd(2,i1) = decd(2,i1) + dedyi1
                  decd(3,i1) = decd(3,i1) + 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 diagonal components
c
                  virx = virx - (xr+xk*sk2)*dedxk1 - (xr-xk*sk1)*dedxk2
                  viry = viry - (yr+yk*sk2)*dedyk1 - (yr-yk*sk1)*dedyk2
                  virz = virz - (zr+zk*sk2)*dedzk1 - (zr-zk*sk1)*dedzk2
c
c     increment the total intermolecular energy
c
                  if (molcule(i1) .ne. molcule(k1)) then
                     einter = einter + e
                  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, nion
         i1 = iion(i)
         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(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,3,i1,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .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 = 1, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  xr = xi - x(k1) - xk*sk2
                  yr = yi - y(k1) - yk*sk2
                  zr = zi - z(k1) - zk*sk2
                  call image (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.i1 .or. skip(k2).ne.i1)
     &                        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,i1) = decd(1,i1) + dedxi1
                     decd(2,i1) = decd(2,i1) + dedyi1
                     decd(3,i1) = decd(3,i1) + 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 diagonal components
c
                  virx = virx - (xr+xk*sk2)*dedxk1 - (xr-xk*sk1)*dedxk2
                  viry = viry - (yr+yk*sk2)*dedyk1 - (yr-yk*sk1)*dedyk2
                  virz = virz - (zr+zk*sk2)*dedzk1 - (zr-zk*sk1)*dedzk2
c
c     increment the total intermolecular energy
c
                  einter = einter + e
               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 echgdpl2  --  atom-wise 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'dipole.i'
      include 'group.i'
      include 'hessn.i'
      include 'shunt.i'
      include 'units.i'
      integer i,k,jcell
      integer ii,i1,k1,k2
      integer skip(maxatm)
      integer omit(maxatm)
      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
c
c
c     zero out the lists of atoms to be skipped
c
      if (ndipole.eq.0 .or. nion.eq.0)  return
      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)
      call switch ('CHGDPL')
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(ii)
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,3,i1,k1,k2,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
               if (use_image)  call image (xr,yr,zr,0)
               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,3,i1,k1,k2,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
               if (use_image)  call image (xr,yr,zr,0)
               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(ii)
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(ii)
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,3,i1,k1,k2,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 = 1, 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 image (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,3,i1,k1,k2,0,0)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do jcell = 1, ncell
                  xr = x(i1) - xq
                  yr = y(i1) - yq
                  zr = z(i1) - zq
                  call image (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(ii)
                     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
      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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'dipole.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k
      integer i1,k1,k2
      integer skip(maxatm)
      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
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 (ndipole.eq.0 .or. nion.eq.0)  return
      header = .true.
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)
      call switch ('CHGDPL')
c
c     get the total energy by looping over each charge-dipole pair
c
      do i = 1, nion
         i1 = iion(i)
         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(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,3,i1,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(k1) .or. use(k2))
            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
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               xr = xi - x(k1) - xk*sdpl(k)
               yr = yi - y(k1) - yk*sdpl(k)
               zr = zi - z(k1) - zk*sdpl(k)
               if (use_image)  call image (xr,yr,zr,0)
               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(i1) = aecd(i1) + 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(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. 25.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,10)
   10                   format (/,' Individual Charge-Dipole',
     &                             ' Interactions :',
     &                          //,' Type',10x,'Charge',11x,'Dipole',
     &                             17x,'Distance',6x,'Energy',/)
                     end if
                     write (iout,20)  i1,name(i1),k1,name(k1),
     &                                k2,name(k2),sqrt(r2),e
   20                format (' Chg-Dpl',4x,i5,'-',a3,' / ',i5,'-',a3,
     &                          1x,i5,'-',a3,10x,f10.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, nion
         i1 = iion(i)
         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(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,3,i1,k1,k2,0,0)
            if (proceed)  proceed = (use(i1) .or. use(k1) .or. use(k2))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 1, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  xr = xi - x(k1) - xk*sdpl(k)
                  yr = yi - y(k1) - yk*sdpl(k)
                  zr = zi - z(k1) - zk*sdpl(k)
                  call image (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.i1 .or. skip(k2).ne.i1)
     &                        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(i1) = aecd(i1) + 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,30)
   30                      format (/,' Individual Charge-Dipole',
     &                                ' Interactions :',
     &                             //,' Type',10x,'Charge',11x,'Dipole',
     &                                17x,'Distance',6x,'Energy',/)
                        end if
                        write (iout,40)  i1,name(i1),k1,name(k1),
     &                                   k2,name(k2),sqrt(r2),e
   40                   format (' Chg-Dpl',4x,i5,'-',a3,' / ',i5,'-',
     &                             a3,1x,i5,'-',a3,2x,'(XTAL)',
     &                             2x,f10.4,f12.4)
                     end if
                  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 edipole  --  dipole-dipole potential energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "edipole" calculates the dipole-dipole interaction energy
c
c
      subroutine edipole
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'dipole.i'
      include 'energi.i'
      include 'group.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      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
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)
      call switch ('DIPOLE')
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)
         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,4,i1,i2,k1,k2,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)
               xr = xq - x(k1) - xk*sdpl(k)
               yr = yq - y(k1) - yk*sdpl(k)
               zr = zq - z(k1) - zk*sdpl(k)
               if (use_image)  call image (xr,yr,zr,0)
               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)
         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,4,i1,i2,k1,k2,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 = 1, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  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,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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'deriv.i'
      include 'dipole.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      include 'virial.i'
      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,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
      logical proceed
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)
      call switch ('DIPOLE')
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)
         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,4,i1,i2,k1,k2,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)
               xr = xq - x(k1) - xk*sk2
               yr = yq - y(k1) - yk*sk2
               zr = zq - z(k1) - zk*sk2
               if (use_image)  call image (xr,yr,zr,0)
               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 diagonal components
c
                  virx = virx + xr*(dedxi1+dedxi2)
                  viry = viry + yr*(dedyi1+dedyi2)
                  virz = virz + zr*(dedzi1+dedzi2)
c
c     increment the total intermolecular energy
c
                  if (molcule(i1) .ne. molcule(k1)) then
                     einter = einter + e
                  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)
         si1 = 1.0d0 - sdpl(i)
         si2 = sdpl(i)
         xi = x(i2) - x(i1)
         yi = y(i2) - y(i1)
         zi = z(i2) - z(i1)
         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,4,i1,i2,k1,k2,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 = 1, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  xr = xq - x(k1) - xk*sk2
                  yr = yq - y(k1) - yk*sk2
                  zr = zq - z(k1) - zk*sk2
                  call image (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 diagonal components
c
                     virx = virx + xr*(dedxi1+dedxi2)
                     viry = viry + yr*(dedyi1+dedyi2)
                     virz = virz + zr*(dedzi1+dedzi2)
c
c     increment the total intermolecular energy
c
                     einter = einter + 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 edipole2  --  atom-wise 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'dipole.i'
      include 'group.i'
      include 'hessn.i'
      include 'units.i'
      include 'shunt.i'
      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
c
c
c     set conversion factor and switching function coefficients
c
      if (ndipole .eq. 0)  return
      f = electric / (debye**2 * dielec)
      call switch ('DIPOLE')
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)
         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,4,i1,i2,k1,k2,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)
               xr = xq - x(k1) - xk*sk2
               yr = yq - y(k1) - yk*sk2
               zr = zq - z(k1) - zk*sk2
               if (use_image)  call image (xr,yr,zr,0)
               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)
         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,4,i1,i2,k1,k2,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 = 1, ncell
               xk = x(k2) - x(k1)
               yk = y(k2) - y(k1)
               zk = z(k2) - z(k1)
               xr = xq - x(k1) - xk*sk2
               yr = yq - y(k1) - yk*sk2
               zr = zq - z(k1) - zk*sk2
               call image (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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'dipole.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      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
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
      header = .true.
c
c     set conversion factor and switching function coefficients
c
      f = electric / (debye**2 * dielec)
      call switch ('DIPOLE')
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)
         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,4,i1,i2,k1,k2,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)
               xr = xq - x(k1) - xk*sdpl(k)
               yr = yq - y(k1) - yk*sdpl(k)
               zr = zq - z(k1) - zk*sdpl(k)
               if (use_image)  call image (xr,yr,zr,0)
               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,10)
   10                   format (/,' Individual Dipole-Dipole',
     &                             ' Interactions :',
     &                          //,' Type',14x,'Dipole 1',14x,
     &                             'Dipole 2',6x,'Distance',
     &                             6x,'Energy',/)
                     end if
                     write (iout,20)  i1,name(i1),i2,name(i2),
     &                                k1,name(k1),k2,name(k2),
     &                                sqrt(r2),e
   20                format (' Dipole',5x,i5,'-',a3,1x,i5,'-',a3,
     &                          ' / ',i5,'-',a3,1x,i5,'-',a3,
     &                          f10.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)
         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,4,i1,i2,k1,k2,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 = 1, ncell
                  xk = x(k2) - x(k1)
                  yk = y(k2) - y(k1)
                  zk = z(k2) - z(k1)
                  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,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,30)
   30                      format (/,' Individual Dipole-Dipole',
     &                                ' Interactions :',
     &                             //,' Type',14x,'Dipole 1',14x,
     &                               'Dipole 2',6x,'Distance',
     &                                6x,'Energy',/)
                        end if
                        write (iout,40)  i1,name(i1),i2,name(i2),
     &                                   k1,name(k1),k2,name(k2),
     &                                   sqrt(r2),e
  40                   format (' Dipole',5x,i5,'-',a3,1x,i5,'-',a3,
     &                            ' / ',i5,'-',a3,1x,i5,'-',a3,
     &                            f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
      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
c     interaction energy
c
c
      subroutine egauss
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'warp.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      real*8 e,rik2,rdn
      real*8 eps,rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 expcut,expterm
      real*8 width,wterm
      real*8 t1,t2,a(4),b(4)
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set cutoff distances and switching function coefficients
c
      call switch ('VDW')
      expcut = -50.0d0
c
c     scale extent of smoothing by the diffusion coefficient
c
      if (use_deform)  width = 4.0d0 * diffv * deform
      if (use_gda)  wterm = (2.0d0/3.0d0) * diffv
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)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               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
               if (rik2 .le. off2) then
                  eps = epsilon(kt,it)
                  rad2 = radmin(kt,it)**2
                  if (iv14(k) .eq. i) then
                     eps = epsilon4(kt,it)
                     rad2 = radmin4(kt,it)**2
                  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 via diffusional smoothing
c
                  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
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
      end do
      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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'warp.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      real*8 e,de,rdn
      real*8 rik,rik2
      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 width,wterm
      real*8 t1,t2,a(4),b(4)
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
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
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
      expcut = -50.0d0
c
c     scale extent of smoothing by the diffusion coefficient
c
      if (use_deform)  width = 4.0d0 * diffv * deform
      if (use_gda)  wterm = (2.0d0/3.0d0) * diffv
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)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               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
               if (rik2 .le. off2) then
                  eps = epsilon(kt,it)
                  rad2 = radmin(kt,it)**2
                  if (iv14(k) .eq. i) then
                     eps = epsilon4(kt,it)
                     rad2 = radmin4(kt,it)**2
                  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 via diffusional smoothing
c
                  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
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 total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
               end if
            end if
         end do
      end do
      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 (iatom,xred,yred,zred)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'group.i'
      include 'hessn.i'
      include 'shunt.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'warp.i'
      integer i,j,k,iatom
      integer ii,kk,iv,kv,it,kt
      integer nuse,use(5)
      integer iv14(maxatm)
      real*8 de,d2e,rik,rik2
      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 redi2,rediv2,rediiv
      real*8 redik,redivk
      real*8 redikv,redivkv
      real*8 d2edx,d2edy,d2edz
      real*8 expcut,expterm
      real*8 width,wterm
      real*8 t1,t2,a(4),b(4)
      real*8 term(3,3)
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed
c
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
      expcut = -50.0d0
c
c     scale extent of smoothing by the diffusion coefficient
c
      if (use_deform)  width = 4.0d0 * diffv * deform
      if (use_gda)  wterm = (2.0d0/3.0d0) * diffv
c
c     check to see if the atom of interest is a vdw site
c
      nuse = 0
      do k = 1, nvdw
         if (ivdw(k) .eq. iatom) then
            nuse = nuse + 1
            use(nuse) = iatom
            goto 10
         end if
      end do
      return
   10 continue
c
c     determine the atoms involved via reduction factors
c
      nuse = 1
      use(nuse) = iatom
      do k = 1, n12(iatom)
         i = i12(k,iatom)
         if (ired(i) .eq. iatom) then
            nuse = nuse + 1
            use(nuse) = i
         end if
      end do
c
c     find van der Waals Hessian elements for involved atoms
c
      do ii = 1, nuse
         i = use(ii)
         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
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         do j = 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 = 1, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = (k .ne. i)
            if (proceed .and. use_group)
     &         call groups (proceed,fgrp,2,i,k,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               kt = class(k)
               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
               if (rik2 .le. off2) then
                  eps = epsilon(kt,it)
                  rad2 = radmin(kt,it)**2
                  if (iv14(k) .eq. i) then
                     eps = epsilon4(kt,it)
                     rad2 = radmin4(kt,it)**2
                  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 via diffusional smoothing
c
                  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
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 non-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
      end do
      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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'warp.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      real*8 e,rik2,rdn,rv
      real*8 eps,rad2,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 expcut,expterm
      real*8 width,wterm
      real*8 t1,t2,a(4),b(4)
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
      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
      header = .true.
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
      expcut = -50.0d0
c
c     scale extent of smoothing by the diffusion coefficient
c
      if (use_deform)  width = 4.0d0 * diffv * deform
      if (use_gda)  wterm = (2.0d0/3.0d0) * diffv
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)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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
               kt = class(k)
               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
               if (rik2 .le. off2) then
                  eps = epsilon(kt,it)
                  rad2 = radmin(kt,it)**2
                  if (iv14(k) .eq. i) then
                     eps = epsilon4(kt,it)
                     rad2 = radmin4(kt,it)**2
                  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 via diffusional smoothing
c
                  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
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,10)
   10                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',13x,'Atom Names',
     &                             18x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     rv = radmin(kt,it)
                     write (iout,20)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   20                format (' VDW-Gauss',2x,i5,'-',a3,1x,i5,
     &                         '-',a3,12x,2f10.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     ##              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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'kgeoms.i'
      include 'math.i'
      include 'molcul.i'
      include 'usage.i'
      integer i,k
      integer ia,ib,ic,id
      real*8 e,dt,dt2,fgrp
      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 df1,df2
      real*8 af1,af2
      real*8 tf1,tf2,t1,t2
      real*8 xi,yi,zi,ri
      real*8 a,b,buffer,term
      logical proceed,intermol
c
c
c     zero out the geometric restraint energy terms
c
      eg = 0.0d0
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,1,ia,0,0,0,0)
         if (proceed)  proceed = (use(ia))
         if (proceed) then
            xr = x(ia) - xpfix(i)
            yr = y(ia) - ypfix(i)
            zr = z(ia) - zpfix(i)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            dt = max(0.0d0,r-pfix(1,i))
            dt2 = dt * dt
            force = pfix(2,i)
            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,2,ia,ib,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,0)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            df1 = dfix(1,i)
            df2 = dfix(2,i)
            target = r
            if (r .lt. df1)  target = df1
            if (r .gt. df2)  target = df2
            force = dfix(3,i)
            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,3,ia,ib,ic,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 = xab*xab + yab*yab + zab*zab
            rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
            if (rab2.ne.0.0d0 .and. rcb2.ne.0.0d0) then
               dot = xab*xcb + yab*ycb + zab*zcb
               cosine = dot / sqrt(rab2*rcb2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               af1 = afix(1,i)
               af2 = afix(2,i)
               target = angle
               if (angle .lt. af1)  target = af1
               if (angle .gt. af2)  target = af2
               force = afix(3,i)
               dt = angle - target
               dt2 = dt * dt
               e = force * dt2
               if (use_group)  e = e * fgrp
               eg = eg + e
            end if
         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,4,ia,ib,ic,id,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
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            xt = yba*zcb - ycb*zba
            yt = zba*xcb - zcb*xba
            zt = xba*ycb - xcb*yba
            xu = ycb*zdc - ydc*zcb
            yu = zcb*xdc - zdc*xcb
            zu = xcb*ydc - xdc*ycb
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               if (sine .lt. 0.0d0)  angle = -angle
               tf1 = tfix(1,i)
               tf2 = tfix(2,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
               force = tfix(3,i)
               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
               dt2 = dt * dt
               e = force * dt2
               if (use_group)  e = e * fgrp
               eg = eg + e
            end if
         end if
      end do
c
c     compute the energy for a Gaussian basin restraint
c
      if (use_basin) then
         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,2,i,k,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
                  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,1,i,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
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'kgeoms.i'
      include 'molcul.i'
      include 'math.i'
      include 'usage.i'
      include 'virial.i'
      integer i,k
      integer ia,ib,ic,id
      real*8 e,xr,yr,zr,fgrp
      real*8 de,dt,dt2,deddt
      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 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 xi,yi,zi,ri
      real*8 a,b,buffer,term
      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     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,1,ia,0,0,0,0)
         if (proceed)  proceed = (use(ia))
         if (proceed) then
            xr = x(ia) - xpfix(i)
            yr = y(ia) - ypfix(i)
            zr = z(ia) - zpfix(i)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            dt = max(0.0d0,r-pfix(1,i))
            dt2 = dt * dt
            force = pfix(2,i)
            e = force * dt2
            if (r .eq. 0.0d0)  r = 1.0d0
            de = 2.0d0 * force * dt / r
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 diagonal components
c
            virx = virx + xr*dedx
            viry = viry + yr*dedy
            virz = virz + zr*dedz
         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,2,ia,ib,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,0)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            df1 = dfix(1,i)
            df2 = dfix(2,i)
            target = r
            if (r .lt. df1)  target = df1
            if (r .gt. df2)  target = df2
            force = dfix(3,i)
            dt = r - target
            dt2 = dt * dt
            e = force * dt2
            if (r .eq. 0.0d0)  r = 1.0d0
            de = 2.0d0 * force * dt / r
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 diagonal components
c
            virx = virx + xr*dedx
            viry = viry + yr*dedy
            virz = virz + zr*dedz
c
c     increment the total intermolecular energy
c
            if (intermol) then
               einter = einter + e
            end if
         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,3,ia,ib,ic,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 = xab*xab + yab*yab + zab*zab
            rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
            if (rab2.ne.0.0d0 .and. rcb2.ne.0.0d0) then
               xp = ycb*zab - zcb*yab
               yp = zcb*xab - xcb*zab
               zp = xcb*yab - ycb*xab
               rp = sqrt(xp*xp + yp*yp + zp*zp)
               rp = max(rp,0.000001d0)
               dot = xab*xcb + yab*ycb + zab*zcb
               cosine = dot / sqrt(rab2*rcb2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               af1 = afix(1,i)
               af2 = afix(2,i)
               target = angle
               if (angle .lt. af1)  target = af1
               if (angle .gt. af2)  target = af2
               force = afix(3,i)
               dt = angle - target
               dt2 = dt * dt
               e = force * dt2
               deddt = 2.0d0 * force * dt * radian
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 diagonal components
c
               virx = virx + xab*dedxia + xcb*dedxic
               viry = viry + yab*dedyia + ycb*dedyic
               virz = virz + zab*dedzia + zcb*dedzic
c
c     increment the total intermolecular energy
c
               if (intermol) then
                  einter = einter + e
               end if
            end if
         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,4,ia,ib,ic,id,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
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            xt = yba*zcb - ycb*zba
            yt = zba*xcb - zcb*xba
            zt = xba*ycb - xcb*yba
            xu = ycb*zdc - ydc*zcb
            yu = zcb*xdc - zdc*xcb
            zu = xcb*ydc - xdc*ycb
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               if (sine .lt. 0.0d0)  angle = -angle
               tf1 = tfix(1,i)
               tf2 = tfix(2,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
               force = tfix(3,i)
               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
               dt2 = dt * dt
               e = force * dt2
               dedphi = 2.0d0 * radian * 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 diagonal components
c
               virx = virx - xba*dedxia + xdc*dedxid
     &                     + xcb*(dedxic-dedxid)
               viry = viry - yba*dedyia + ydc*dedyid
     &                     + ycb*(dedyic-dedyid)
               virz = virz - zba*dedzia + zdc*dedzid
     &                     + zcb*(dedzic-dedzid)
c
c     increment the total intermolecular energy
c
               if (molcule(ia).ne.molcule(ib) .or.
     &             molcule(ia).ne.molcule(ic) .or.
     &             molcule(ia).ne.molcule(id)) then
                  einter = einter + e
               end if
            end if
         end if
      end do
c
c     get energy and derivatives for a Gaussian basin restraint
c
      if (use_basin) then
         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,2,i,k,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
                  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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
               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,1,i,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 diagonal components
c
               xr = r * xi/ri
               yr = r * yi/ri
               zr = r * zi/ri
               virx = virx + xr*dedx
               viry = viry + yr*dedy
               virz = virz + zr*dedz
            end if
         end do
      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
      subroutine egeom2 (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'group.i'
      include 'hessn.i'
      include 'kgeoms.i'
      include 'math.i'
      include 'molcul.i'
      integer i,j,k
      integer ia,ib,ic,id
      integer ipos,idist
      integer iangle,itors
      real*8 xr,yr,zr,fgrp
      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 xrab,yrab,zrab
      real*8 xrcb,yrcb,zrcb
      real*8 xabp,yabp,zabp
      real*8 xcbp,ycbp,zcbp
      real*8 rab2,rcb2
      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 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 dedr,d2edr2,expterm
      real*8 xi,yi,zi,ri,ri2
      real*8 r,r2,r6,r12
      real*8 a,b,buffer
      logical proceed,intermol
c
c
c     compute the Hessian elements for position restraints
c
      do ipos = 1, npfix
         ia = ipfix(ipos)
         proceed = (i .eq. ia)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,1,ia,0,0,0,0)
         if (proceed) then
            xr = x(ia) - xpfix(ipos)
            yr = y(ia) - ypfix(ipos)
            zr = z(ia) - zpfix(ipos)
            r2 = xr*xr + yr*yr + zr*zr
            r = sqrt(r2)
            dt = max(0.0d0,r-pfix(1,ipos))
            dt2 = dt * dt
            force = pfix(2,ipos)
            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
            if (r .eq. 0.0d0) then
               de = deddt
               term = 0.0d0
            else
               de = deddt * dt/r
               term = (deddt-de) / r2
            end if
            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 non-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     note that the Hessian is discontinuous when an upper and
c     lower bound range is used instead of a single distance
c
      do idist = 1, ndfix
         ia = idfix(1,idist)
         ib = idfix(2,idist)
         proceed = (i.eq.ia .or. i.eq.ib)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,2,ia,ib,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,0)
            r2 = xr*xr + yr*yr + zr*zr
            r = sqrt(r2)
            df1 = dfix(1,idist)
            df2 = dfix(2,idist)
            target = r
            if (r .lt. df1)  target = df1
            if (r .gt. df2)  target = df2
            force = dfix(3,idist)
            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
            if (r .eq. 0.0d0) then
               r = 0.0001d0
               r2 = r * r
            end if
            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 non-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 iangle = 1, nafix
         ia = iafix(1,iangle)
         ib = iafix(2,iangle)
         ic = iafix(3,iangle)
         proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,3,ia,ib,ic,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 = xab*xab + yab*yab + zab*zab
            rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
            if (rab2.ne.0.0d0 .and. rcb2.ne.0.0d0) then
               xp = ycb*zab - zcb*yab
               yp = zcb*xab - xcb*zab
               zp = xcb*yab - ycb*xab
               rp = sqrt(xp*xp + yp*yp + zp*zp)
               rp = max(rp,0.000001d0)
               dot = xab*xcb + yab*ycb + zab*zcb
               cosine = dot / sqrt(rab2*rcb2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               af1 = afix(1,iangle)
               af2 = afix(2,iangle)
               target = angle
               if (angle .lt. af1)  target = af1
               if (angle .gt. af2)  target = af2
               force = afix(3,iangle)
               dt = angle - target
               dt2 = dt * dt
               deddt = 2.0d0 * force * dt * radian
               d2eddt2 = 2.0d0 * force * radian**2
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     first derivatives of bond angle with respect to coordinates
c
               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
            end if
         end if
      end do
c
c     compute the Hessian elements for torsion restraints
c
      do itors = 1, ntfix
         ia = itfix(1,itors)
         ib = itfix(2,itors)
         ic = itfix(3,itors)
         id = itfix(4,itors)
         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,4,ia,ib,ic,id,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
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            xt = yba*zcb - ycb*zba
            yt = zba*xcb - zcb*xba
            zt = xba*ycb - xcb*yba
            xu = ycb*zdc - ydc*zcb
            yu = zcb*xdc - zdc*xcb
            zu = xcb*ydc - xdc*ycb
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               if (sine .lt. 0.0d0)  angle = -angle
c
c     calculate the pseudoenergy master chain rule terms
c
               tf1 = tfix(1,itors)
               tf2 = tfix(2,itors)
               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
               force = tfix(3,itors)
               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
               dedphi = 2.0d0 * radian * force * dt
               d2edphi2 = 2.0d0 * radian**2 * 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 if
      end do
c
c     compute Hessian elements for a Gaussian basin restraint
c
      if (use_basin) then
         xi = x(i)
         yi = y(i)
         zi = z(i)
         do k = 1, n
            proceed = (k .ne. i)
            if (use_group)  call groups (proceed,fgrp,2,i,k,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
               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 non-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,1,i,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 non-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
      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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'kgeoms.i'
      include 'math.i'
      include 'molcul.i'
      include 'usage.i'
      integer i,k
      integer ia,ib,ic,id
      real*8 e,dt,dt2,fgrp
      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 df1,df2
      real*8 af1,af2
      real*8 tf1,tf2,t1,t2
      real*8 xi,yi,zi,ri
      real*8 a,b,buffer,term
      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     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,1,ia,0,0,0,0)
         if (proceed)  proceed = (use(ia))
         if (proceed) then
            xr = x(ia) - xpfix(i)
            yr = y(ia) - ypfix(i)
            zr = z(ia) - zpfix(i)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            dt = max(0.0d0,r-pfix(1,i))
            dt2 = dt * dt
            force = pfix(2,i)
            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',8x,'Atom Name',11x,'Target',
     &                       ' Position',7x,'Distance',6x,'Energy',/)
               end if
               dt = sqrt(dt2)
               write (iout,20)  ia,name(ia),xpfix(i),ypfix(i),
     &                          zpfix(i),dt,e
   20          format (' Position',3x,i5,'-',a3,2x,4f10.4,f12.4)
            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,2,ia,ib,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,0)
            r = sqrt(xr*xr + yr*yr + zr*zr)
            df1 = dfix(1,i)
            df2 = dfix(2,i)
            target = r
            if (r .lt. df1)  target = df1
            if (r .gt. df2)  target = df2
            force = dfix(3,i)
            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,30)
   30             format (/,' Individual Interatomic Distance',
     &                       ' Restraint Terms :',
     &                    //,' Type',13x,'Atom Names',14x,'Ideal Range',
     &                       4x,'Actual',6x,'Energy',/)
               end if
               write (iout,40)  ia,name(ia),ib,name(ib),df1,df2,r,e
   40          format (' Distance',3x,i5,'-',a3,1x,i5,'-',a3,
     &                    6x,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,3,ia,ib,ic,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 = xab*xab + yab*yab + zab*zab
            rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
            if (rab2.ne.0.0d0 .and. rcb2.ne.0.0d0) then
               dot = xab*xcb + yab*ycb + zab*zcb
               cosine = dot / sqrt(rab2*rcb2)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               af1 = afix(1,i)
               af2 = afix(2,i)
               target = angle
               if (angle .lt. af1)  target = af1
               if (angle .gt. af2)  target = af2
               force = afix(3,i)
               dt = angle - target
               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
               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,50)
   50                format (/,' Individual Interatomic Angle',
     &                          ' Restraint Terms :',
     &                       //,' Type',12x,'Atom Numbers',13x,'Ideal',
     &                          ' Range',4x,'Actual',6x,'Energy',/)
                  end if
                  write (iout,60)  ia,ib,ic,af1,af2,angle,e
   60             format (' Angle',8x,3i5,8x,2f8.2,f10.4,f12.4)
               end if
            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,4,ia,ib,ic,id,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
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            xt = yba*zcb - ycb*zba
            yt = zba*xcb - zcb*xba
            zt = xba*ycb - xcb*yba
            xu = ycb*zdc - ydc*zcb
            yu = zcb*xdc - zdc*xcb
            zu = xcb*ydc - xdc*ycb
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
               cosine = min(1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
               if (sine .lt. 0.0d0)  angle = -angle
               tf1 = tfix(1,i)
               tf2 = tfix(2,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
               force = tfix(3,i)
               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
               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,70)
   70                format (/,' Individual Torsional Angle Restraint',
     &                          ' Terms :',
     &                       //,' Type',12x,'Atom Numbers',13x,'Ideal',
     &                          ' Range',4x,'Actual',6x,'Energy',/)
                  end if
                  write (iout,80)  ia,ib,ic,id,tf1,tf2,angle,e
   80             format (' Torsion',4x,4i5,5x,2f8.2,f10.4,f12.4)
               end if
            end if
         end if
      end do
c
c     compute the energy for a Gaussian basin restraint
c
      if (use_basin) then
         header = .true.
         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,2,i,k,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
                  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,90)
   90                   format (/,' Individual Gaussian Basin',
     &                             ' Restraint Terms :',
     &                          //,' Type',13x,'Atom Names',20x,'Ideal',
     &                             4x,'Actual',6x,'Energy',/)
                     end if
                     r = sqrt(r2)
                     write (iout,100)  i,name(i),k,name(k),0.0d0,r,e
  100                format (' Distance',3x,i5,'-',a3,1x,i5,'-',a3,
     &                          12x,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,1,i,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,110)
  110                format (/,' Individual Spherical Boundary',
     &                          ' Restraint Terms :',
     &                       //,' Type',13x,'Atom Name',28x,'Distance',
     &                          6x,'Energy',/)
                  end if
                  write (iout,120)  i,name(i),ri,e
  120             format (' Wall',12x,i5,'-',a3,27x,f10.4,f12.4)
               end if
            end if
         end do
      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
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call ehal0b
      else
         call ehal0a
      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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      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 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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
                  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)
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
      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 = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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
                     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)
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
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ehal0b  --  method of lights Buffered 14-7 vdw  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ehal0a" calculates the buffered 14-7 van der Waals energy
c     using the method of lights to locate neighboring atoms
c
c
      subroutine ehal0b
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'iounit.i'
      include 'light.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      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 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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 (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  rv7 = rv**7
                  rik7 = rik**7
                  rho = rik7 + ghal*rv7
                  tau = dhal / (rik + dhal*rv)
                  e = eps * rv7 * tau**7
     &                   * ((ghal+1.0d0)*rv7/rho-2.0d0)
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
      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 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
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call ehal1b
      else
         call ehal1a
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ehal1a  --  double loop 14-7 vdw derivatives  ##
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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'virial.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      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,tau,tau7
      real*8 dtau,gtau
      real*8 taper,dtaper
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 rik6,rik7
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
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
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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)
                  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)
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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
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     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)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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)
                     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)
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 diagonal components
c
                     virx = virx + xr*dedx
                     viry = viry + yr*dedy
                     virz = virz + zr*dedz
c
c     increment the total intermolecular energy
c
                     einter = einter + e
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ehal1b  --  method of lights 14-7 vdw derivs  ##
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 to locate neighboring atoms
c
c
      subroutine ehal1b
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'iounit.i'
      include 'light.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'virial.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      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,tau,tau7
      real*8 dtau,gtau
      real*8 taper,dtaper
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 rik6,rik7
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
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
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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 (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  rik = sqrt(rik2)
                  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)
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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         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 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,xred,yred,zred)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'group.i'
      include 'hessn.i'
      include 'shunt.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,jcell
      integer ii,kk,iatom
      integer iv,kv,it,kt
      integer nlist,list(5)
      integer iv14(maxatm)
      real*8 e,de,d2e,fgrp
      real*8 eps,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 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed
c
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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     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)
         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
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         do j = 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 = 1, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (k .ne. i)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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)
                  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 non-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
      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)
         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
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         do j = 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 = 1, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               kt = class(k)
               do jcell = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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)
                     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 non-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
      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 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
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call ehal3b
      else
         call ehal3a
      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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      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 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
      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
      header = .true.
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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
                  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)
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
                  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,10)
   10                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',13x,'Atom Names',
     &                             18x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,20)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   20                format (' VDW-Hal',4x,i5,'-',a3,1x,i5,
     &                          '-',a3,12x,2f10.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, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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
                     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)
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,30)
   30                      format (/,' Individual van der Waals',
     &                                ' Interactions :',
     &                             //,' Type',13x,'Atom Names',
     &                                18x,'Minimum',4x,'Actual',
     &                                6x,'Energy',/)
                        end if
                        write (iout,40)  i,name(i),k,name(k),
     &                                   rv,sqrt(rik2),e
   40                   format (' VDW-Hal',4x,i5,'-',a3,1x,i5,'-',
     &                             a3,3x,'(XTAL)',3x,2f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
      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 to locate neighboring atoms
c
c
      subroutine ehal3b
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'light.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      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 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
      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
      header = .true.
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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 40
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 40
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 40
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 40
            end if
            k = ivdw(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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 (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  rv7 = rv**7
                  rik7 = rik**7
                  rho = rik7 + ghal*rv7
                  tau = dhal / (rik + dhal*rv)
                  e = eps * rv7 * tau**7
     &                   * ((ghal+1.0d0)*rv7/rho-2.0d0)
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)  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.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',13x,'Atom Names',
     &                             18x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-Hal',4x,i5,'-',a3,1x,i5,'-',
     &                          a3,12x,2f10.4,f12.4)
                  end if
               end if
            end if
   40       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         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 eimprop  --  improper dihedral energy  ##
c     ##                                                    ##
c     ########################################################
c
c
c     "eimprop" calculates the improper dihedral potential energy
c
c
      subroutine eimprop
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'improp.i'
      include 'math.i'
      include 'torpot.i'
      include 'usage.i'
      integer i,ia,ib,ic,id
      real*8 e,ideal,force
      real*8 dt,cosine,sine
      real*8 rcb,angle,fgrp
      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
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,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the 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,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            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     set the improper dihedral parameters for this angle
c
               ideal = vprop(i)
               force = kprop(i)
               dt = angle - ideal
               dowhile (dt .gt. 180.0d0)
                  dt = dt - 360.0d0
               end do
               dowhile (dt .lt. -180.0d0)
                  dt = dt + 360.0d0
               end do
               dt = dt / radian
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 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 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'improp.i'
      include 'math.i'
      include 'torpot.i'
      include 'usage.i'
      include 'virial.i'
      integer i,ia,ib,ic,id
      real*8 e,dedphi
      real*8 ideal,force
      real*8 dt,cosine,sine
      real*8 rcb,angle,fgrp
      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
      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
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,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the 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,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            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     set the improper dihedral parameters for this angle
c
               ideal = vprop(i)
               force = kprop(i)
               dt = angle - ideal
               dowhile (dt .gt. 180.0d0)
                  dt = dt - 360.0d0
               end do
               dowhile (dt .lt. -180.0d0)
                  dt = dt + 360.0d0
               end do
               dt = dt / radian
c
c     calculate improper energy and master chain rule term
c
               e = idihunit * force * dt**2
               dedphi = 2.0d0 * idihunit * 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
               if (use_polymer) then
                  call image (xca,yca,zca,0)
                  call image (xdb,ydb,zdb,0)
               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 diagonal components
c
               virx = virx - xba*dedxia + xdc*dedxid
     &                     + xcb*(dedxic+dedxid)
               viry = viry - yba*dedyia + ydc*dedyid
     &                     + ycb*(dedyic+dedyid)
               virz = virz - zba*dedzia + zdc*dedzid
     &                     + zcb*(dedzic+dedzid)
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eimprop2  --  atom-wise 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'group.i'
      include 'hessn.i'
      include 'improp.i'
      include 'math.i'
      include 'torpot.i'
      integer i,kiprop
      integer ia,ib,ic,id
      real*8 angle,ideal,force
      real*8 dt,dedphi,d2edphi2
      real*8 sine,cosine,fgrp
      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     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,4,ia,ib,ic,id,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,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            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     set the improper dihedral parameters for this angle
c
               ideal = vprop(kiprop)
               force = kprop(kiprop)
               dt = angle - ideal
               dowhile (dt .gt. 180.0d0)
                  dt = dt - 360.0d0
               end do
               dowhile (dt .lt. -180.0d0)
                  dt = dt + 360.0d0
               end do
               dt = dt / radian
c
c     calculate the improper torsion master chain rule terms
c
               dedphi = 2.0d0 * idihunit * force * dt
               d2edphi2 = 2.0d0 * idihunit * 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
               if (use_polymer) then
                  call image (xca,yca,zca,0)
                  call image (xdb,ydb,zdb,0)
               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 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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'improp.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'torpot.i'
      include 'usage.i'
      integer i,ia,ib,ic,id
      real*8 e,ideal,force
      real*8 dt,cosine,sine
      real*8 rcb,angle,fgrp
      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
      header = .true.
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,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the 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,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            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     set the improper dihedral parameters for this angle
c
               ideal = vprop(i)
               force = kprop(i)
               dt = angle - ideal
               dowhile (dt .gt. 180.0d0)
                  dt = dt - 360.0d0
               end do
               dowhile (dt .lt. -180.0d0)
                  dt = dt + 360.0d0
               end do
               dt = dt / radian
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,10)
   10                format (/,' Individual Improper Dihedral',
     &                          ' Interactions :',
     &                       //,' Type',23x,'Atom Names',20x,'Angle',
     &                          6x,'Energy',/)
                  end if
                  write (iout,20)  ia,name(ia),ib,name(ib),ic,
     &                             name(ic),id,name(id),angle,e
   20             format (' Improper',3x,i5,'-',a3,3(1x,i5,'-',a3),
     &                       2x,f10.4,f12.4)
               end if
            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 eimptor  --  improper torsion energy  ##
c     ##                                                   ##
c     #######################################################
c
c
c     "eimptor" calculates the improper torsion potential energy
c
c
      subroutine eimptor
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'imptor.i'
      include 'torpot.i'
      include 'usage.i'
      integer i,ia,ib,ic,id
      real*8 e,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
c
c     calculate the improper torsional angle energy term
c
      do i = 1, nitors
         ia = iitors(1,i)
         ib = iitors(2,i)
         ic = iitors(3,i)
         id = iitors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the torsional angle
c
         if (proceed) then
            xia = x(ia)
            yia = y(ia)
            zia = z(ia)
            xib = x(ib)
            yib = y(ib)
            zib = z(ib)
            xic = x(ic)
            yic = y(ic)
            zic = z(ic)
            xid = x(id)
            yid = y(id)
            zid = z(id)
            xba = xib - xia
            yba = yib - yia
            zba = zib - zia
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            if (use_polymer) then
               call image (xba,yba,zba,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the improper torsional parameters for this angle
c
               v1 = itors1(1,i)
               c1 = itors1(3,i)
               s1 = itors1(4,i)
               v2 = itors2(1,i)
               c2 = itors2(3,i)
               s2 = itors2(4,i)
               v3 = itors3(1,i)
               c3 = itors3(3,i)
               s3 = itors3(4,i)
c
c     compute the multiple angle trigonometry and the phase terms
c
               cosine2 = cosine*cosine - sine*sine
               sine2 = 2.0d0 * cosine * sine
               cosine3 = cosine*cosine2 - sine*sine2
               sine3 = cosine*sine2 + sine*cosine2
               phi1 = 1.0d0 + (cosine*c1 + sine*s1)
               phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
               phi3 = 1.0d0 + (cosine3*c3 + sine3*s3)
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 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 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'imptor.i'
      include 'torpot.i'
      include 'usage.i'
      include 'virial.i'
      integer i,ia,ib,ic,id
      real*8 e,dedphi
      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
      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
      logical proceed
c
c
c     zero out energy and first derivative components
c
      eit = 0.0d0
      do i = 1, n
         deit(1,i) = 0.0d0
         deit(2,i) = 0.0d0
         deit(3,i) = 0.0d0
      end do
c
c     calculate the improper torsional angle energy term
c
      do i = 1, nitors
         ia = iitors(1,i)
         ib = iitors(2,i)
         ic = iitors(3,i)
         id = iitors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the torsional angle
c
         if (proceed) then
            xia = x(ia)
            yia = y(ia)
            zia = z(ia)
            xib = x(ib)
            yib = y(ib)
            zib = z(ib)
            xic = x(ic)
            yic = y(ic)
            zic = z(ic)
            xid = x(id)
            yid = y(id)
            zid = z(id)
            xba = xib - xia
            yba = yib - yia
            zba = zib - zia
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            if (use_polymer) then
               call image (xba,yba,zba,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the improper torsional parameters for this angle
c
               v1 = itors1(1,i)
               c1 = itors1(3,i)
               s1 = itors1(4,i)
               v2 = itors2(1,i)
               c2 = itors2(3,i)
               s2 = itors2(4,i)
               v3 = itors3(1,i)
               c3 = itors3(3,i)
               s3 = itors3(4,i)
c
c     compute the multiple angle trigonometry and the phase terms
c
               cosine2 = cosine*cosine - sine*sine
               sine2 = 2.0d0 * cosine * sine
               cosine3 = cosine*cosine2 - sine*sine2
               sine3 = cosine*sine2 + sine*cosine2
               phi1 = 1.0d0 + (cosine*c1 + sine*s1)
               phi2 = 1.0d0 + (cosine2*c2 + sine2*s2)
               phi3 = 1.0d0 + (cosine3*c3 + sine3*s3)
               dphi1 = (cosine*s1 - sine*c1)
               dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2)
               dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3)
c
c     calculate improper torsion energy and master chain rule term
c
               e = 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,0)
                  call image (xdb,ydb,zdb,0)
               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 diagonal components
c
               virx = virx - xba*dedxia + xdc*dedxid
     &                     + xcb*(dedxic+dedxid)
               viry = viry - yba*dedyia + ydc*dedyid
     &                     + ycb*(dedyic+dedyid)
               virz = virz - zba*dedzia + zdc*dedzid
     &                     + zcb*(dedzic+dedzid)
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eimptor2  --  atom-wise 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'group.i'
      include 'hessn.i'
      include 'imptor.i'
      include 'torpot.i'
      integer i,kitors
      integer ia,ib,ic,id
      real*8 dedphi,d2edphi2
      real*8 rcb,fgrp
      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     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,4,ia,ib,ic,id,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,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the improper torsional parameters for this angle
c
               v1 = itors1(1,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,0)
                  call image (xdb,ydb,zdb,0)
               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 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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'imptor.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'torpot.i'
      include 'usage.i'
      integer i,ia,ib,ic,id
      real*8 e,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
      header = .true.
c
c     calculate the improper torsional angle energy term
c
      do i = 1, nitors
         ia = iitors(1,i)
         ib = iitors(2,i)
         ic = iitors(3,i)
         id = iitors(4,i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the torsional angle
c
         if (proceed) then
            xia = x(ia)
            yia = y(ia)
            zia = z(ia)
            xib = x(ib)
            yib = y(ib)
            zib = z(ib)
            xic = x(ic)
            yic = y(ic)
            zic = z(ic)
            xid = x(id)
            yid = y(id)
            zid = z(id)
            xba = xib - xia
            yba = yib - yia
            zba = zib - zia
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            if (use_polymer) then
               call image (xba,yba,zba,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            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     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,10)
   10                format (/,' Individual Improper Torsion',
     &                          ' Interactions :',
     &                       //,' Type',23x,'Atom Names',20x,'Angle',
     &                          6x,'Energy',/)
                  end if
                  write (iout,20)  ia,name(ia),ib,name(ib),ic,
     &                             name(ic),id,name(id),angle,e
   20             format (' Improper',3x,i5,'-',a3,3(1x,i5,'-',a3),
     &                       2x,f10.4,f12.4)
               end if
            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 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
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call elj0b
      else
         call elj0a
      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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      real*8 e,p6,p12,eps
      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 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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)
                  p6 = rv**6 / rik2**3
                  p12 = p6 * p6
                  e = eps * (p12 - 2.0d0*p6)
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
      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 = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
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
      end do
      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 to locate neighboring atoms
c
c
      subroutine elj0b
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'iounit.i'
      include 'light.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      real*8 e,p6,p12,eps
      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 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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 (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  p6 = rv**6 / rik2**3
                  p12 = p6 * p6
                  e = eps * (p12 - 2.0d0*p6)
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
      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 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
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call elj1b
      else
         call elj1a
      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 with respect to Cartesian coordinates
c     using a pairwise double loop
c
c
      subroutine elj1a
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'virial.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      real*8 e,p6,p12,eps
      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,de
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 taper,dtaper
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
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
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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
                  e = eps * (p12 - 2.0d0*p6)
                  de = eps * (p12 - p6) * (-12.0d0/rik)
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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
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     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)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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)
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
                     de = eps * (p12 - p6) * (-12.0d0/rik)
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 diagonal components
c
                     virx = virx + xr*dedx
                     viry = viry + yr*dedy
                     virz = virz + zr*dedz
c
c     increment the total intermolecular energy
c
                     einter = einter + e
                  end if
               end do
            end if
         end do
      end do
      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 with respect to Cartesian coordinates
c     using the method of lights to locate neighboring atoms
c
c
      subroutine elj1b
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'iounit.i'
      include 'light.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'virial.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      real*8 e,p6,p12,eps
      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,de
      real*8 rik,rik2,rik3
      real*8 rik4,rik5
      real*8 taper,dtaper
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
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
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
         map(i) = i
         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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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 (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
                  e = eps * (p12 - 2.0d0*p6)
                  de = eps * (p12 - p6) * (-12.0d0/rik)
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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         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 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 (iatom,xred,yred,zred)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'group.i'
      include 'hessn.i'
      include 'shunt.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,iatom
      integer ii,kk,jcell
      integer iv,kv,it,kt
      integer nlist,list(5)
      integer iv14(maxatm)
      real*8 e,de,d2e,fgrp
      real*8 p6,p12,eps,rv
      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 term(3,3)
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed
c
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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     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)
         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
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         do j = 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 = 1, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (k .ne. i)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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 non-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
      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)
         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
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         do j = 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 = 1, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               kt = class(k)
               do jcell = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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 non-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
      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 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
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call elj3b
      else
         call elj3a
      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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer iv14(maxatm)
      real*8 e,p6,p12,eps
      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 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
      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
      header = .true.
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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)
                  p6 = rv**6 / rik2**3
                  p12 = p6 * p6
                  e = eps * (p12 - 2.0d0*p6)
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
                  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,10)
   10                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',13x,'Atom Names',
     &                             18x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,20)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   20                format (' VDW-LJ',5x,i5,'-',a3,1x,i5,
     &                          '-',a3,12x,2f10.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, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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
                     p6 = rv**6 / rik2**3
                     p12 = p6 * p6
                     e = eps * (p12 - 2.0d0*p6)
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)  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
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,30)
   30                      format (/,' Individual van der Waals',
     &                                ' Interactions :',
     &                             //,' Type',13x,'Atom Names',
     &                                18x,'Minimum',4x,'Actual',
     &                                6x,'Energy',/)
                        end if
                        write (iout,40)  i,name(i),k,name(k),
     &                                   rv,sqrt(rik2),e
   40                   format (' VDW-LJ',5x,i5,'-',a3,1x,i5,'-',a3,
     &                             3x,'(XTAL)',3x,2f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
      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 energy
c     and also partitions the energy among the atoms using the method
c     of lights to locate neighboring atoms
c
c
      subroutine elj3b
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'light.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      real*8 e,p6,p12,eps
      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 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
      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
      header = .true.
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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 40
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 40
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 40
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 40
            end if
            k = ivdw(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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 (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
                  p6 = rv**6 / rik2**3
                  p12 = p6 * p6
                  e = eps * (p12 - 2.0d0*p6)
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)  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.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',13x,'Atom Names',
     &                             18x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-LJ',5x,i5,'-',a3,1x,i5,'-',
     &                          a3,12x,2f10.4,f12.4)
                  end if
               end if
            end if
   40       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         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     ##  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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'minima.i'
      include 'refer.i'
      integer maxeigen
      parameter (maxeigen=5)
      integer i,j,nstep,lext
      integer igeo,freeunit
      integer maxneg,nneg
      integer maxinner,ninner
      integer maxouter,nouter
      real*8 fctval,grdmin,secs
      real*8 dt,temp_start,temp_stop
      real*8 rg,rmsorig,rmsflip,mass
      real*8 bounds,contact,local
      real*8 chiral,torsion
      real*8 bnderr,vdwerr,locerr
      real*8 chirer,torser
      real*8 derivs(3,maxgeo)
      real*8 matrix(maxgeo,maxgeo)
      real*8 evl(maxeigen)
      real*8 evc(maxgeo,maxeigen)
      real*8 v(maxvar),a(maxvar)
      logical done,valid,exist,info
      character*7 errtyp,ext
      character*60 title,geofile
c
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,maxgeo,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,maxgeo,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.
      dowhile (.not. valid)
         ninner = 0
         done = .false.
         dowhile (.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,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,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,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.
         dowhile (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
            bnd(j,i) = bnd(j,i)**2
         end do
      end do
c
c     minimize the error function via simulated annealing
c
      if (verbose)  call setime
      if (use_anneal) then
         iprint = 0
         if (verbose)  iprint = 10
         grdmin = 1.0d0
         mass = 10000.0d0
         do i = 1, 3*n
            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 getime (secs)
         write (iout,40)  secs
   40    format (/,' Time Required for Refinement :',10x,f12.2,
     &              ' seconds')
      end if
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
            bnd(j,i) = sqrt(bnd(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
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'inform.i'
      include 'iounit.i'
      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
         vchir(i) = xad*c1 + xbd*c2 + xcd*c3
         if (abs(vchir(i)) .lt. 1.0d0)  vchir(i) = 0.0d0
      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),vchir(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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'iounit.i'
      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 = bnd(ik2,ik1)
            uik = bnd(ik1,ik2)
            do j = i+1, n
               lij = bnd(j,i)
               uij = bnd(i,j)
               jk1 = min(j,k)
               jk2 = max(j,k)
               ljk = bnd(jk2,jk1)
               ujk = bnd(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-bnd(j,i) .gt. eps) then
                  write (iout,40)  i,j,bnd(j,i),lij
   40             format (' TRIANGLE  --  Altered Lower Bound at',
     &                       2x,2i6,3x,f9.4,' -->',f9.4)
               end if
               if (bnd(i,j)-uij .gt. eps) then
                  write (iout,50)  i,j,bnd(i,j),uij
   50             format (' TRIANGLE  --  Altered Upper Bound at',
     &                       2x,2i6,3x,f9.4,' -->',f9.4)
               end if
               bnd(j,i) = lij
               bnd(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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'kgeoms.i'
      integer maxlist
      parameter (maxlist=2*maxfix)
      integer i,j,k,nlist
      integer start(maxatm),stop(maxatm)
      integer list(maxlist),key(maxlist)
      real*8 upper(maxatm),lower(maxatm)
c
c
c     build an indexed list of atoms in distance restraints
c
      do i = 1, n
         start(i) = 0
         stop(i) = -1
      end do
      nlist = 2 * ndfix
      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
            bnd(i,j) = upper(j)
            bnd(j,i) = max(lower(j),bnd(j,i))
         end do
      end do
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'disgeo.i'
      integer maxlist
      parameter (maxlist=2*maxfix)
      integer i,j,k,root
      integer narc,iarc(maxatm)
      integer head,tail,queue(maxatm)
      integer start(maxatm),stop(maxatm)
      integer list(maxlist)
      real*8 big,upper(maxatm)
      real*8 small,lower(maxatm)
      logical enter,queued(maxatm)
c
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
      dowhile (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) + bnd(k,j)
               small = max(bnd(j,k)-upper(j),lower(j)-bnd(k,j))
            else
               big = upper(j) + bnd(j,k)
               small = max(bnd(k,j)-upper(j),lower(j)-bnd(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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'inform.i'
      include 'iounit.i'
      integer i,k,p,q,ip,iq,np,nq
      integer pt(maxgeo),qt(maxgeo)
      real*8 eps,ipmin,ipmax,iqmin,iqmax
      real*8 pmin(maxgeo),pmax(maxgeo)
      real*8 qmin(maxgeo),qmax(maxgeo)
      logical pun(maxgeo),qun(maxgeo)
c
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) = bnd(p,i)
         pmax(i) = bnd(i,p)
      end do
      do i = p+1, n
         pmin(i) = bnd(i,p)
         pmax(i) = bnd(p,i)
      end do
      do i = 1, q
         qmin(i) = bnd(q,i)
         qmax(i) = bnd(i,q)
      end do
      do i = q+1, n
         qmin(i) = bnd(i,q)
         qmax(i) = bnd(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
               bnd(i,k) = min(bnd(i,k),ipmax+pmax(k))
            else
               bnd(k,i) = min(bnd(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
               bnd(k,i) = max(bnd(k,i),ipmin-pmax(k),pmin(k)-ipmax)
            else
               bnd(i,k) = max(bnd(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
         bnd(p,i) = pmin(i)
         bnd(i,p) = pmax(i)
      end do
      do i = p+1, n
         bnd(i,p) = pmin(i)
         bnd(p,i) = pmax(i)
      end do
      do i = 1, q
         bnd(q,i) = qmin(i)
         bnd(i,q) = qmax(i)
      end do
      do i = q+1, n
         bnd(i,q) = qmin(i)
         bnd(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
      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,np,a,title)
      implicit none
      include 'iounit.i'
      integer i,j,k,m,n,np
      integer maxj,nrow,ndash
      integer minrow,maxrow
      real*8 a(np,np),big
      real*8 amin,dmin,bmin
      real*8 amax,dmax,bmax
      real*8 v,rcl,scl,tcl
      real*8 ca,cb,cc,cd
      real*8 cw,cx,cy,cz
      character*1 ta,tb,tc,td,te
      character*1 dash,digit(0:9)
      character*1 symbol(130)
      character*60 title
      data ta,tb,tc,td,te  / ' ','.','+','X','#' /
      data dash   / '-' /
      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
   20 format (/,1x,a60)
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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kgeoms.i'
      integer maxpair
      parameter (maxpair=maxgeo*(maxgeo-1)/2)
      integer i,j,k,m,index,next
      integer npart,nmetrize,npair
      integer mik,mjk,nik,njk
      integer list(maxpair)
      real*8 random,fraction
      real*8 invbeta,alpha,beta
      real*8 corr,mean,stdev
      real*8 denom,swap,delta
      real*8 percent,eps,gap,secs
      real*8 value(maxpair)
      real*8 dmx(maxgeo,maxgeo)
      logical initial,uniform
      logical update
      character*8 method
      character*20 keyword
      character*80 record,string
      save initial,method,update
      save npart,percent,alpha,beta
      data initial  / .true. /
c
c
c     initialize the method for distance element selection
c
      if (initial) then
         initial = .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 lowcase (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:80)
                  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:80)
               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 setime
         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     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 = bnd(i,j) - bnd(j,i)
               dmx(j,i) = bnd(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 (bnd(njk,mjk) .le. 0.2d0*bnd(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 (bnd(nik,mik) .le. 0.2d0*bnd(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 (bnd(mik,nik) .ge. 0.9d0*bnd(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 (bnd(mjk,njk) .ge. 0.9d0*bnd(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 = bnd(i,j) - bnd(j,i)
               dmx(i,j) = bnd(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) = bnd(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(bnd(k,m) - bnd(m,k))
               if (k .lt. m) then
                  bnd(k,m) = bnd(m,k) + delta*fraction
                  bnd(m,k) = bnd(k,m)
               else
                  bnd(k,m) = bnd(k,m) + delta*fraction
                  bnd(m,k) = bnd(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) = bnd(j,i)
               bnd(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) = bnd(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 (bnd(k,m) .eq. bnd(m,k))  goto 140
            if (k .gt. m) then
               swap = k
               k = m
               m = swap
            end if
            fraction = random ()
            fraction = invbeta (alpha,beta,fraction)
            delta = bnd(k,m) - bnd(m,k)
            bnd(k,m) = bnd(m,k) + delta*fraction
            bnd(m,k) = bnd(k,m)
            call trifix (k,m)
         end do
         gap = 0.0d0
         do i = 1, n-1
            do j = i, n
               delta = bnd(i,j) - bnd(j,i)
               if (delta .ne. 0.0d0) then
                  gap = gap + delta
                  fraction = random ()
                  fraction = invbeta (alpha,beta,fraction)
                  bnd(i,j) = bnd(j,i) + delta*fraction
                  bnd(j,i) = bnd(i,j)
               end if
            end do
         end do
         do i = 1, n
            do j = 1, n
               swap = dmx(j,i)
               dmx(j,i) = bnd(j,i)
               bnd(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) = bnd(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 = bnd(k,m) - bnd(m,k)
            bnd(k,m) = bnd(m,k) + delta*fraction
            bnd(m,k) = bnd(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) = bnd(j,i)
               bnd(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     get the time required for distance matrix generation
c
      if (verbose) then
         call getime (secs)
         write (iout,170)  secs
  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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'inform.i'
      include 'iounit.i'
      integer i,j,nneg
      real*8 total,sum,rg
      real*8 dsq(maxgeo)
      real*8 dcm(maxgeo)
      real*8 gmx(maxgeo,maxgeo)
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     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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      integer maxeigen
      parameter (maxeigen=5)
      integer i,j,neigen
      real*8 evl(maxeigen)
      real*8 evc(maxgeo,maxeigen)
      real*8 gmx(maxgeo,maxgeo)
      real*8 secs,work(maxgeo)
      logical valid
c
c
c     initialize number of eigenvalues and convergence criteria
c
      if (verbose)  call setime
      neigen = 3
c
c     compute the largest few eigenvalues via the power method
c
      call power (n,maxgeo,neigen,gmx,evl,evc,work)
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 getime (secs)
         write (iout,50)  secs
   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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'inform.i'
      include 'iounit.i'
      integer maxeigen
      parameter (maxeigen=5)
      integer i,j,neigen
      real*8 rg,evl(maxeigen)
      real*8 evc(maxgeo,maxeigen)
      character*60 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'disgeo.i'
      include 'inform.i'
      include 'iounit.i'
      integer i,k,npair,nskip
      integer nlarge,nsmall
      integer skip(maxatm)
      real*8 xi,yi,zi
      real*8 dstsq,bupsq,blosq
c
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 = bnd(i,k)**2
               blosq = bnd(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     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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      integer i,k,iter,niter,period
      real*8 pairs,dn1,dn2,rg,secs
      real*8 target,dist,error
      real*8 rmserr,average
      real*8 xi,yi,zi,b(maxatm)
      real*8 dmx(maxgeo,maxgeo)
      real*8 xx(maxatm),yy(maxatm),zz(maxatm)
      character*60 title
c
c
c     set number of iterations and some other needed values
c
      if (verbose)  call setime
      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     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     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 getime (secs)
         write (iout,50)  secs
   50    format (/,' Time Required for Majorization :',8x,f12.2,
     &              ' seconds')
      end if
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'inform.i'
      include 'iounit.i'
      include 'minima.i'
      include 'output.i'
      integer i,nvar
      real*8 initerr,miderr,toterr
      real*8 fctval,grdmin
      real*8 xx(maxvar)
      character*7 mode
      external initerr,miderr
      external toterr,writeout
c
c
c     translate the atomic coordinates to optimization 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     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,writeout)
      else if (mode .eq. 'middle') then
         call lbfgs (nvar,xx,fctval,grdmin,miderr,writeout)
      else if (mode .eq. 'final') then
         call lbfgs (nvar,xx,fctval,grdmin,toterr,writeout)
      end if
c
c     translate optimization variables back to 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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'units.i'
      integer i,istep,nstep,nvar,period
      real*8 error,total,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 xx(maxvar),xmove(maxvar)
      real*8 g(maxvar),v(maxvar),a(maxvar)
      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     translate the 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 / convert
      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) = -convert * 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 / convert
         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     translate annealing variables back to 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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'iounit.i'
      integer start,stop
      parameter (start=-20)
      parameter (stop=120)
      integer i,j,k,sum
      integer leng,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*60 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 = bnd(i,j) - bnd(j,i)
            if (range .ge. 1.0d0) then
               fraction = (dist-bnd(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
      leng = trimtext(title)
      write (iout,10)  title(1:leng)
   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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'iounit.i'
      include 'kgeoms.i'
      integer i,j,k,npair
      integer nhierr,nloerr
      integer ihi,jhi,ilo,jlo
      integer leng,trimtext
      real*8 rms,himax,lomax
      real*8 dist,hierr,loerr
      character*60 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 - bnd(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 = bnd(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
      leng = trimtext(title)
      write (iout,10)  title(1:leng)
   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(1,k)) then
               nloerr = nloerr + 1
               loerr = dfix(1,k) - dist
               rms = rms + (dist-dfix(1,k))**2
               if (loerr .gt. lomax) then
                  lomax = loerr
                  ilo = i
                  jlo = j
               end if
            else if (dist .gt. dfix(2,k)) then
               nhierr = nhierr + 1
               hierr = dist - dfix(2,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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      include 'iounit.i'
      integer i,j
      real*8 sum,dist,dist2,rgsq
      real*8 dmd(maxgeo,maxgeo)
      character*60 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. bnd(i,j)) then
               dmd(j,i) = dist - bnd(i,j)
            else if (dist .lt. bnd(j,i)) then
               dmd(j,i) = bnd(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,maxgeo,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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,j,nvar
      real*8 initerr,local,torsion
      real*8 locerr,torser
      real*8 xx(maxvar),g(maxvar)
      real*8 derivs(3,maxgeo)
      external locerr,torser
c
c
c     translate 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     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 goemetry 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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,j,nvar
      real*8 miderr,bounds,local
      real*8 chiral,torsion
      real*8 bnderr,locerr
      real*8 chirer,torser
      real*8 xx(maxvar),g(maxvar)
      real*8 derivs(3,maxgeo)
c
c
c     translate 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     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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,j,nvar
      real*8 toterr,bounds,contact
      real*8 local,chiral,torsion
      real*8 bnderr,vdwerr,locerr
      real*8 chirer,torser
      real*8 xx(maxvar),g(maxvar)
      real*8 derivs(3,maxgeo)
      external bnderr,vdwerr
      external chirer,torser
c
c
c     translate 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     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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'kgeoms.i'
      integer i,j,k
      real*8 bnderr,error,cutsq
      real*8 scale,chain,term
      real*8 gap,buffer,weight
      real*8 dx,dy,dz,gx,gy,gz
      real*8 dstsq,bupsq,blosq
      real*8 derivs(3,maxgeo)
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(2,k) - dfix(1,k)
         buffer = 0.05d0 * min(1.0d0,gap)
         blosq = (dfix(1,k) + buffer)**2
         bupsq = (dfix(2,k) - buffer)**2
c
c     error and derivatives for upper bound violation
c
         if (dstsq .gt. bupsq) then
            weight = scale * dfix(3,k)
            term = (dstsq-bupsq) / bupsq
            chain = 4.0d0 * weight * term / bupsq
            error = weight * 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
            weight = scale * dfix(3,k)
            if (blosq .gt. cutsq) then
               term = (blosq-dstsq) / dstsq
               chain = -4.0d0 * weight * term * (blosq/dstsq**2)
            else
               term = (blosq-dstsq) / (blosq+dstsq)
               chain = -8.0d0 * weight * term * (blosq/(blosq+dstsq)**2)
            end if
            error = weight * 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'disgeo.i'
      include 'light.i'
      include 'shunt.i'
      integer i,j,k,kgy,kgz
      integer skip(maxgeo)
      integer map(maxlight)
      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 derivs(3,maxgeo)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
c
c
c     zero out the distance van der Waals error function
c
      vdwerr = 0.0d0
      scale = 1.0d0
c
c     set maximum value of vdw radii sum for a pair of atoms
c
      off = vdwmax
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
      call lights (n,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do i = 1, n
         radi = vdwrad(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 + vdwrad(k))**2
            blosq = min(bnd(k,i),bnd(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
      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)
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atoms.i'
      include 'bond.i'
      include 'disgeo.i'
      include 'tors.i'
      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,maxgeo)
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 = bnd(ia,ib)
         blosq = bnd(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 = bnd(ia,ic)
         blosq = bnd(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 = bnd(ia,id)
         blosq = bnd(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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'disgeo.i'
      integer i,ia,ib,ic,id
      real*8 chirer,error,scale
      real*8 vol,dv,dedv
      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,maxgeo)
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
         dv = vol - vchir(i)
         error = scale * dv**2
         dedv = 2.0d0 * scale * dv
c
c     chain rule terms for first derivative components
c
         dedxia = dedv * (ybd*zcd - zbd*ycd)
         dedyia = dedv * (zbd*xcd - xbd*zcd)
         dedzia = dedv * (xbd*ycd - ybd*xcd)
         dedxib = dedv * (zad*ycd - yad*zcd)
         dedyib = dedv * (xad*zcd - zad*xcd)
         dedzib = dedv * (yad*xcd - xad*ycd)
         dedxic = dedv * (yad*zbd - zad*ybd)
         dedyic = dedv * (zad*xbd - xad*zbd)
         dedzic = dedv * (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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'disgeo.i'
      include 'kgeoms.i'
      include 'math.i'
      include 'refer.i'
      integer i,j,k,ia,ib,ic,id
      real*8 torser,derivs(3,maxgeo)
      real*8 error,dt,deddt,dedphi
      real*8 angle,target,scale
      real*8 xia,yia,zia,xib,yib,zib
      real*8 xic,yic,zic,xid,yid,zid
      real*8 xria,yria,zria,xrib,yrib,zrib
      real*8 xric,yric,zric,xrid,yrid,zrid
      real*8 rba,rcb,rdc,dot,cosine,sine
      real*8 rrba,rrcb,rrdc,rrca,rrdb
      real*8 bndfac,angfac
      real*8 xp,yp,zp,rp
      real*8 terma,termb,termc,termd
      real*8 angmax,angmin,cosmax,cosmin
      real*8 bamax,bamin,cbmax,cbmin,dcmax,dcmin
      real*8 camax,camin,dbmax,dbmin
      real*8 xba,yba,zba,xcb,ycb,zcb,xdc,ydc,zdc
      real*8 xca,yca,zca,xdb,ydb,zdb
      real*8 xt,yt,zt,rt2,xu,yu,zu,ru2
      real*8 xtu,ytu,ztu,rtru
      real*8 tf1,tf2,tf3,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
      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(bnd(min(ib,ia),max(ib,ia)))
            bamin = sqrt(bnd(max(ib,ia),min(ib,ia)))
            cbmax = sqrt(bnd(min(ic,ib),max(ic,ib)))
            cbmin = sqrt(bnd(max(ic,ib),min(ic,ib)))
            dcmax = sqrt(bnd(min(id,ic),max(id,ic)))
            dcmin = sqrt(bnd(max(id,ic),min(id,ic)))
            camax = sqrt(bnd(min(ic,ia),max(ic,ia)))
            camin = sqrt(bnd(max(ic,ia),min(ic,ia)))
            dbmax = sqrt(bnd(min(id,ib),max(id,ib)))
            dbmin = sqrt(bnd(max(id,ib),min(id,ib)))
c
c     get maximum and minimum distances from input structure
c
         else
            xria = xref(ia)
            yria = yref(ia)
            zria = zref(ia)
            xrib = xref(ib)
            yrib = yref(ib)
            zrib = zref(ib)
            xric = xref(ic)
            yric = yref(ic)
            zric = zref(ic)
            xrid = xref(id)
            yrid = yref(id)
            zrid = zref(id)
            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
            tf1 = tfix(1,i)
            tf2 = tfix(2,i)
            tf3 = 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 * tf3 * dt**2
            dedphi = 2.0d0 * radian * scale * tf3 * 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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'energi.i'
      include 'kchrge.i'
      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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'kchrge.i'
      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 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),demet(3)
      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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'energi.i'
      include 'kchrge.i'
      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 reference:
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
      subroutine emm3hb
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call emm3hb0b
      else
         call emm3hb0a
      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
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer ia,ib,ic
      integer iv,kv,it,kt
      integer iv14(maxatm)
      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 xp,yp,zp,rp
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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
                     rab2 = xab*xab + yab*yab + zab*zab
                     rab = sqrt(rab2)
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     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
      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 = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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
                        rab2 = xab*xab + yab*yab + zab*zab
                        rab = sqrt(rab2)
                        xcb = xic - xib
                        ycb = yic - yib
                        zcb = zic - zib
                        rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                        xp = ycb*zab - zcb*yab
                        yp = zcb*xab - xcb*zab
                        zp = xcb*yab - ycb*xab
                        rp = sqrt(xp*xp + yp*yp + zp*zp)
                        dot = xab*xcb + yab*ycb + zab*zcb
                        cosine = dot / sqrt(rab2*rcb2)
                        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
      end do
      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 to locate neighboring atoms
c
c
      subroutine emm3hb0b
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'iounit.i'
      include 'light.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer ia,ib,ic
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      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 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8 xp,yp,zp,rp
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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) 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
                        xab = xred(ii) - x(ib)
                        yab = yred(ii) - y(ib)
                        zab = zred(ii) - z(ib)
                        xcb = xab - xr
                        ycb = yab - yr
                        zcb = zab - zr
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                        xab = xred(kk) - x(ib)
                        yab = yred(kk) - y(ib)
                        zab = zred(kk) - z(ib)
                        xcb = xab + xr
                        ycb = yab + yr
                        zcb = zab + zr
                     end if
                     if (ired(ia) .ne. ia) then
                        xab = xab / kred(ia)
                        yab = yab / kred(ia)
                        zab = zab / kred(ia)
                     end if
                     rab2 = xab*xab + yab*yab + zab*zab
                     rab = sqrt(rab2)
                     rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     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
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
      end do
      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 reference:
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
      subroutine emm3hb1
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call emm3hb1b
      else
         call emm3hb1a
      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
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'virial.i'
      integer i,j,k,ii,kk
      integer ia,ib,ic
      integer iv,kv,it,kt
      integer iv14(maxatm)
      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
      real*8 taper,dtaper,rvterm
      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 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse,use_hb
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
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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
                     rab2 = xab*xab + yab*yab + zab*zab
                     rab = sqrt(rab2)
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     sine = sqrt(abs(1.0d0-cosine**2))
                     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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
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     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)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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
                        rab2 = xab*xab + yab*yab + zab*zab
                        rab = sqrt(rab2)
                        xcb = xic - xib
                        ycb = yic - yib
                        zcb = zic - zib
                        rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                        xp = ycb*zab - zcb*yab
                        yp = zcb*xab - xcb*zab
                        zp = xcb*yab - ycb*xab
                        rp = sqrt(xp*xp + yp*yp + zp*zp)
                        dot = xab*xcb + yab*ycb + zab*zcb
                        cosine = dot / sqrt(rab2*rcb2)
                        sine = sqrt(abs(1.0d0-cosine**2))
                        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 diagonal components
c
                     virx = virx + xr*dedx
                     viry = viry + yr*dedy
                     virz = virz + zr*dedz
c
c     increment the total intermolecular energy
c
                     einter = einter + e
                  end if
               end do
            end if
         end do
      end do
      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 to locate neighboring atoms
c
c
      subroutine emm3hb1b
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'iounit.i'
      include 'light.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      include 'virial.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer ia,ib,ic
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      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
      real*8 taper,dtaper,rvterm
      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 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 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse
      logical repeat,use_hb
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
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         redi = kred(i)
         rediv = 1.0d0 - redi
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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) 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
                        xab = xred(ii) - x(ib)
                        yab = yred(ii) - y(ib)
                        zab = zred(ii) - z(ib)
                        xcb = xab - xr
                        ycb = yab - yr
                        zcb = zab - zr
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                        xab = xred(kk) - x(ib)
                        yab = yred(kk) - y(ib)
                        zab = zred(kk) - z(ib)
                        xcb = xab + xr
                        ycb = yab + yr
                        zcb = zab + zr
                     end if
                     if (ired(ia) .ne. ia) then
                        xab = xab / kred(ia)
                        yab = yab / kred(ia)
                        zab = zab / kred(ia)
                     end if
                     rab2 = xab*xab + yab*yab + zab*zab
                     rab = sqrt(rab2)
                     rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     sine = sqrt(abs(1.0d0-cosine**2))
                     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*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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
c
c     increment the total intermolecular energy
c
                  if (molcule(i) .ne. molcule(k)) then
                     einter = einter + e
                  end if
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1998  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine emm3hb2  --  atom-wise 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 reference:
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
      subroutine emm3hb2 (iatom,xred,yred,zred)
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'group.i'
      include 'hessn.i'
      include 'shunt.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,jcell
      integer ii,kk,iatom
      integer ia,ib,ic
      integer iv,kv,it,kt
      integer nlist,list(5)
      integer iv14(maxatm)
      real*8 e,de,d2e
      real*8 eps,rv,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 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 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,use_hb
c
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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     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)
         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
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         do j = 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 = 1, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (k .ne. i)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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
                     rab2 = xab*xab + yab*yab + zab*zab
                     rab = sqrt(rab2)
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     sine = sqrt(abs(1.0d0-cosine**2))
                     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
                     use_hb = .false.
                     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 non-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
      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)
         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
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         do j = 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 = 1, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
c
c     compute the Hessian elements for this interaction
c
            if (proceed) then
               kt = class(k)
               do jcell = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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
                     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
                        rab2 = xab*xab + yab*yab + zab*zab
                        rab = sqrt(rab2)
                        xcb = xic - xib
                        ycb = yic - yib
                        zcb = zic - zib
                        rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                        xp = ycb*zab - zcb*yab
                        yp = zcb*xab - xcb*zab
                        zp = xcb*yab - ycb*xab
                        rp = sqrt(xp*xp + yp*yp + zp*zp)
                        dot = xab*xcb + yab*ycb + zab*zcb
                        cosine = dot / sqrt(rab2*rcb2)
                        sine = sqrt(abs(1.0d0-cosine**2))
                        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
                              use_hb = .false.
                              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
                        use_hb = .false.
                        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 non-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
      end do
      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 reference:
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
      subroutine emm3hb3
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or method of lights version
c
      if (use_lights) then
         call emm3hb3b
      else
         call emm3hb3a
      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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer ia,ib,ic
      integer iv,kv,it,kt
      integer iv14(maxatm)
      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 xp,yp,zp,rp
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      logical proceed,iuse
      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
      header = .true.
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (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)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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
               kt = class(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               if (use_image)  call image (xr,yr,zr,0)
               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
                     rab2 = xab*xab + yab*yab + zab*zab
                     rab = sqrt(rab2)
                     xcb = xic - xib
                     ycb = yic - yib
                     zcb = zic - zib
                     rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     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
                  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,10)
   10                   format (/,' Individual van der Waals',
     &                             ' Interactions :',
     &                          //,' Type',13x,'Atom Names',
     &                             18x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,20)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   20                format (' VDW-MM3',4x,i5,'-',a3,1x,i5,
     &                          '-',a3,12x,2f10.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, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         iuse = (use(i) .or. use(iv))
         do j = ii, 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, nvdw
            k = ivdw(kk)
            kv = ired(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call image (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
                        rab2 = xab*xab + yab*yab + zab*zab
                        rab = sqrt(rab2)
                        xcb = xic - xib
                        ycb = yic - yib
                        zcb = zic - zib
                        rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                        xp = ycb*zab - zcb*yab
                        yp = zcb*xab - xcb*zab
                        zp = xcb*yab - ycb*xab
                        rp = sqrt(xp*xp + yp*yp + zp*zp)
                        dot = xab*xcb + yab*ycb + zab*zcb
                        cosine = dot / sqrt(rab2*rcb2)
                        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,30)
   30                      format (/,' Individual van der Waals',
     &                                ' Interactions :',
     &                             //,' Type',13x,'Atom Names',
     &                                18x,'Minimum',4x,'Actual',
     &                                6x,'Energy',/)
                        end if
                        write (iout,40)  i,name(i),k,name(k),
     &                                   rv,sqrt(rik2),e
   40                   format (' VDW-MM3',4x,i5,'-',a3,1x,i5,'-',
     &                             a3,3x,'(XTAL)',3x,2f10.4,f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
      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 to locate neighboring atoms
c
c
      subroutine emm3hb3b
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'light.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,ii,kk
      integer iv,kv,it,kt
      integer ia,ib,ic
      integer kgy,kgz
      integer start,stop
      integer iv14(maxatm)
      integer map(maxlight)
      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 xab,yab,zab
      real*8 xcb,ycb,zcb
      real*8 rab2,rab,rcb2
      real*8 xp,yp,zp,rp
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 vscale(maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical proceed,iuse,repeat
      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
      header = .true.
c
c     zero out the array marking 1-4 vdw interactions
c
      do i = 1, n
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      call switch ('VDW')
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
      call lights (nvdw,map,xsort,ysort,zsort)
c
c     now, loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = class(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         iuse = (use(i) .or. use(iv))
         do j = 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
         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 40
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 40
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 40
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 40
            end if
            k = ivdw(map(kk))
            kv = ired(k)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = class(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_image) 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) 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
                        xab = xred(ii) - x(ib)
                        yab = yred(ii) - y(ib)
                        zab = zred(ii) - z(ib)
                        xcb = xab - xr
                        ycb = yab - yr
                        zcb = zab - zr
                     else
                        ia = k
                        ib = i12(1,k)
                        ic = i
                        xab = xred(kk) - x(ib)
                        yab = yred(kk) - y(ib)
                        zab = zred(kk) - z(ib)
                        xcb = xab + xr
                        ycb = yab + yr
                        zcb = zab + zr
                     end if
                     if (ired(ia) .ne. ia) then
                        xab = xab / kred(ia)
                        yab = yab / kred(ia)
                        zab = zab / kred(ia)
                     end if
                     rab2 = xab*xab + yab*yab + zab*zab
                     rab = sqrt(rab2)
                     rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
                     xp = ycb*zab - zcb*yab
                     yp = zcb*xab - xcb*zab
                     zp = xcb*yab - ycb*xab
                     rp = sqrt(xp*xp + yp*yp + zp*zp)
                     dot = xab*xcb + yab*ycb + zab*zcb
                     cosine = dot / sqrt(rab2*rcb2)
                     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)  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.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',13x,'Atom Names',
     &                             18x,'Minimum',4x,'Actual',
     &                             6x,'Energy',/)
                     end if
                     write (iout,30)  i,name(i),k,name(k),
     &                                rv,sqrt(rik2),e
   30                format (' VDW-LJ',5x,i5,'-',a3,1x,i5,'-',
     &                          a3,12x,2f10.4,f12.4)
                  end if
               end if
            end if
   40       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
      end do
      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  --  multipole & polarization energy  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "empole" calculates the electrostatic energy due to
c     atomic multipole interactions and dipole polarizability
c
c
      subroutine empole
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or Ewald summation version
c
      if (use_ewald) then
         call empole0b
      else
         call empole0a
      end if
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine empole0a  --  double loop multipole energy  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "empole0a" calculates the electrostatic energy due to
c     atomic multipole interactions and dipole polarizability
c     using a pairwise double loop
c
c
      subroutine empole0a
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'math.i'
      include 'mplpot.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k
      integer ii,kk
      integer ix,iz
      integer kx,kz
      real*8 e,ei,f,fikm,fikp
      real*8 r,r2,xr,yr,zr
      real*8 fgrp,damp
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9
      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 scale3,scale5
      real*8 scale7
      real*8 sc(10),sci(8)
      real*8 gl(0:4),gli(3)
      real*8 a(3,3)
      real*8 mscale(maxatm)
      real*8 pscale(maxatm)
      logical proceed,iuse,kuse
c
c
c     zero out the multipole and polarization energies
c
      em = 0.0d0
      ep = 0.0d0
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (npole .eq. 0)  return
      f = electric / dielec
      call switch ('MPOLE')
c
c     calculate the multipole interaction energy term
c
      do i = 1, npole-1
         ii = ipole(i)
         iz = zaxis(i)
         ix = xaxis(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)
         iuse = (use(ii) .or. use(iz) .or. use(ix))
         do j = i+1, npole
            mscale(ipole(j)) = 1.0d0
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
c
c     decide whether to compute the current interaction
c
         do k = i+1, npole
            kk = ipole(k)
            kz = zaxis(k)
            kx = xaxis(k)
            kuse = (use(kk) .or. use(kz) .or. use(kx))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,ii,kk,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (iuse .or. kuse)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = x(kk) - x(ii)
               yr = y(kk) - y(ii)
               zr = z(kk) - z(ii)
               call image (xr,yr,zr,0)
               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     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(2) = dix*dkx + diy*dky + diz*dkz
                  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
                  sc(7) = qix*dkx + qiy*dky + qiz*dkz
                  sc(8) = qkx*dix + qky*diy + qkz*diz
                  sc(9) = qix*qkx + qiy*qky + qiz*qkz
                  sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                        + qixx*qkxx + qiyy*qkyy + qizz*qkzz
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 permanent multipoles
c
                  gl(0) = ci*ck
                  gl(1) = ck*sc(3) - ci*sc(4) + sc(2)
                  gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4)
     &                       + 2.0d0*(sc(7)-sc(8)+sc(10))
                  gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9)
                  gl(4) = sc(5)*sc(6)
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
                  rr9 = 7.0d0 * rr7 / r2
                  scale3 = 1.0d0 
                  scale5 = 1.0d0 
                  scale7 = 1.0d0 
                  damp = pdamp(i) * pdamp(k)
                  if (damp .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)
                     end if
                  end if
                  e = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5
     &                   + gl(3)*rr7 + gl(4)*rr9
                  ei = gli(1)*rr3*scale3 + gli(2)*rr5*scale5 
     &                    + gli(3)*rr7*scale7
c
c     make the adjustment for scaled interactions
c
                  fikm = f * mscale(kk)
                  fikp = f * pscale(kk)
                  e = fikm * e
                  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
                     e = e * fgrp
c                    ei = ei * fgrp
                  end if
c
c     increment the overall multipole and polarization energies
c
                  em = em + e
                  ep = ep + ei
               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, npole
         ii = ipole(i)
         iz = zaxis(i)
         ix = xaxis(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)
         iuse = (use(ii) .or. use(iz) .or. use(ix))
         do j = i, npole
            mscale(ipole(j)) = 1.0d0
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
c
c     decide whether to compute the current interaction
c
         do k = i, npole
            kk = ipole(k)
            kz = zaxis(k)
            kx = xaxis(k)
            kuse = (use(kk) .or. use(kz) .or. use(kx))
            if (use_group)  call groups (proceed,fgrp,2,ii,kk,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (iuse .or. kuse)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 1, ncell
                  xr = x(kk) - x(ii)
                  yr = y(kk) - y(ii)
                  zr = z(kk) - z(ii)
                  call image (xr,yr,zr,j)
                  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     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(2) = dix*dkx + diy*dky + diz*dkz
                     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
                     sc(7) = qix*dkx + qiy*dky + qiz*dkz
                     sc(8) = qkx*dix + qky*diy + qkz*diz
                     sc(9) = qix*qkx + qiy*qky + qiz*qkz
                     sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                           + qixx*qkxx + qiyy*qkyy + qizz*qkzz
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 permanent multipoles
c
                     gl(0) = ci*ck
                     gl(1) = ck*sc(3) - ci*sc(4) + sc(2)
                     gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4)
     &                          + 2.0d0*(sc(7)-sc(8)+sc(10))
                     gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9)
                     gl(4) = sc(5)*sc(6)
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
                     rr9 = 7.0d0 * rr7 / r2
                     scale3 = 1.0d0 
                     scale5 = 1.0d0 
                     scale7 = 1.0d0 
                     damp = pdamp(i) * pdamp(k)
                     if (damp .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)
                        end if
                     end if
                     e = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5
     &                      + gl(3)*rr7 + gl(4)*rr9
                     ei = gli(1)*rr3*scale3 + gli(2)*rr5*scale5 
     &                       + gli(3)*rr7*scale7
                     fikm = f
                     fikp = f
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           fikm = fikm * mscale(kk)
                           fikp = fikp * pscale(kk)
                        end if
                     end if
                     e = fikm * e
                     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
                        e = e * fgrp
c                       ei = ei * fgrp
                     end if
c
c     increment the overall multipole and polarization energies
c
                     if (ii .eq. kk) then
                        e = 0.5d0 * e
                        ei = 0.5d0 * ei
                     end if
                     em = em + e
                     ep = ep + ei
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine empole0b  --  Ewald summation multipole energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "empole0b" calculates the electrostatic energy due to
c     atomic multipole interactions and dipole polarizability
c     using a regular Ewald summation
c
c
      subroutine empole0b
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'chgpot.i'
      include 'energi.i'
      include 'ewald.i'
      include 'math.i'
      include 'mpole.i'
      include 'polar.i'
      include 'units.i'
      integer i,ii
      real*8 e,ei,a(3,3)
      real*8 f,term,fterm
      real*8 cii,dii,qii,uii
      real*8 xd,yd,zd
      real*8 xu,yu,zu
      real*8 ci,dix,diy,diz
      real*8 uix,uiy,uiz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
c
c
c     zero out the multipole and polarization energies
c
      em = 0.0d0
      ep = 0.0d0
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     compute the reciprocal space part of the Ewald summation
c
      call erecip
c
c     compute the real space portion of the Ewald summation
c
      call ereal
c
c     compute the self-energy portion of the Ewald summation
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / sqrtpi
      do i = 1, npole
         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)
         cii = ci*ci
         dii = dix*dix + diy*diy + diz*diz
         qii = qixx*qixx + qiyy*qiyy + qizz*qizz
     &            + 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz)
         uii = dix*uix + diy*uiy + diz*uiz
         e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0))
         ei = fterm * term * uii / 3.0d0
         em = em + e
         ep = ep + ei
      end do
c
c     compute the cell dipole boundary correction term
c
      if (.not. tinfoil) then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xu = 0.0d0
         yu = 0.0d0
         zu = 0.0d0
         do i = 1, npole
            ii = ipole(i)
            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(ii)
            yd = yd + diy + rpole(1,i)*y(ii)
            zd = zd + diz + rpole(1,i)*z(ii)
            xu = xu + uix        
            yu = yu + uiy
            zu = zu + uiz       
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         em = em + term*(xd*xd+yd*yd+zd*zd)
         ep = ep + term*(xd*xu+yd*yu+zd*zu)
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine erecip  --  multipole Ewald reciprocal energy  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "erecip" evaluates the reciprocal space portion of the regular
c     Ewald summation energy due to atomic multipole interactions
c     and dipole polarizability
c
c     literature reference:
c
c     W. Smith, "Point Multipoles in the Ewald Summation (Revisited)",
c     CCP5 Newsletter, 46, 18-30, 1998  (see http://www.ccp5.org/)
c
c
      subroutine erecip
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'chgpot.i'
      include 'energi.i'
      include 'ewald.i'
      include 'ewreg.i'
      include 'math.i'
      include 'mpole.i'
      include 'polar.i'
      include 'units.i'
      integer i,j,k,l,ii
      integer jmin,jmax
      integer kmin,kmax
      integer lmin,lmax
      real*8 e,ei,f,term,cut
      real*8 eterm,expterm
      real*8 xfr,yfr,zfr
      real*8 rj,rk,rl
      real*8 h1,h2,h3,hsq
      real*8 t1,t2,t3,t4
      real*8 ck,dk,qk,uk
      real*8 q1,q2,q3
      real*8 ckr,skr
      real*8 cm(maxatm)
      real*8 dm(3,maxatm)
      real*8 qm(9,maxatm)
      real*8 um(3,maxatm)
      real*8 cjk(maxatm)
      real*8 sjk(maxatm)
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = electric / dielec
      term = -0.25d0 / aewald**2
      eterm = 4.0d0 * pi * f / volbox
c
c     set the number of vectors based on box dimensions
c
      cut = 4.0d0 * pi * pi * frecip
      jmin = 0
      kmin = 0
      lmin = 1
      jmax = min(maxvec,int(frecip/recip(1,1)))
      kmax = min(maxvec,int(frecip/recip(2,2)))
      lmax = min(maxvec,int(frecip/recip(3,3)))
c
c     copy the multipole moments into local storage areas
c
      do i = 1, npole
         cm(i) = rpole(1,i)
         dm(1,i) = rpole(2,i)
         dm(2,i) = rpole(3,i)
         dm(3,i) = rpole(4,i)
         qm(1,i) = rpole(5,i)
         qm(2,i) = rpole(6,i)
         qm(3,i) = rpole(7,i)
         qm(4,i) = rpole(8,i)
         qm(5,i) = rpole(9,i)
         qm(6,i) = rpole(10,i)
         qm(7,i) = rpole(11,i)
         qm(8,i) = rpole(12,i)
         qm(9,i) = rpole(13,i)
         um(1,i) = uind(1,i)
         um(2,i) = uind(2,i)
         um(3,i) = uind(3,i)
      end do
c
c     calculate and store the exponential factors
c
      do i = 1, npole
         ii = ipole(i)
         zfr = (z(ii)/gamma_term) / zbox
         yfr = ((y(ii)-zfr*zbox*beta_term)/gamma_sin) / ybox
         xfr = (x(ii)-yfr*ybox*gamma_cos-zfr*zbox*beta_cos) / xbox
         xfr = 2.0d0 * pi * xfr
         yfr = 2.0d0 * pi * yfr
         zfr = 2.0d0 * pi * zfr
         ejc(i,0) = 1.0d0
         ejs(i,0) = 0.0d0
         ekc(i,0) = 1.0d0
         eks(i,0) = 0.0d0
         elc(i,0) = 1.0d0
         els(i,0) = 0.0d0
         ejc(i,1) = cos(xfr)
         ejs(i,1) = sin(xfr)
         ekc(i,1) = cos(yfr)
         eks(i,1) = sin(yfr)
         elc(i,1) = cos(zfr)
         els(i,1) = sin(zfr)
         ekc(i,-1) = ekc(i,1)
         eks(i,-1) = -eks(i,1)
         elc(i,-1) = elc(i,1)
         els(i,-1) = -els(i,1)
         do j = 2, jmax
            ejc(i,j) = ejc(i,j-1)*ejc(i,1) - ejs(i,j-1)*ejs(i,1)
            ejs(i,j) = ejs(i,j-1)*ejc(i,1) + ejc(i,j-1)*ejs(i,1)
         end do
         do j = 2, kmax
            ekc(i,j) = ekc(i,j-1)*ekc(i,1) - eks(i,j-1)*eks(i,1)
            eks(i,j) = eks(i,j-1)*ekc(i,1) + ekc(i,j-1)*eks(i,1)
            ekc(i,-j) = ekc(i,j)
            eks(i,-j) = -eks(i,j)
         end do
         do j = 2, lmax
            elc(i,j) = elc(i,j-1)*elc(i,1) - els(i,j-1)*els(i,1)
            els(i,j) = els(i,j-1)*elc(i,1) + elc(i,j-1)*els(i,1)
            elc(i,-j) = elc(i,j)
            els(i,-j) = -els(i,j)
         end do
      end do
c
c     loop over all k vectors from the reciprocal lattice
c
      do j = jmin, jmax
         rj = 2.0d0 * pi * dble(j)
         do k = kmin, kmax
            rk = 2.0d0 * pi * dble(k)
            do i = 1, npole
               cjk(i) = ejc(i,j)*ekc(i,k) - ejs(i,j)*eks(i,k)
               sjk(i) = ejs(i,j)*ekc(i,k) + ejc(i,j)*eks(i,k)
            end do
            do l = lmin, lmax
               rl = 2.0d0 * pi * dble(l)
               h1 = recip(1,1)*rj
               h2 = recip(2,1)*rj + recip(2,2)*rk
               h3 = recip(3,1)*rj + recip(3,2)*rk + recip(3,3)*rl
               hsq = h1*h1 + h2*h2 + h3*h3
               if (hsq .le. cut) then
                  t1 = 0.0d0
                  t2 = 0.0d0
                  t3 = 0.0d0
                  t4 = 0.0d0
                  do i = 1, npole
                     ckr = cjk(i)*elc(i,l) - sjk(i)*els(i,l)
                     skr = sjk(i)*elc(i,l) + cjk(i)*els(i,l)
                     ck = cm(i)
                     dk = h1*dm(1,i) + h2*dm(2,i) + h3*dm(3,i)
                     q1 = h1*qm(1,i) + h2*qm(4,i) + h3*qm(7,i)
                     q2 = h1*qm(2,i) + h2*qm(5,i) + h3*qm(8,i)
                     q3 = h1*qm(3,i) + h2*qm(6,i) + h3*qm(9,i)
                     qk = h1*q1 + h2*q2 + h3*q3
                     uk = h1*um(1,i) + h2*um(2,i) + h3*um(3,i)
                     t1 = t1 + (ck-qk)*skr + dk*ckr
                     t2 = t2 + (ck-qk)*ckr - dk*skr
                     t3 = t3 + uk*ckr
                     t4 = t4 - uk*skr
                  end do
                  expterm = eterm * exp(term*hsq) / hsq
                  e = expterm * (t1*t1+t2*t2)
                  ei = expterm * (t1*t3+t2*t4)
                  em = em + e
                  ep = ep + ei
               end if
            end do
            lmin = -lmax
         end do
         kmin = -kmax
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ereal  --  multipole Ewald real space energy  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ereal" evaluates the real space portion of the regular Ewald
c     summation energy due to atomic multipole interactions and dipole
c     polarizability
c
c     literature reference:
c
c     W. Smith, "Point Multipoles in the Ewald Summation (Revisited)",
c     CCP5 Newsletter, 46, 18-30, 1998  (see http://www.ccp5.org/)
c
c
      subroutine ereal
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'ewald.i'
      include 'math.i'
      include 'mplpot.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'shunt.i'
      include 'units.i'
      integer i,j,k,m
      integer ii,kk
      real*8 e,ei,f,erfc
      real*8 r,r2,xr,yr,zr
      real*8 bfac,exp2a
      real*8 efix,eifix
      real*8 ralpha,damp
      real*8 alsq2,alsq2n
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9
      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 scale3,scale5
      real*8 scale7
      real*8 sc(10),sci(8)
      real*8 gl(0:4),gli(3)
      real*8 bn(0:4)
      real*8 mscale(maxatm)
      real*8 pscale(maxatm)
c
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (npole .eq. 0)  return
      f = electric / dielec
      call switch ('EWALD')
c
c     compute the real space portion of the Ewald summation
c
      do i = 1, npole-1
         ii = ipole(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)
         do j = i+1, npole
            mscale(ipole(j)) = 1.0d0
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
         do k = i+1, npole
            kk = ipole(k)
            xr = x(kk) - x(ii)
            yr = y(kk) - y(ii)
            zr = z(kk) - z(ii)
            call image (xr,yr,zr,0)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. cut2) 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     calculate the error function damping terms
c
               ralpha = aewald * r
               bn(0) = erfc(ralpha) / r
               alsq2 = 2.0d0 * aewald**2
               alsq2n = 0.0d0
               if (aewald .gt. 0.0d0)
     &            alsq2n = 1.0d0 / (sqrtpi*aewald)
               exp2a = exp(-ralpha**2)
               do m = 1, 4
                  bfac = dble(m+m-1)
                  alsq2n = alsq2 * alsq2n
                  bn(m) = (bfac*bn(m-1)+alsq2n*exp2a) / r2
               end do
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(2) = dix*dkx + diy*dky + diz*dkz
               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
               sc(7) = qix*dkx + qiy*dky + qiz*dkz
               sc(8) = qkx*dix + qky*diy + qkz*diz
               sc(9) = qix*qkx + qiy*qky + qiz*qkz
               sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                     + qixx*qkxx + qiyy*qkyy + qizz*qkzz
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 permanent multipoles
c
               gl(0) = ci*ck
               gl(1) = ck*sc(3) - ci*sc(4) + sc(2)
               gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4)
     &                    + 2.0d0*(sc(7)-sc(8)+sc(10))
               gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9)
               gl(4) = sc(5)*sc(6)
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
               e = gl(0)*bn(0) + gl(1)*bn(1) + gl(2)*bn(2)
     &                + gl(3)*bn(3) + gl(4)*bn(4)
               ei = gli(1)*bn(1) + gli(2)*bn(2) + gli(3)*bn(3)
c
c     full energies needeed for scaling and damping correction
c
               rr1 = 1.0d0 / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               damp = pdamp(i) * pdamp(k)
               scale3 = pscale(kk) 
               scale5 = pscale(kk)
               scale7 = pscale(kk)
               damp = pdamp(i) * pdamp(k)
               if (damp .ne. 0.0d0) then
                  damp = -pgamma * (r/damp)**3
                  if (damp .gt. -50.0d0) then
                     scale3 = scale3 * (1.0d0-exp(damp))
                     scale5 = scale5 * (1.0d0-(1.0d0-damp)*exp(damp))
                     scale7 = scale7 * (1.0d0-(1.0d0-damp+0.6d0*damp**2)
     &                                               *exp(damp))
                  end if
               end if
               efix = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5
     &                   + gl(3)*rr7 + gl(4)*rr9
               eifix = gli(1)*rr3*(1.0d0-scale3)
     &                    + gli(2)*rr5*(1.0d0-scale5)
     &                    + gli(3)*rr7*(1.0d0-scale7)
c
c     correction for scaled interactions and polarization damping
c
               e = e - efix*(1.0d0-mscale(kk))
               ei = ei - eifix
c
c     increment the overall multipole and polarization energies
c
               e = f * e
               ei = 0.5d0 * f * ei
               em = em + e
               ep = ep + ei
            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, npole
         ii = ipole(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)
         do j = i, npole
            mscale(ipole(j)) = 1.0d0
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
         do k = i, npole
            kk = ipole(k)
            do j = 1, ncell
               xr = x(kk) - x(ii)
               yr = y(kk) - y(ii)
               zr = z(kk) - z(ii)
               call image (xr,yr,zr,j)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. cut2) 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     calculate the error function damping terms
c
                  ralpha = aewald * r
                  bn(0) = erfc(ralpha) / r
                  alsq2 = 2.0d0 * aewald**2
                  alsq2n = 0.0d0
                  if (aewald .gt. 0.0d0)
     &               alsq2n = 1.0d0 / (sqrtpi*aewald)
                  exp2a = exp(-ralpha**2)
                  do m = 1, 4
                     bfac = dble(m+m-1)
                     alsq2n = alsq2 * alsq2n
                     bn(m) = (bfac*bn(m-1)+alsq2n*exp2a) / r2
                  end do
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(2) = dix*dkx + diy*dky + diz*dkz
                  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
                  sc(7) = qix*dkx + qiy*dky + qiz*dkz
                  sc(8) = qkx*dix + qky*diy + qkz*diz
                  sc(9) = qix*qkx + qiy*qky + qiz*qkz
                  sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                        + qixx*qkxx + qiyy*qkyy + qizz*qkzz
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 permanent multipoles
c
                  gl(0) = ci*ck
                  gl(1) = ck*sc(3) - ci*sc(4) + sc(2)
                  gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4)
     &                       + 2.0d0*(sc(7)-sc(8)+sc(10))
                  gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9)
                  gl(4) = sc(5)*sc(6)
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
                  e = gl(0)*bn(0) + gl(1)*bn(1) + gl(2)*bn(2)
     &                   + gl(3)*bn(3) + gl(4)*bn(4)
                  ei = gli(1)*bn(1) + gli(2)*bn(2) + gli(3)*bn(3)
c
c     full energies needeed for scaling and damping correction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
                  damp = pdamp(i) * pdamp(k)
                  scale3 = 1.0d0 
                  scale5 = 1.0d0 
                  scale7 = 1.0d0 
                  damp = pdamp(i) * pdamp(k)
                  if (damp .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)
                     end if
                  end if
                  if (use_polymer .and. r2.le.polycut2) then
                     scale3 = scale3 * pscale(kk)
                     scale5 = scale5 * pscale(kk)
                     scale7 = scale7 * pscale(kk)
                  end if
                  efix = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5
     &                      + gl(3)*rr7 + gl(4)*rr9
                  eifix = gli(1)*rr3*(1.0d0-scale3) 
     &                       + gli(2)*rr5*(1.0d0-scale5) 
     &                       + gli(3)*rr7*(1.0d0-scale7)
c
c     correction for scaled interactions and polarization damping
c
                  if (use_polymer .and. r2.le.polycut2) 
     &               e = e - efix*(1.0d0-mscale(kk))
                  ei = ei - eifix
c
c     increment the overall multipole and polarization energies
c
                  e = f * e
                  ei = 0.5d0 * f * ei
                  if (ii .eq. kk) then
                     e = 0.5d0 * e
                     ei = 0.5d0 * ei
                  end if
                  em = em + e
                  ep = ep + ei
               end if
            end do
         end do
      end do
      return
      end
c
c
c     #############################################################
c     ##  COPYRIGHT (C) 1995 by Yong Kong & Jay William Ponder   ##
c     ##  COPYRIGHT (C) 1999 by Pengyu Ren & Jay William Ponder  ##
c     ##                   All Rights Reserved                   ##
c     #############################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine empole1  --  mpole/polar energy & derivatives  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "empole1" calculates the multipole and dipole polarization
c     energy and derivatives with respect to Cartesian coordinates
c
c
      subroutine empole1
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or Ewald summation version
c
      if (use_ewald) then
         call empole1b
      else
         call empole1a
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine empole1a  --  double loop multipole derivatives  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "empole1a" calculates the multipole and dipole polarization
c     energy and derivatives with respect to Cartesian coordinates
c     using a pairwise double loop
c
c
      subroutine empole1a
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'cutoff.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'mplpot.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      include 'virial.i'
      integer i,j,k
      integer ii,jj
      integer ix,iz
      integer jx,jz
      real*8 e,ei,f,fgrp
      real*8 pterm,damp,gfd
      real*8 scale3,scale5
      real*8 scale7,scale9
      real*8 psc3,psc5,psc7,psc9
      real*8 dsc3,dsc5,dsc7,dsc9
      real*8 scale3i,scale5i
      real*8 scale7i
      real*8 xji,yji,zji
      real*8 xix,yix,zix
      real*8 xiz,yiz,ziz
      real*8 xjx,yjx,zjx
      real*8 xjz,yjz,zjz
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9,rr11
      real*8 vx,vy,vz,tq(3)
      real*8 frcxi(3),frczi(3)
      real*8 frcxj(3),frczj(3)
      real*8 ci,di(3),qi(9)
      real*8 cj,dj(3),qj(9)
      real*8 fridmp(3),findmp(3)
      real*8 ftm2(3),ftm2i(3)
      real*8 ttm2(3),ttm3(3)
      real*8 ttm2i(3),ttm3i(3)
      real*8 dixdj(3),fdir(3)
      real*8 dixuj(3),djxui(3)
      real*8 dixujp(3),djxuip(3)
      real*8 uixqjr(3),ujxqir(3)
      real*8 uixqjrp(3),ujxqirp(3)
      real*8 qiuj(3),qjui(3)
      real*8 qiujp(3),qjuip(3)
      real*8 rxqiuj(3),rxqjui(3)
      real*8 rxqiujp(3),rxqjuip(3)
      real*8 qidj(3),qjdi(3)
      real*8 qir(3),qjr(3)
      real*8 qiqjr(3),qjqir(3)
      real*8 qixqj(3),rxqir(3)
      real*8 dixr(3),djxr(3)
      real*8 dixqjr(3),djxqir(3)
      real*8 rxqjr(3),qjrxqir(3)
      real*8 rxqijr(3),rxqjir(3)
      real*8 rxqidj(3),rxqjdi(3)
      real*8 ddsc3(3),ddsc5(3)
      real*8 ddsc7(3),a(3,3)
      real*8 gl(0:8),gli(7),glip(7)
      real*8 sc(10),sci(8),scip(8)
      real*8 gf(7),gfi(6),gti(6)
      real*8 mscale(maxatm)
      real*8 pscale(maxatm)
      real*8 dscale(maxatm)
      real*8 uscale(maxatm)
      real*8 ftm1(3,maxatm)
      real*8 ftm1i(3,maxatm)
      real*8 ttm1(3,maxatm)
      real*8 ttm1i(3,maxatm)
      real*8 trq(3,maxatm)
      real*8 trqi(3,maxatm)
      logical proceed,iuse,juse
c
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (npole .eq. 0)  return
      f = electric / dielec
      call switch ('MPOLE')
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     zero out local accumulation arrays for derivatives
c
      do i = 1, n
         trq(1,i) = 0.0d0
         trq(2,i) = 0.0d0
         trq(3,i) = 0.0d0
         trqi(1,i) = 0.0d0
         trqi(2,i) = 0.0d0
         trqi(3,i) = 0.0d0
      end do
c
c     initialise temporary force and torque accumulators
c
      do i = 1, npole
         do k = 1, 3
            ftm1(k,i) = 0.0d0
            ftm1i(k,i) = 0.0d0
            ttm1(k,i) = 0.0d0
            ttm1i(k,i) = 0.0d0
         end do
      end do
c
c     set scale factors for permanent multipole and induced terms
c
      do i = 1, npole-1
         ii = ipole(i)
         iz = zaxis(i)
         ix = xaxis(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)
         iuse = (use(ii) .or. use(iz) .or. use(ix))
         do j = 1, n
            mscale(j) = 1.0d0
            dscale(j) = 1.0d0
            uscale(j) = 1.0d0
            pscale(j) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
         do j = 1, np11(ii)
            dscale(ip11(j,ii)) = d1scale
            uscale(ip11(j,ii)) = u1scale
         end do
         do j = 1, np12(ii)
            dscale(ip12(j,ii)) = d2scale
            uscale(ip12(j,ii)) = u2scale
         end do
         do j = 1, np13(ii)
            dscale(ip13(j,ii)) = d3scale
            uscale(ip13(j,ii)) = u3scale
         end do
         do j = 1, np14(ii)
            dscale(ip14(j,ii)) = d4scale
            uscale(ip14(j,ii)) = u4scale
         end do
         do j = i+1, npole
            jj = ipole(j)
            jz = zaxis(j)
            jx = xaxis(j)
            juse = (use(jj) .or. use(jz) .or. use(jx))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,ii,jj,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (iuse .or. juse)
            if (.not. proceed)  goto 10
            cj = rpole(1,j)
            dj(1) = rpole(2,j)
            dj(2) = rpole(3,j)
            dj(3) = rpole(4,j)
            qj(1) = rpole(5,j)
            qj(2) = rpole(6,j)
            qj(3) = rpole(7,j)
            qj(4) = rpole(8,j)
            qj(5) = rpole(9,j)
            qj(6) = rpole(10,j)
            qj(7) = rpole(11,j)
            qj(8) = rpole(12,j)
            qj(9) = rpole(13,j)
            xji = x(jj) - x(ii)
            yji = y(jj) - y(ii)
            zji = z(jj) - z(ii)
            if (use_image)  call image (xji,yji,zji,0)
            r2 = xji*xji + yji*yji + zji*zji
            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
               rr11 = 9.0d0 * rr9 / r2
               scale3 = 1.0d0
               scale5 = 1.0d0
               scale7 = 1.0d0
               scale9 = 1.0d0
               do k = 1, 3
                  ddsc3(k) = 0.0d0
                  ddsc5(k) = 0.0d0
                  ddsc7(k) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               pterm = pdamp(i) * pdamp(j)
               if (pterm .ne. 0.0d0) then
                  damp = -pgamma * (r/pterm)**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) * xji/r2
                     ddsc3(2) = -3.0d0*damp*exp(damp) * yji/r2
                     ddsc3(3) = -3.0d0*damp*exp(damp) * zji/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(jj)
               scale5i = scale5 * uscale(jj)
               scale7i = scale7 * uscale(jj)
               dsc3 = scale3 * dscale(jj)
               dsc5 = scale5 * dscale(jj)
               dsc7 = scale7 * dscale(jj)
               dsc9 = scale9 * dscale(jj)
               psc3 = scale3 * pscale(jj)
               psc5 = scale5 * pscale(jj)
               psc7 = scale7 * pscale(jj)
               psc9 = scale9 * pscale(jj)
c
c     construct auxiliary vectors
c
               dixdj(1) = di(2)*dj(3) - di(3)*dj(2)
               dixdj(2) = di(3)*dj(1) - di(1)*dj(3)
               dixdj(3) = di(1)*dj(2) - di(2)*dj(1)
               dixuj(1) = di(2)*uind(3,j) - di(3)*uind(2,j)
               dixuj(2) = di(3)*uind(1,j) - di(1)*uind(3,j)
               dixuj(3) = di(1)*uind(2,j) - di(2)*uind(1,j)
               djxui(1) = dj(2)*uind(3,i) - dj(3)*uind(2,i)
               djxui(2) = dj(3)*uind(1,i) - dj(1)*uind(3,i)
               djxui(3) = dj(1)*uind(2,i) - dj(2)*uind(1,i)
               dixujp(1) = di(2)*uinp(3,j) - di(3)*uinp(2,j)
               dixujp(2) = di(3)*uinp(1,j) - di(1)*uinp(3,j)
               dixujp(3) = di(1)*uinp(2,j) - di(2)*uinp(1,j)
               djxuip(1) = dj(2)*uinp(3,i) - dj(3)*uinp(2,i)
               djxuip(2) = dj(3)*uinp(1,i) - dj(1)*uinp(3,i)
               djxuip(3) = dj(1)*uinp(2,i) - dj(2)*uinp(1,i)

               dixr(1) = di(2)*zji - di(3)*yji
               dixr(2) = di(3)*xji - di(1)*zji
               dixr(3) = di(1)*yji - di(2)*xji
               djxr(1) = dj(2)*zji - dj(3)*yji
               djxr(2) = dj(3)*xji - dj(1)*zji
               djxr(3) = dj(1)*yji - dj(2)*xji
               qir(1) = qi(1)*xji + qi(4)*yji + qi(7)*zji
               qir(2) = qi(2)*xji + qi(5)*yji + qi(8)*zji
               qir(3) = qi(3)*xji + qi(6)*yji + qi(9)*zji
               qjr(1) = qj(1)*xji + qj(4)*yji + qj(7)*zji
               qjr(2) = qj(2)*xji + qj(5)*yji + qj(8)*zji
               qjr(3) = qj(3)*xji + qj(6)*yji + qj(9)*zji
               qiqjr(1) = qi(1)*qjr(1) + qi(4)*qjr(2) + qi(7)*qjr(3)
               qiqjr(2) = qi(2)*qjr(1) + qi(5)*qjr(2) + qi(8)*qjr(3)
               qiqjr(3) = qi(3)*qjr(1) + qi(6)*qjr(2) + qi(9)*qjr(3)
               qjqir(1) = qj(1)*qir(1) + qj(4)*qir(2) + qj(7)*qir(3)
               qjqir(2) = qj(2)*qir(1) + qj(5)*qir(2) + qj(8)*qir(3)
               qjqir(3) = qj(3)*qir(1) + qj(6)*qir(2) + qj(9)*qir(3)
               qixqj(1) = qi(2)*qj(3) + qi(5)*qj(6) + qi(8)*qj(9)
     &                       - qi(3)*qj(2) - qi(6)*qj(5) - qi(9)*qj(8)
               qixqj(2) = qi(3)*qj(1) + qi(6)*qj(4) + qi(9)*qj(7)
     &                       - qi(1)*qj(3) - qi(4)*qj(6) - qi(7)*qj(9)
               qixqj(3) = qi(1)*qj(2) + qi(4)*qj(5) + qi(7)*qj(8)
     &                       - qi(2)*qj(1) - qi(5)*qj(4) - qi(8)*qj(7)
               rxqir(1) = yji*qir(3) - zji*qir(2)
               rxqir(2) = zji*qir(1) - xji*qir(3)
               rxqir(3) = xji*qir(2) - yji*qir(1)
               rxqjr(1) = yji*qjr(3) - zji*qjr(2)
               rxqjr(2) = zji*qjr(1) - xji*qjr(3)
               rxqjr(3) = xji*qjr(2) - yji*qjr(1)
               rxqijr(1) = yji*qiqjr(3) - zji*qiqjr(2)
               rxqijr(2) = zji*qiqjr(1) - xji*qiqjr(3)
               rxqijr(3) = xji*qiqjr(2) - yji*qiqjr(1)
               rxqjir(1) = yji*qjqir(3) - zji*qjqir(2)
               rxqjir(2) = zji*qjqir(1) - xji*qjqir(3)
               rxqjir(3) = xji*qjqir(2) - yji*qjqir(1)
               qjrxqir(1) = qjr(2)*qir(3) - qjr(3)*qir(2)
               qjrxqir(2) = qjr(3)*qir(1) - qjr(1)*qir(3)
               qjrxqir(3) = qjr(1)*qir(2) - qjr(2)*qir(1)
               qidj(1) = qi(1)*dj(1) + qi(4)*dj(2) + qi(7)*dj(3)
               qidj(2) = qi(2)*dj(1) + qi(5)*dj(2) + qi(8)*dj(3)
               qidj(3) = qi(3)*dj(1) + qi(6)*dj(2) + qi(9)*dj(3)
               qjdi(1) = qj(1)*di(1) + qj(4)*di(2) + qj(7)*di(3)
               qjdi(2) = qj(2)*di(1) + qj(5)*di(2) + qj(8)*di(3)
               qjdi(3) = qj(3)*di(1) + qj(6)*di(2) + qj(9)*di(3)
               qiuj(1) = qi(1)*uind(1,j)+qi(4)*uind(2,j)+qi(7)*uind(3,j)
               qiuj(2) = qi(2)*uind(1,j)+qi(5)*uind(2,j)+qi(8)*uind(3,j)
               qiuj(3) = qi(3)*uind(1,j)+qi(6)*uind(2,j)+qi(9)*uind(3,j)
               qjui(1) = qj(1)*uind(1,i)+qj(4)*uind(2,i)+qj(7)*uind(3,i)
               qjui(2) = qj(2)*uind(1,i)+qj(5)*uind(2,i)+qj(8)*uind(3,i)
               qjui(3) = qj(3)*uind(1,i)+qj(6)*uind(2,i)+qj(9)*uind(3,i)
               qiujp(1)= qi(1)*uinp(1,j)+qi(4)*uinp(2,j)+qi(7)*uinp(3,j)
               qiujp(2)= qi(2)*uinp(1,j)+qi(5)*uinp(2,j)+qi(8)*uinp(3,j)
               qiujp(3)= qi(3)*uinp(1,j)+qi(6)*uinp(2,j)+qi(9)*uinp(3,j)
               qjuip(1)= qj(1)*uinp(1,i)+qj(4)*uinp(2,i)+qj(7)*uinp(3,i)
               qjuip(2)= qj(2)*uinp(1,i)+qj(5)*uinp(2,i)+qj(8)*uinp(3,i)
               qjuip(3)= qj(3)*uinp(1,i)+qj(6)*uinp(2,i)+qj(9)*uinp(3,i)
               
               dixqjr(1) = di(2)*qjr(3) - di(3)*qjr(2)
               dixqjr(2) = di(3)*qjr(1) - di(1)*qjr(3)
               dixqjr(3) = di(1)*qjr(2) - di(2)*qjr(1)
               djxqir(1) = dj(2)*qir(3) - dj(3)*qir(2)
               djxqir(2) = dj(3)*qir(1) - dj(1)*qir(3)
               djxqir(3) = dj(1)*qir(2) - dj(2)*qir(1)
               
               uixqjr(1) = uind(2,i)*qjr(3) - uind(3,i)*qjr(2)
               uixqjr(2) = uind(3,i)*qjr(1) - uind(1,i)*qjr(3)
               uixqjr(3) = uind(1,i)*qjr(2) - uind(2,i)*qjr(1)
               ujxqir(1) = uind(2,j)*qir(3) - uind(3,j)*qir(2)
               ujxqir(2) = uind(3,j)*qir(1) - uind(1,j)*qir(3)
               ujxqir(3) = uind(1,j)*qir(2) - uind(2,j)*qir(1)
               uixqjrp(1) = uinp(2,i)*qjr(3) - uinp(3,i)*qjr(2)
               uixqjrp(2) = uinp(3,i)*qjr(1) - uinp(1,i)*qjr(3)
               uixqjrp(3) = uinp(1,i)*qjr(2) - uinp(2,i)*qjr(1)
               ujxqirp(1) = uinp(2,j)*qir(3) - uinp(3,j)*qir(2)
               ujxqirp(2) = uinp(3,j)*qir(1) - uinp(1,j)*qir(3)
               ujxqirp(3) = uinp(1,j)*qir(2) - uinp(2,j)*qir(1)
               
               rxqidj(1) = yji*qidj(3) - zji*qidj(2)
               rxqidj(2) = zji*qidj(1) - xji*qidj(3)
               rxqidj(3) = xji*qidj(2) - yji*qidj(1)
               rxqjdi(1) = yji*qjdi(3) - zji*qjdi(2)
               rxqjdi(2) = zji*qjdi(1) - xji*qjdi(3)
               rxqjdi(3) = xji*qjdi(2) - yji*qjdi(1)

               rxqiuj(1) = yji*qiuj(3) - zji*qiuj(2)
               rxqiuj(2) = zji*qiuj(1) - xji*qiuj(3)
               rxqiuj(3) = xji*qiuj(2) - yji*qiuj(1)
               rxqjui(1) = yji*qjui(3) - zji*qjui(2)
               rxqjui(2) = zji*qjui(1) - xji*qjui(3)
               rxqjui(3) = xji*qjui(2) - yji*qjui(1)
               rxqiujp(1) = yji*qiujp(3) - zji*qiujp(2)
               rxqiujp(2) = zji*qiujp(1) - xji*qiujp(3)
               rxqiujp(3) = xji*qiujp(2) - yji*qiujp(1)
               rxqjuip(1) = yji*qjuip(3) - zji*qjuip(2)
               rxqjuip(2) = zji*qjuip(1) - xji*qjuip(3)
               rxqjuip(3) = xji*qjuip(2) - yji*qjuip(1)
c
c     get intermediate variables for permanent energy terms
c
               sc(2) = di(1)*dj(1) + di(2)*dj(2) + di(3)*dj(3)
               sc(3) = di(1)*xji + di(2)*yji + di(3)*zji
               sc(4) = dj(1)*xji + dj(2)*yji + dj(3)*zji
               sc(5) = qir(1)*xji + qir(2)*yji + qir(3)*zji
               sc(6) = qjr(1)*xji + qjr(2)*yji + qjr(3)*zji
               sc(7) = qir(1)*dj(1) + qir(2)*dj(2) + qir(3)*dj(3)
               sc(8) = qjr(1)*di(1) + qjr(2)*di(2) + qjr(3)*di(3)
               sc(9) = qir(1)*qjr(1) + qir(2)*qjr(2) + qir(3)*qjr(3)
               sc(10) = qi(1)*qj(1) + qi(2)*qj(2) + qi(3)*qj(3)
     &                     + qi(4)*qj(4) + qi(5)*qj(5) + qi(6)*qj(6)
     &                     + qi(7)*qj(7) + qi(8)*qj(8) + qi(9)*qj(9)
c
c     get intermediate variables for induction energy terms
c
               sci(1) = uind(1,i)*dj(1) + uind(2,i)*dj(2)
     &                     + uind(3,i)*dj(3) + di(1)*uind(1,j)
     &                     + di(2)*uind(2,j) + di(3)*uind(3,j)
               sci(2) = uind(1,i)*uind(1,j) + uind(2,i)*uind(2,j)
     &                     + uind(3,i)*uind(3,j)
               sci(3) = uind(1,i)*xji + uind(2,i)*yji + uind(3,i)*zji
               sci(4) = uind(1,j)*xji + uind(2,j)*yji + uind(3,j)*zji
               sci(7) = qir(1)*uind(1,j) + qir(2)*uind(2,j)
     &                     + qir(3)*uind(3,j)
               sci(8) = qjr(1)*uind(1,i) + qjr(2)*uind(2,i)
     &                     + qjr(3)*uind(3,i)
               scip(1) = uinp(1,i)*dj(1) + uinp(2,i)*dj(2)
     &                      + uinp(3,i)*dj(3) + di(1)*uinp(1,j)
     &                      + di(2)*uinp(2,j) + di(3)*uinp(3,j)
               scip(2) = uind(1,i)*uinp(1,j)+uind(2,i)*uinp(2,j)
     &                      + uind(3,i)*uinp(3,j)+uinp(1,i)*uind(1,j)
     &                      + uinp(2,i)*uind(2,j)+uinp(3,i)*uind(3,j)
               scip(3) = uinp(1,i)*xji + uinp(2,i)*yji + uinp(3,i)*zji
               scip(4) = uinp(1,j)*xji + uinp(2,j)*yji + uinp(3,j)*zji
               scip(7) = qir(1)*uinp(1,j) + qir(2)*uinp(2,j)
     &                      + qir(3)*uinp(3,j)
               scip(8) = qjr(1)*uinp(1,i) + qjr(2)*uinp(2,i)
     &                      + qjr(3)*uinp(3,i)
c
c     get the induced-induced derivative terms
c
               findmp(1) = uscale(jj) * (scip(2)*rr3*ddsc3(1)
     &           - rr5*ddsc5(1)*(sci(3)*scip(4)+scip(3)*sci(4)))*0.5d0
               findmp(2) = uscale(jj) * (scip(2)*rr3*ddsc3(2)
     &           - rr5*ddsc5(2)*(sci(3)*scip(4)+scip(3)*sci(4)))*0.5d0
               findmp(3) = uscale(jj) * (scip(2)*rr3*ddsc3(3)
     &           - rr5*ddsc5(3)*(sci(3)*scip(4)+scip(3)*sci(4)))*0.5d0
c
c     calculate the gl functions for potential energy
c
               gl(0) = ci*cj
               gl(1) = cj*sc(3) - ci*sc(4)
               gl(2) = ci*sc(6) + cj*sc(5) - sc(3)*sc(4)
               gl(3) = sc(3)*sc(6) - sc(4)*sc(5)
               gl(4) = sc(5)*sc(6)
               gl(6) = sc(2)
               gl(7) = 2.0d0 * (sc(7)-sc(8))
               gl(8) = 2.0d0 * sc(10)
               gl(5) = -4.0d0 * sc(9)
               gli(1) = cj*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) = cj*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
               e = rr1*gl(0) + rr3*(gl(1)+gl(6))
     &                + rr5*(gl(2)+gl(7)+gl(8))
     &                + rr7*(gl(3)+gl(5)) + rr9*gl(4)
               ei = 0.5d0*(rr3*(gli(1)+gli(6))*psc3
     &                   + rr5*(gli(2)+gli(7))*psc5
     &                   + rr7*gli(3)*psc7)

               fridmp(1) = 0.5d0*(rr3*((gli(1)+gli(6))*pscale(jj)
     &           + (glip(1)+glip(6))*dscale(jj))*ddsc3(1)
     &           + rr5*((gli(2)+gli(7))*pscale(jj)
     &           + (glip(2)+glip(7))*dscale(jj))*ddsc5(1)
     &           + rr7*(gli(3)*pscale(jj)+glip(3)*dscale(jj))*ddsc7(1))
               fridmp(2) = 0.5d0*(rr3*((gli(1)+gli(6))*pscale(jj)
     &           + (glip(1)+glip(6))*dscale(jj))*ddsc3(2)
     &           + rr5*((gli(2)+gli(7))*pscale(jj)
     &           + (glip(2)+glip(7))*dscale(jj))*ddsc5(2)
     &           + rr7*(gli(3)*pscale(jj)+glip(3)*dscale(jj))*ddsc7(2))
               fridmp(3) = 0.5d0*(rr3*((gli(1)+gli(6))*pscale(jj)
     &           + (glip(1)+glip(6))*dscale(jj))*ddsc3(3)
     &           + rr5*((gli(2)+gli(7))*pscale(jj)
     &           + (glip(2)+glip(7))*dscale(jj))*ddsc5(3)
     &           + rr7*(gli(3)*pscale(jj)+glip(3)*dscale(jj))*ddsc7(3))
               e = f * mscale(jj) * e
               ei = f * ei
               em = em + e
               ep = ep + ei
c
c     increment the total intermolecular energy
c
               if (molcule(ii) .ne. molcule(jj)) then
                  einter = einter + e + ei
               end if
c
c     intermediate variables for the permanent multipole terms
c
               gf(1) = rr3*gl(0) + rr5*(gl(1)+gl(6))
     &                    + rr7*(gl(2)+gl(7)+gl(8))
     &                    + rr9*(gl(3)+gl(5)) + rr11*gl(4)
               gf(2) = -cj*rr3 + sc(4)*rr5 - sc(6)*rr7
               gf(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7
               gf(4) = 2.0d0 * rr5
               gf(5) = 2.0d0 * (-cj*rr5+sc(4)*rr7-sc(6)*rr9)
               gf(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9)
               gf(7) = 4.0d0 * rr7
c
c     intermediate variables for the induced-permanent terms
c
               gfi(1) = rr5*0.5d0*((gli(1)+gli(6))*psc3 
     &             + (glip(1)+glip(6))*dsc3 + scip(2)*scale3i)
     &             + 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)*0.5d0
               gfi(2) = -rr3*cj + 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 permanent force
c
               ftm2(1) = gf(1)*xji + gf(2)*di(1) + gf(3)*dj(1)
     &                      + gf(4)*(qjdi(1)-qidj(1)) + gf(5)*qir(1)
     &                      + gf(6)*qjr(1) + gf(7)*(qiqjr(1)+qjqir(1))
               ftm2(2) = gf(1)*yji + gf(2)*di(2) + gf(3)*dj(2)
     &                      + gf(4)*(qjdi(2)-qidj(2)) + gf(5)*qir(2)
     &                      + gf(6)*qjr(2) + gf(7)*(qiqjr(2)+qjqir(2))
               ftm2(3) = gf(1)*zji + gf(2)*di(3) + gf(3)*dj(3)
     &                      + gf(4)*(qjdi(3)-qidj(3)) + gf(5)*qir(3)
     &                      + gf(6)*qjr(3) + gf(7)*(qiqjr(3)+qjqir(3))
c
c     get the induced force
c
               ftm2i(1) = gfi(1)*xji + 0.5d0*
     &          (- rr3*cj*(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,j)*psc3+uinp(1,j)*dsc3)
     &           + rr5*sc(3)*(uind(1,j)*psc5+uinp(1,j)*dsc5)
     &           + rr7*sc(5)*(uind(1,j)*psc7+uinp(1,j)*dsc7))*0.5d0
     &           + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i)
     &           + sci(3)*uinp(1,j)+scip(3)*uind(1,j))*0.5d0
     &           + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1)
     &           + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dj(1)
     &           + 0.5d0*gfi(4)*((qjui(1)-qiuj(1))*psc5
     &           + (qjuip(1)-qiujp(1))*dsc5)
     &           + gfi(5)*qir(1) + gfi(6)*qjr(1)
               ftm2i(2) = gfi(1)*yji + 0.5d0*
     &          (- rr3*cj*(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,j)*psc3+uinp(2,j)*dsc3)
     &           + rr5*sc(3)*(uind(2,j)*psc5+uinp(2,j)*dsc5)
     &           + rr7*sc(5)*(uind(2,j)*psc7+uinp(2,j)*dsc7))*0.5d0
     &           + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i)
     &           + sci(3)*uinp(2,j)+scip(3)*uind(2,j))*0.5d0
     &           + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2)
     &           + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dj(2)
     &           + 0.5d0*gfi(4)*((qjui(2)-qiuj(2))*psc5
     &           + (qjuip(2)-qiujp(2))*dsc5)
     &           + gfi(5)*qir(2) + gfi(6)*qjr(2)
               ftm2i(3) = gfi(1)*zji  + 0.5d0*
     &          (- rr3*cj*(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,j)*psc3+uinp(3,j)*dsc3)
     &           + rr5*sc(3)*(uind(3,j)*psc5+uinp(3,j)*dsc5)
     &           + rr7*sc(5)*(uind(3,j)*psc7+uinp(3,j)*dsc7))*0.5d0
     &           + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i)
     &           + sci(3)*uinp(3,j)+scip(3)*uind(3,j))*0.5d0
     &           + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3)
     &           + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dj(3)
     &           + 0.5d0*gfi(4)*((qjui(3)-qiuj(3))*psc5
     &           + (qjuip(3)-qiujp(3))*dsc5)
     &           + gfi(5)*qir(3) + gfi(6)*qjr(3)
c
c     handle of scaling for partially excluded interactions
c
               ftm2(1) = mscale(jj) * ftm2(1)
               ftm2(2) = mscale(jj) * ftm2(2)
               ftm2(3) = mscale(jj) * ftm2(3)
               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 = (rr5*scip(2)*scale3i - rr7*(scip(3)*sci(4)
     &                 + sci(3)*scip(4))*scale5i)*0.5d0
                  fdir(1) = gfd*xji + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinp(1,i)+scip(4)*uind(1,i)
     &                           +sci(3)*uinp(1,j)+scip(3)*uind(1,j))
                  fdir(2) = gfd*yji + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinp(2,i)+scip(4)*uind(2,i)
     &                           +sci(3)*uinp(2,j)+scip(3)*uind(2,j))
                  fdir(3) = gfd*zji + 0.5d0*rr5*scale5i
     &                         * (sci(4)*uinp(3,i)+scip(4)*uind(3,i)
     &                           +sci(3)*uinp(3,j)+scip(3)*uind(3,j))
                  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     now perform the torque calculation
c     intermediate terms for torque between multipoles i and j
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     get the permanent interaction torques
c
               ttm2(1) = -rr3*dixdj(1) + gf(2)*dixr(1)-gf(5)*rxqir(1)
     &           + gf(4)*(dixqjr(1)+djxqir(1)+rxqidj(1)-2.0d0*qixqj(1))
     &           - gf(7)*(rxqijr(1)+qjrxqir(1))
               ttm2(2) = -rr3*dixdj(2) + gf(2)*dixr(2)-gf(5)*rxqir(2)
     &           + gf(4)*(dixqjr(2)+djxqir(2)+rxqidj(2)-2.0d0*qixqj(2))
     &           - gf(7)*(rxqijr(2)+qjrxqir(2))
               ttm2(3) = -rr3*dixdj(3) + gf(2)*dixr(3)-gf(5)*rxqir(3)
     &           + gf(4)*(dixqjr(3)+djxqir(3)+rxqidj(3)-2.0d0*qixqj(3))
     &           - gf(7)*(rxqijr(3)+qjrxqir(3))
               ttm3(1) = rr3*dixdj(1) + gf(3)*djxr(1) -gf(6)*rxqjr(1)
     &           - gf(4)*(dixqjr(1)+djxqir(1)+rxqjdi(1)-2.0d0*qixqj(1))
     &           - gf(7)*(rxqjir(1)-qjrxqir(1))
               ttm3(2) = rr3*dixdj(2) + gf(3)*djxr(2) -gf(6)*rxqjr(2)
     &           - gf(4)*(dixqjr(2)+djxqir(2)+rxqjdi(2)-2.0d0*qixqj(2))
     &           - gf(7)*(rxqjir(2)-qjrxqir(2))
               ttm3(3) = rr3*dixdj(3) + gf(3)*djxr(3) -gf(6)*rxqjr(3)
     &           - gf(4)*(dixqjr(3)+djxqir(3)+rxqjdi(3)-2.0d0*qixqj(3))
     &           - gf(7)*(rxqjir(3)-qjrxqir(3))
c
c     calculate the induced torque components
c
               ttm2i(1) = -rr3*(dixuj(1)*psc3+dixujp(1)*dsc3)*0.5d0
     &           + gti(2)*dixr(1) + gti(4)*((ujxqir(1)+rxqiuj(1))*psc5
     &           +(ujxqirp(1)+rxqiujp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1)
               ttm2i(2) = -rr3*(dixuj(2)*psc3+dixujp(2)*dsc3)*0.5d0
     &           + gti(2)*dixr(2) + gti(4)*((ujxqir(2)+rxqiuj(2))*psc5
     &           +(ujxqirp(2)+rxqiujp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2)
               ttm2i(3) = -rr3*(dixuj(3)*psc3+dixujp(3)*dsc3)*0.5d0
     &           + gti(2)*dixr(3) + gti(4)*((ujxqir(3)+rxqiuj(3))*psc5
     &           +(ujxqirp(3)+rxqiujp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3)
               ttm3i(1) = -rr3*(djxui(1)*psc3+djxuip(1)*dsc3)*0.5d0
     &           + gti(3)*djxr(1) - gti(4)*((uixqjr(1)+rxqjui(1))*psc5
     &           +(uixqjrp(1)+rxqjuip(1))*dsc5)*0.5d0 - gti(6)*rxqjr(1)
               ttm3i(2) = -rr3*(djxui(2)*psc3+djxuip(2)*dsc3)*0.5d0
     &           + gti(3)*djxr(2) - gti(4)*((uixqjr(2)+rxqjui(2))*psc5
     &           +(uixqjrp(2)+rxqjuip(2))*dsc5)*0.5d0 - gti(6)*rxqjr(2)
               ttm3i(3) = -rr3*(djxui(3)*psc3+djxuip(3)*dsc3)*0.5d0
     &           + gti(3)*djxr(3) - gti(4)*((uixqjr(3)+rxqjui(3))*psc5
     &           +(uixqjrp(3)+rxqjuip(3))*dsc5)*0.5d0 - gti(6)*rxqjr(3)
c
c     handle the case where scaling is used
c
               ttm2(1) = ttm2(1) * mscale(jj)
               ttm2(2) = ttm2(2) * mscale(jj)
               ttm2(3) = ttm2(3) * mscale(jj)
               ttm3(1) = ttm3(1) * mscale(jj)
               ttm3(2) = ttm3(2) * mscale(jj)
               ttm3(3) = ttm3(3) * mscale(jj)
c
c     now compute the virial components for this interaction
c
               xiz = x(zaxis(i)) - x(ii)
               yiz = y(zaxis(i)) - y(ii)
               ziz = z(zaxis(i)) - z(ii)
               xix = x(xaxis(i)) - x(ii)
               yix = y(xaxis(i)) - y(ii)
               zix = z(xaxis(i)) - z(ii)
               xjz = x(zaxis(j)) - x(jj)
               yjz = y(zaxis(j)) - y(jj)
               zjz = z(zaxis(j)) - z(jj)
               xjx = x(xaxis(j)) - x(jj)
               yjx = y(xaxis(j)) - y(jj)
               zjx = z(xaxis(j)) - z(jj)
               do k = 1, 3
                  tq(k) = ttm2(k) + ttm2i(k)
               end do
               call torque1 (i,tq,frczi,frcxi)
               do k = 1, 3
                  tq(k) = ttm3(k) + ttm3i(k)
               end do
               call torque1 (j,tq,frczj,frcxj)
               vx = -xji*(ftm2(1)+ftm2i(1)) + xix*frcxi(1)
     &                 + xjz*frczj(1) + xjx*frcxj(1) + xiz*frczi(1)
               vy = -yji*(ftm2(2)+ftm2i(2)) + yix*frcxi(2)
     &                 + yjz*frczj(2) + yjx*frcxj(2) + yiz*frczi(2)
               vz = -zji*(ftm2(3)+ftm2i(3)) + zix*frcxi(3)
     &                 + zjz*frczj(3) + zjx*frcxj(3) + ziz*frczi(3)
               virx = virx + f*vx
               viry = viry + f*vy
               virz = virz + f*vz
c
c     update force and torque on site j
c
               ftm1(1,j) = ftm1(1,j) + ftm2(1)
               ftm1(2,j) = ftm1(2,j) + ftm2(2)
               ftm1(3,j) = ftm1(3,j) + ftm2(3)
               ttm1(1,j) = ttm1(1,j) + ttm3(1)
               ttm1(2,j) = ttm1(2,j) + ttm3(2)
               ttm1(3,j) = ttm1(3,j) + ttm3(3)
               ftm1i(1,j) = ftm1i(1,j) + ftm2i(1)
               ftm1i(2,j) = ftm1i(2,j) + ftm2i(2)
               ftm1i(3,j) = ftm1i(3,j) + ftm2i(3)
               ttm1i(1,j) = ttm1i(1,j) + ttm3i(1)
               ttm1i(2,j) = ttm1i(2,j) + ttm3i(2)
               ttm1i(3,j) = ttm1i(3,j) + ttm3i(3)
c
c     update force and torque on site i
c
               ftm1(1,i) = ftm1(1,i) - ftm2(1)
               ftm1(2,i) = ftm1(2,i) - ftm2(2)
               ftm1(3,i) = ftm1(3,i) - ftm2(3)
               ttm1(1,i) = ttm1(1,i) + ttm2(1)
               ttm1(2,i) = ttm1(2,i) + ttm2(2)
               ttm1(3,i) = ttm1(3,i) + ttm2(3)
               ftm1i(1,i) = ftm1i(1,i) - ftm2i(1)
               ftm1i(2,i) = ftm1i(2,i) - ftm2i(2)
               ftm1i(3,i) = ftm1i(3,i) - ftm2i(3)
               ttm1i(1,i) = ttm1i(1,i) + ttm2i(1)
               ttm1i(2,i) = ttm1i(2,i) + ttm2i(2)
               ttm1i(3,i) = ttm1i(3,i) + ttm2i(3)
            end if
   10       continue
         end do
      end do
c
c     increment the total forces and torques
c
      do i = 1, npole
         ii = ipole(i)
         dem(1,ii) = dem(1,ii) - f*ftm1(1,i)
         dem(2,ii) = dem(2,ii) - f*ftm1(2,i)
         dem(3,ii) = dem(3,ii) - f*ftm1(3,i)
         dep(1,ii) = dep(1,ii) - f*ftm1i(1,i)
         dep(2,ii) = dep(2,ii) - f*ftm1i(2,i)
         dep(3,ii) = dep(3,ii) - f*ftm1i(3,i)
         trq(1,ii) = trq(1,ii) + f*ttm1(1,i)
         trq(2,ii) = trq(2,ii) + f*ttm1(2,i)
         trq(3,ii) = trq(3,ii) + f*ttm1(3,i)
         trqi(1,ii) = trqi(1,ii) + f*ttm1i(1,i)
         trqi(2,ii) = trqi(2,ii) + f*ttm1i(2,i)
         trqi(3,ii) = trqi(3,ii) + f*ttm1i(3,i)
      end do
      call torque (trq,dem)
      call torque (trqi,dep)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine empole1b  --  Ewald summation multipole derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "empole1b" calculates the multipole and dipole polarization
c     energy and derivatives with respect to Cartesian coordinates
c     using a regular Ewald summation
c
c
      subroutine empole1b
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'chgpot.i'
      include 'deriv.i'
      include 'energi.i'
      include 'ewald.i'
      include 'inter.i'
      include 'math.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polpot.i'
      include 'units.i'
      include 'virial.i'
      integer i,j,ii
      real*8 e,ei,eintra
      real*8 f,term,fterm
      real*8 cii,dii,qii,uii
      real*8 xd,yd,zd
      real*8 xu,yu,zu
      real*8 xup,yup,zup
      real*8 xq,yq,zq
      real*8 ci,dix,diy,diz
      real*8 uix,uiy,uiz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 xdfield,xufield
      real*8 ydfield,yufield
      real*8 zdfield,zufield
      real*8 trqi(3,maxatm)
      real*8 trqd(3,maxatm)
      real*8 a(3,3)
c
c
c     zero out multipole and polarization energy and derivatives
c
      em = 0.0d0
      ep = 0.0d0
      do i = 1, n
         do j = 1, 3
            dem(j,i) = 0.0d0
            dep(j,i) = 0.0d0
         end do
      end do
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
c
c     compute the induced dipole moment at each atom
c
      call induce
c
c     compute the reciprocal space part of the Ewald summation
c
      call erecip1
c
c     compute the real space part of the Ewald summation
c
      call ereal1 (eintra)
c
c     compute the Ewald self-energy term over all the atoms
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / sqrtpi
      do i = 1, npole
         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)
         cii = ci*ci
         dii = dix*dix + diy*diy + diz*diz
         qii = qixx*qixx + qiyy*qiyy + qizz*qizz
     &            + 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz)
         uii = dix*uix + diy*uiy + diz*uiz
         e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0))
         ei = fterm * term * uii / 3.0d0
         em = em + e
         ep = ep + ei
      end do
c
c     compute the self-energy torque term due to induced dipole
c
      do i = 1, n
         trqi(1,i) = 0.0d0
         trqi(2,i) = 0.0d0
         trqi(3,i) = 0.0d0
         trqd(1,i) = 0.0d0
         trqd(2,i) = 0.0d0
         trqd(3,i) = 0.0d0
      end do
      term = (4.0d0/3.0d0) * f * aewald**3 / sqrtpi
      do i = 1, npole
         ii = ipole(i)
         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))
         trqi(1,ii) = trqi(1,ii) + term*(diy*uiz-diz*uiy)
         trqi(2,ii) = trqi(2,ii) + term*(diz*uix-dix*uiz)
         trqi(3,ii) = trqi(3,ii) + term*(dix*uiy-diy*uix)
      end do
c
c     compute the cell dipole boundary correction term
c
      if (.not. tinfoil) 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 i = 1, npole
            ii = ipole(i)
            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)
         em = em + term*(xd*xd+yd*yd+zd*zd)
         ep = ep + term*(xd*xu+yd*yu+zd*zu)
         do i = 1, npole
            ii = ipole(i)
            dem(1,ii) = dem(1,ii) + 2.0d0*term*rpole(1,i)*xd
            dem(2,ii) = dem(2,ii) + 2.0d0*term*rpole(1,i)*yd
            dem(3,ii) = dem(3,ii) + 2.0d0*term*rpole(1,i)*zd
            dep(1,ii) = dep(1,ii) + term*rpole(1,i)*(xu+xup)
            dep(2,ii) = dep(2,ii) + term*rpole(1,i)*(yu+yup)
            dep(3,ii) = dep(3,ii) + term*rpole(1,i)*(zu+zup)
         end do
         xdfield = -2.0d0 * term * xd
         ydfield = -2.0d0 * term * yd
         zdfield = -2.0d0 * term * zd
         xufield = -term * (xu+xup)
         yufield = -term * (yu+yup)
         zufield = -term * (zu+zup)
         do i = 1, npole
            ii = ipole(i)
            trqd(1,ii) = trqd(1,ii) + rpole(3,i)*zdfield
     &                      - rpole(4,i)*ydfield
            trqd(2,ii) = trqd(2,ii) + rpole(4,i)*xdfield
     &                      - rpole(2,i)*zdfield
            trqd(3,ii) = trqd(3,ii) + rpole(2,i)*ydfield
     &                      - rpole(3,i)*xdfield
            trqi(1,ii) = trqi(1,ii) + rpole(3,i)*zufield
     &                      - rpole(4,i)*yufield
            trqi(2,ii) = trqi(2,ii) + rpole(4,i)*xufield
     &                      - rpole(2,i)*zufield
            trqi(3,ii) = trqi(3,ii) + rpole(2,i)*yufield
     &                      - rpole(3,i)*xufield
         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 i = 1, npole
            ii = ipole(i)
            xd = xd + rpole(2,i)  
            yd = yd + rpole(3,i)
            zd = zd + rpole(4,i)
            xq = xq + rpole(1,i)*x(ii)
            yq = yq + rpole(1,i)*y(ii)
            zq = zq + rpole(1,i)*z(ii)
         end do
         virx = virx - term*(xq*xq + 4.0d0*xq*(xd+0.5d0*(xu+xup))
     &                         + 3.0d0*(xd*(xd+xu+xup)+xu*xup))
         viry = viry - term*(yq*yq + 4.0d0*yq*(yd+0.5d0*(yu+yup))
     &                         + 3.0d0*(yd*(yd+yu+yup)+yu*yup))
         virz = virz - term*(zq*zq + 4.0d0*zq*(zd+0.5d0*(zu+zup))
     &                         + 3.0d0*(zd*(zd+zu+zup)+zu*zup))
         if (poltyp .eq. 'DIRECT') then
            virx = virx + term*(3.0d0*xu*xup)
            viry = viry + term*(3.0d0*yu*yup)
            virz = virz + term*(3.0d0*zu*zup)
         end if
      end if
c
c     convert torque from self-interaction and boundary correction
c
      call torque (trqi,dep)
      call torque (trqd,dem)
c
c     intermolecular energy is total minus intramolecular part
c
      einter = einter + em + ep - eintra
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine erecip1  --  mpole Ewald recip energy & derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "erecip1" evaluates the reciprocal space portion of the regular
c     Ewald summation energy and gradient due to atomic multipole
c     interactions and dipole polarizability
c
c     literature reference:
c
c     W. Smith, "Point Multipoles in the Ewald Summation (Revisited)",
c     CCP5 Newsletter, 46, 18-30, 1998  (see http://www.ccp5.org/)
c
c
      subroutine erecip1
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'chgpot.i'
      include 'deriv.i'
      include 'energi.i'
      include 'ewald.i'
      include 'ewreg.i'
      include 'math.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polpot.i'
      include 'units.i'
      include 'virial.i'
      integer i,j,k,l,ii
      integer jmin,jmax
      integer kmin,kmax
      integer lmin,lmax
      real*8 e,ei,etot,f,cut
      real*8 expterm,term,eterm
      real*8 uterm,vterm,wterm
      real*8 xfr,yfr,zfr
      real*8 rj,rk,rl
      real*8 h1,h2,h3,hsq
      real*8 ck,dk,qk,uk
      real*8 q1,q2,q3
      real*8 t1,t2,t3
      real*8 t4,t5,t6
      real*8 ukp,t3p,t4p
      real*8 de,det1,det2
      real*8 dei,det1i,det2i
      real*8 ckr(maxatm),skr(maxatm)
      real*8 cjk(maxatm),sjk(maxatm)
      real*8 s1(maxatm),s2(maxatm)
      real*8 s3(maxatm),s4(maxatm)
      real*8 s3p(maxatm),s4p(maxatm)
      real*8 cm(maxatm),dm(3,maxatm)
      real*8 qm(9,maxatm),um(3,maxatm)
      real*8 trq(3,maxatm),trqi(3,maxatm)
      real*8 dkx(maxatm),qkx(maxatm)
      real*8 dky(maxatm),qky(maxatm)
      real*8 dkz(maxatm),qkz(maxatm)
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      f = electric / dielec
      term = -0.25d0 / aewald**2
      eterm = 4.0d0 * pi * f / volbox
c
c     set the number of vectors based on box dimensions
c
      cut = 4.0d0 * pi * pi * frecip
      jmin = 0
      kmin = 0
      lmin = 1
      jmax = min(maxvec,int(frecip/recip(1,1)))
      kmax = min(maxvec,int(frecip/recip(2,2)))
      lmax = min(maxvec,int(frecip/recip(3,3)))
c
c     copy the multipole moments into local storage areas
c
      do i = 1, npole
         cm(i) = rpole(1,i)
         dm(1,i) = rpole(2,i)
         dm(2,i) = rpole(3,i)
         dm(3,i) = rpole(4,i)
         qm(1,i) = rpole(5,i)
         qm(2,i) = rpole(6,i)
         qm(3,i) = rpole(7,i)
         qm(4,i) = rpole(8,i)
         qm(5,i) = rpole(9,i)
         qm(6,i) = rpole(10,i)
         qm(7,i) = rpole(11,i)
         qm(8,i) = rpole(12,i)
         qm(9,i) = rpole(13,i)
         um(1,i) = uind(1,i)
         um(2,i) = uind(2,i)
         um(3,i) = uind(3,i)
      end do
c
c     zero out local accumulation arrays for derivatives
c
      do i = 1, n
         trq(1,i) = 0.0d0
         trq(2,i) = 0.0d0
         trq(3,i) = 0.0d0
         trqi(1,i) = 0.0d0
         trqi(2,i) = 0.0d0
         trqi(3,i) = 0.0d0
      end do
c
c     calculate and store the exponential factors
c
      do i = 1, npole
         ii = ipole(i)
         zfr = (z(ii)/gamma_term) / zbox
         yfr = ((y(ii)-zfr*zbox*beta_term)/gamma_sin) / ybox
         xfr = (x(ii)-yfr*ybox*gamma_cos-zfr*zbox*beta_cos) / xbox
         xfr = 2.0d0 * pi * xfr
         yfr = 2.0d0 * pi * yfr
         zfr = 2.0d0 * pi * zfr
         ejc(i,0) = 1.0d0
         ejs(i,0) = 0.0d0
         ekc(i,0) = 1.0d0
         eks(i,0) = 0.0d0
         elc(i,0) = 1.0d0
         els(i,0) = 0.0d0
         ejc(i,1) = cos(xfr)
         ejs(i,1) = sin(xfr)
         ekc(i,1) = cos(yfr)
         eks(i,1) = sin(yfr)
         elc(i,1) = cos(zfr)
         els(i,1) = sin(zfr)
         ekc(i,-1) = ekc(i,1)
         eks(i,-1) = -eks(i,1)
         elc(i,-1) = elc(i,1)
         els(i,-1) = -els(i,1)
         do j = 2, jmax
            ejc(i,j) = ejc(i,j-1)*ejc(i,1) - ejs(i,j-1)*ejs(i,1)
            ejs(i,j) = ejs(i,j-1)*ejc(i,1) + ejc(i,j-1)*ejs(i,1)
         end do
         do j = 2, kmax
            ekc(i,j) = ekc(i,j-1)*ekc(i,1) - eks(i,j-1)*eks(i,1)
            eks(i,j) = eks(i,j-1)*ekc(i,1) + ekc(i,j-1)*eks(i,1)
            ekc(i,-j) = ekc(i,j)
            eks(i,-j) = -eks(i,j)
         end do
         do j = 2, lmax
            elc(i,j) = elc(i,j-1)*elc(i,1) - els(i,j-1)*els(i,1)
            els(i,j) = els(i,j-1)*elc(i,1) + elc(i,j-1)*els(i,1)
            elc(i,-j) = elc(i,j)
            els(i,-j) = -els(i,j)
         end do
      end do
c
c     loop over all k vectors from the reciprocal lattice
c
      do j = jmin, jmax
         rj = 2.0d0 * pi * dble(j)
         do k = kmin, kmax
            rk = 2.0d0 * pi * dble(k)
            do i = 1, npole
               cjk(i) = ejc(i,j)*ekc(i,k) - ejs(i,j)*eks(i,k)
               sjk(i) = ejs(i,j)*ekc(i,k) + ejc(i,j)*eks(i,k)
            end do
            do l = lmin, lmax
               rl = 2.0d0 * pi * dble(l)
               h1 = recip(1,1)*rj
               h2 = recip(2,1)*rj + recip(2,2)*rk
               h3 = recip(3,1)*rj + recip(3,2)*rk + recip(3,3)*rl
               hsq = h1*h1 + h2*h2 + h3*h3
               if (hsq .le. cut) then
                  t1 = 0.0d0
                  t2 = 0.0d0
                  t3 = 0.0d0
                  t4 = 0.0d0
                  t3p = 0.0d0
                  t4p = 0.0d0
                  t5 = 0.0d0
                  t6 = 0.0d0
                  do i = 1, npole
                     ckr(i) = cjk(i)*elc(i,l) - sjk(i)*els(i,l)
                     skr(i) = sjk(i)*elc(i,l) + cjk(i)*els(i,l)
                     ck = cm(i)
                     dk = h1*dm(1,i) + h2*dm(2,i) + h3*dm(3,i)
                     dkx(i) = h3*dm(2,i) - h2*dm(3,i)
                     dky(i) = h1*dm(3,i) - h3*dm(1,i)
                     dkz(i) = h2*dm(1,i) - h1*dm(2,i)
                     q1 = h1*qm(1,i) + h2*qm(4,i) + h3*qm(7,i)
                     q2 = h1*qm(2,i) + h2*qm(5,i) + h3*qm(8,i)
                     q3 = h1*qm(3,i) + h2*qm(6,i) + h3*qm(9,i)
                     qk = h1*q1 + h2*q2 + h3*q3
                     qkx(i) = h3*q2 - h2*q3
                     qky(i) = h1*q3 - h3*q1
                     qkz(i) = h2*q1 - h1*q2
                     uk = h1*uind(1,i) + h2*uind(2,i) + h3*uind(3,i)
                     ukp = h1*uinp(1,i) + h2*uinp(2,i) + h3*uinp(3,i)
                     s1(i) = (ck-qk)*skr(i) + dk*ckr(i)
                     s2(i) = (ck-qk)*ckr(i) - dk*skr(i)
                     s3(i) = uk * ckr(i)
                     s4(i) = -uk * skr(i)
                     s3p(i) = ukp * ckr(i)
                     s4p(i) = -ukp * skr(i)
                     t1 = t1 + s1(i)
                     t2 = t2 + s2(i)
                     t3 = t3 + s3(i)
                     t4 = t4 + s4(i)
                     t3p = t3p + s3p(i)
                     t4p = t4p + s4p(i)
                     t5 = t5 + 2.0d0*qk*skr(i) - dk*ckr(i)
                     t6 = t6 + 2.0d0*qk*ckr(i) + dk*skr(i)
                  end do
c
c     get the energy contributions for current reciprocal vector
c
                  expterm = eterm * exp(term*hsq) / hsq
                  e = expterm * (t1*t1+t2*t2)
                  ei = expterm * (t1*t3+t2*t4)
                  etot = e + ei
                  em = em + e
                  ep = ep + ei
c
c     get the virial contributions for current reciprocal vector
c
                  uterm = expterm * (t1*(t1+t3+t3p) + t3*t3p
     &                                  + t2*(t2+t4+t4p) + t4*t4p)
                  vterm = 2.0d0 * (1.0d0-term*hsq) / hsq
                  wterm = 2.0d0 * expterm * (t1*t5 + t2*t6
     &                      + 0.5d0*((t3+t3p)*(t5-t1)+(t4+t4p)*(t6-t2))
     &                      - t3*t3p - t4*t4p) / hsq
                  if (poltyp .eq. 'DIRECT') then
                     uterm = uterm - expterm*(t3*t3p+t4*t4p)
                     wterm = wterm + 2.0d0*expterm*(t4*t4p+t3*t3p)/hsq
                  end if
                  wterm = uterm*vterm + wterm
                  virx = virx + h1*h1*wterm - uterm
                  virx = virx + h2*h2*wterm - uterm
                  virx = virx + h3*h3*wterm - uterm
c
c     get the force contributions for current reciprocal vector
c
                  expterm = 2.0d0 * expterm
                  do i = 1, npole
                     ii = ipole(i)
                     de = expterm * (s2(i)*t1-s1(i)*t2)
                     dei = 0.5d0 * expterm * ((s4(i)+s4p(i))*t1
     &                                       -(s3(i)+s3p(i))*t2
     &                                +s2(i)*(t3+t3p)-s1(i)*(t4+t4p))
                     if (poltyp .eq. 'MUTUAL') then
                         dei = dei + 0.5d0 * expterm
     &                            * (s4p(i)*t3+s4(i)*t3p
     &                              -s3p(i)*t4-s3(i)*t4p)
                     end if
                     det1 = expterm * (skr(i)*t2-ckr(i)*t1)
                     det2 = 2.0d0 * expterm * (ckr(i)*t2+skr(i)*t1)
                     det1i = 0.5d0 * expterm * (skr(i)*(t4+t4p)
     &                                         -ckr(i)*(t3+t3p))
                     det2i = expterm * (ckr(i)*(t4+t4p)+skr(i)*(t3+t3p))
                     dem(1,ii) = dem(1,ii) + h1*de
                     dem(2,ii) = dem(2,ii) + h2*de
                     dem(3,ii) = dem(3,ii) + h3*de
                     dep(1,ii) = dep(1,ii) + h1*dei
                     dep(2,ii) = dep(2,ii) + h2*dei
                     dep(3,ii) = dep(3,ii) + h3*dei
                     trq(1,ii) = trq(1,ii) + dkx(i)*det1 + qkx(i)*det2
                     trq(2,ii) = trq(2,ii) + dky(i)*det1 + qky(i)*det2
                     trq(3,ii) = trq(3,ii) + dkz(i)*det1 + qkz(i)*det2
                     trqi(1,ii) = trqi(1,ii) + dkx(i)*det1i
     &                               + qkx(i)*det2i
                     trqi(2,ii) = trqi(2,ii) + dky(i)*det1i
     &                               + qky(i)*det2i
                     trqi(3,ii) = trqi(3,ii) + dkz(i)*det1i
     &                               + qkz(i)*det2i
                  end do
               end if
            end do
            lmin = -lmax
         end do
         kmin = -kmax
      end do
c
c     convert the torques to forces and increment the totals
c
      call torque (trq,dem)
      call torque (trqi,dep)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ereal1  --  mpole ewald real energy and derivs  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ereal1" evaluates the real space portion of the regular Ewald
c     summation energy and gradient due to atomic multipole interactions
c     and dipole polarizability
c
c
      subroutine ereal1 (eintra)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'cutoff.i'
      include 'deriv.i'
      include 'energi.i'
      include 'ewald.i'
      include 'math.i'
      include 'molcul.i'
      include 'mplpot.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'shunt.i'
      include 'units.i'
      include 'virial.i'
      integer i,j,k,m
      integer ii,jj
      real*8 e,ei,f,bfac
      real*8 eintra,erfc
      real*8 pterm,damp
      real*8 scale3,scale5
      real*8 scale7,scale9
      real*8 dsc3,dsc5,dsc7
      real*8 psc3,psc5,psc7
      real*8 ruscale3,ruscale5
      real*8 ruscale7
      real*8 alsq2,alsq2n
      real*8 exp2a,ralpha
      real*8 gfdr,gfd
      real*8 xji,yji,zji
      real*8 xix,yix,zix
      real*8 xiz,yiz,ziz
      real*8 xjx,yjx,zjx
      real*8 xjz,yjz,zjz
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9,rr11
      real*8 einin,erl,erli
      real*8 vx,vy,vz,tq(3)
      real*8 frcxi(3),frczi(3)
      real*8 frcxj(3),frczj(3)
      real*8 ci,di(3),qi(9)
      real*8 cj,dj(3),qj(9)
      real*8 fridmp(3),findmp(3)
      real*8 ftm2(3),ftm2i(3)
      real*8 ftm2r(3),ftm2ri(3)
      real*8 ttm2(3),ttm3(3)
      real*8 ttm2i(3),ttm3i(3)
      real*8 ttm2r(3),ttm3r(3)
      real*8 ttm2ri(3),ttm3ri(3)
      real*8 fdir(3),dixdj(3)
      real*8 djxui(3),dixuj(3)
      real*8 dixujp(3),djxuip(3)
      real*8 uixqjr(3),ujxqir(3)
      real*8 uixqjrp(3),ujxqirp(3)
      real*8 qiuj(3),qjui(3)
      real*8 qiujp(3),qjuip(3)
      real*8 rxqiuj(3),rxqjui(3)
      real*8 rxqiujp(3),rxqjuip(3)
      real*8 qidj(3),qjdi(3)
      real*8 qir(3),qjr(3)
      real*8 qiqjr(3),qjqir(3)
      real*8 qixqj(3),rxqir(3)
      real*8 dixr(3),djxr(3)
      real*8 dixqjr(3),djxqir(3)
      real*8 rxqjr(3),qjrxqir(3)
      real*8 rxqijr(3),rxqjir(3)
      real*8 rxqidj(3),rxqjdi(3)
      real*8 ddsc3(3),ddsc5(3)
      real*8 ddsc7(3),bn(0:5)
      real*8 sc(10),gl(0:8)
      real*8 sci(8),scip(8)
      real*8 gli(7),glip(7)
      real*8 gf(7),gfi(6)
      real*8 gfr(7),gfri(6)
      real*8 gti(6),gtri(6)
      real*8 mscale(maxatm)
      real*8 pscale(maxatm)
      real*8 dscale(maxatm)
      real*8 uscale(maxatm)
      real*8 ftm1(3,maxatm)
      real*8 ftm1i(3,maxatm)
      real*8 ttm1(3,maxatm)
      real*8 ttm1i(3,maxatm)
      real*8 trq(3,maxatm)
      real*8 trqi(3,maxatm)
      external erfc
c
c
c     zero out the intramolecular portion of the Ewald energy
c
      eintra = 0.0d0
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (npole .eq. 0)  return
      f = electric / dielec
      call switch ('EWALD')
c
c     zero out local accumulation arrays for derivatives
c
      do i = 1, n
         trq(1,i) = 0.0d0
         trq(2,i) = 0.0d0
         trq(3,i) = 0.0d0
         trqi(1,i) = 0.0d0
         trqi(2,i) = 0.0d0
         trqi(3,i) = 0.0d0
      end do
c
c     initialise temporary force and torque accumulators
c
      do i = 1, npole
         do k = 1, 3
            ftm1(k,i) = 0.0d0
            ftm1i(k,i) = 0.0d0
            ttm1(k,i) = 0.0d0
            ttm1i(k,i) = 0.0d0
         end do
      end do
c
c     set scale factors for permanent multipole and induced terms
c
      do i = 1, npole-1
         ii = ipole(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)
         do j = 1, n
            mscale(j) = 1.0d0
            dscale(j) = 1.0d0
            pscale(j) = 1.0d0
            uscale(j) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
         do j = 1, np11(ii)
            dscale(ip11(j,ii)) = d1scale
            uscale(ip11(j,ii)) = u1scale
         end do
         do j = 1, np12(ii)
            dscale(ip12(j,ii)) = d2scale
            uscale(ip12(j,ii)) = u2scale
         end do
         do j = 1, np13(ii)
            dscale(ip13(j,ii)) = d3scale
            uscale(ip13(j,ii)) = u3scale
         end do
         do j = 1, np14(ii)
            dscale(ip14(j,ii)) = d4scale
            uscale(ip14(j,ii)) = u4scale
         end do
         do j = i+1, npole
            jj = ipole(j)
            cj = rpole(1,j)
            dj(1) = rpole(2,j)
            dj(2) = rpole(3,j)
            dj(3) = rpole(4,j)
            qj(1) = rpole(5,j)
            qj(2) = rpole(6,j)
            qj(3) = rpole(7,j)
            qj(4) = rpole(8,j)
            qj(5) = rpole(9,j)
            qj(6) = rpole(10,j)
            qj(7) = rpole(11,j)
            qj(8) = rpole(12,j)
            qj(9) = rpole(13,j)
            xji = x(jj) - x(ii)
            yji = y(jj) - y(ii)
            zji = z(jj) - z(ii)
            if (use_image)  call image (xji,yji,zji,0)
            r2 = xji*xji + yji*yji + zji*zji
            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
               rr11 = 9.0d0 * rr9 / r2
c
c     calculate the real space error function terms
c
               ralpha = aewald * r
               bn(0) = erfc(ralpha) / r
               alsq2 = 2.0d0 * aewald**2
               alsq2n = 0.0d0
               if (aewald .gt. 0.0d0)  alsq2n = 1.0d0 / (sqrtpi*aewald)
               exp2a = exp(-ralpha**2)
               do m = 1, 5
                  bfac = dble(m+m-1)
                  alsq2n = alsq2 * alsq2n
                  bn(m) = (bfac*bn(m-1)+alsq2n*exp2a) / r2
               end do
c
c     zero out the temporary force and torque
c
               do k = 1, 3
                  ftm2(k) = 0.0d0
                  ftm2i(k) = 0.0d0
                  ttm2(k) = 0.0d0
                  ttm2i(k) = 0.0d0
                  ttm3(k) = 0.0d0
                  ttm3i(k) = 0.0d0
               end do
               scale3 = 1.0d0
               scale5 = 1.0d0
               scale7 = 1.0d0
               scale9 = 1.0d0
               do k = 1, 3
                  ddsc3(k) = 0.0d0
                  ddsc5(k) = 0.0d0
                  ddsc7(k) = 0.0d0
               end do
               pterm = pdamp(i) * pdamp(j)
               if (pterm .ne. 0.0d0) then
                  damp = -pgamma * (r/pterm)**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) * xji/r2
                     ddsc3(2) = -3.0d0*damp*exp(damp) * yji/r2
                     ddsc3(3) = -3.0d0*damp*exp(damp) * zji/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
               dsc3 = 1.0d0 - scale3*dscale(jj)
               dsc5 = 1.0d0 - scale5*dscale(jj)
               dsc7 = 1.0d0 - scale7*dscale(jj)
               psc3 = 1.0d0 - scale3*pscale(jj)
               psc5 = 1.0d0 - scale5*pscale(jj)
               psc7 = 1.0d0 - scale7*pscale(jj)
               ruscale3 = 1.0d0 - scale3*uscale(jj)
               ruscale5 = 1.0d0 - scale5*uscale(jj)
               ruscale7 = 1.0d0 - scale7*uscale(jj)
c
c     construct auxiliary vectors
c
               dixdj(1) = di(2)*dj(3) - di(3)*dj(2)
               dixdj(2) = di(3)*dj(1) - di(1)*dj(3)
               dixdj(3) = di(1)*dj(2) - di(2)*dj(1)
               dixuj(1) = di(2)*uind(3,j) - di(3)*uind(2,j)
               dixuj(2) = di(3)*uind(1,j) - di(1)*uind(3,j)
               dixuj(3) = di(1)*uind(2,j) - di(2)*uind(1,j)
               djxui(1) = dj(2)*uind(3,i) - dj(3)*uind(2,i)
               djxui(2) = dj(3)*uind(1,i) - dj(1)*uind(3,i)
               djxui(3) = dj(1)*uind(2,i) - dj(2)*uind(1,i)
               dixujp(1) = di(2)*uinp(3,j) - di(3)*uinp(2,j)
               dixujp(2) = di(3)*uinp(1,j) - di(1)*uinp(3,j)
               dixujp(3) = di(1)*uinp(2,j) - di(2)*uinp(1,j)
               djxuip(1) = dj(2)*uinp(3,i) - dj(3)*uinp(2,i)
               djxuip(2) = dj(3)*uinp(1,i) - dj(1)*uinp(3,i)
               djxuip(3) = dj(1)*uinp(2,i) - dj(2)*uinp(1,i)
               dixr(1) = di(2)*zji - di(3)*yji
               dixr(2) = di(3)*xji - di(1)*zji
               dixr(3) = di(1)*yji - di(2)*xji
               djxr(1) = dj(2)*zji - dj(3)*yji
               djxr(2) = dj(3)*xji - dj(1)*zji
               djxr(3) = dj(1)*yji - dj(2)*xji
               qir(1) = qi(1)*xji + qi(4)*yji + qi(7)*zji
               qir(2) = qi(2)*xji + qi(5)*yji + qi(8)*zji
               qir(3) = qi(3)*xji + qi(6)*yji + qi(9)*zji
               qjr(1) = qj(1)*xji + qj(4)*yji + qj(7)*zji
               qjr(2) = qj(2)*xji + qj(5)*yji + qj(8)*zji
               qjr(3) = qj(3)*xji + qj(6)*yji + qj(9)*zji
               qiqjr(1) = qi(1)*qjr(1) + qi(4)*qjr(2) + qi(7)*qjr(3)
               qiqjr(2) = qi(2)*qjr(1) + qi(5)*qjr(2) + qi(8)*qjr(3)
               qiqjr(3) = qi(3)*qjr(1) + qi(6)*qjr(2) + qi(9)*qjr(3)
               qjqir(1) = qj(1)*qir(1) + qj(4)*qir(2) + qj(7)*qir(3)
               qjqir(2) = qj(2)*qir(1) + qj(5)*qir(2) + qj(8)*qir(3)
               qjqir(3) = qj(3)*qir(1) + qj(6)*qir(2) + qj(9)*qir(3)
               qixqj(1) = qi(2)*qj(3) + qi(5)*qj(6) + qi(8)*qj(9)
     &                       - qi(3)*qj(2) - qi(6)*qj(5) - qi(9)*qj(8)
               qixqj(2) = qi(3)*qj(1) + qi(6)*qj(4) + qi(9)*qj(7)
     &                       - qi(1)*qj(3) - qi(4)*qj(6) - qi(7)*qj(9)
               qixqj(3) = qi(1)*qj(2) + qi(4)*qj(5) + qi(7)*qj(8)
     &                       - qi(2)*qj(1) - qi(5)*qj(4) - qi(8)*qj(7)
               rxqir(1) = yji*qir(3) - zji*qir(2)
               rxqir(2) = zji*qir(1) - xji*qir(3)
               rxqir(3) = xji*qir(2) - yji*qir(1)
               rxqjr(1) = yji*qjr(3) - zji*qjr(2)
               rxqjr(2) = zji*qjr(1) - xji*qjr(3)
               rxqjr(3) = xji*qjr(2) - yji*qjr(1)
               rxqijr(1) = yji*qiqjr(3) - zji*qiqjr(2)
               rxqijr(2) = zji*qiqjr(1) - xji*qiqjr(3)
               rxqijr(3) = xji*qiqjr(2) - yji*qiqjr(1)
               rxqjir(1) = yji*qjqir(3) - zji*qjqir(2)
               rxqjir(2) = zji*qjqir(1) - xji*qjqir(3)
               rxqjir(3) = xji*qjqir(2) - yji*qjqir(1)
               qjrxqir(1) = qjr(2)*qir(3) - qjr(3)*qir(2)
               qjrxqir(2) = qjr(3)*qir(1) - qjr(1)*qir(3)
               qjrxqir(3) = qjr(1)*qir(2) - qjr(2)*qir(1)
               qidj(1) = qi(1)*dj(1) + qi(4)*dj(2) + qi(7)*dj(3)
               qidj(2) = qi(2)*dj(1) + qi(5)*dj(2) + qi(8)*dj(3)
               qidj(3) = qi(3)*dj(1) + qi(6)*dj(2) + qi(9)*dj(3)
               qjdi(1) = qj(1)*di(1) + qj(4)*di(2) + qj(7)*di(3)
               qjdi(2) = qj(2)*di(1) + qj(5)*di(2) + qj(8)*di(3)
               qjdi(3) = qj(3)*di(1) + qj(6)*di(2) + qj(9)*di(3)
               qiuj(1) = qi(1)*uind(1,j)+qi(4)*uind(2,j)+qi(7)*uind(3,j)
               qiuj(2) = qi(2)*uind(1,j)+qi(5)*uind(2,j)+qi(8)*uind(3,j)
               qiuj(3) = qi(3)*uind(1,j)+qi(6)*uind(2,j)+qi(9)*uind(3,j)
               qjui(1) = qj(1)*uind(1,i)+qj(4)*uind(2,i)+qj(7)*uind(3,i)
               qjui(2) = qj(2)*uind(1,i)+qj(5)*uind(2,i)+qj(8)*uind(3,i)
               qjui(3) = qj(3)*uind(1,i)+qj(6)*uind(2,i)+qj(9)*uind(3,i)
               qiujp(1)= qi(1)*uinp(1,j)+qi(4)*uinp(2,j)+qi(7)*uinp(3,j)
               qiujp(2)= qi(2)*uinp(1,j)+qi(5)*uinp(2,j)+qi(8)*uinp(3,j)
               qiujp(3)= qi(3)*uinp(1,j)+qi(6)*uinp(2,j)+qi(9)*uinp(3,j)
               qjuip(1)= qj(1)*uinp(1,i)+qj(4)*uinp(2,i)+qj(7)*uinp(3,i)
               qjuip(2)= qj(2)*uinp(1,i)+qj(5)*uinp(2,i)+qj(8)*uinp(3,i)
               qjuip(3)= qj(3)*uinp(1,i)+qj(6)*uinp(2,i)+qj(9)*uinp(3,i)
               dixqjr(1) = di(2)*qjr(3) - di(3)*qjr(2)
               dixqjr(2) = di(3)*qjr(1) - di(1)*qjr(3)
               dixqjr(3) = di(1)*qjr(2) - di(2)*qjr(1)
               djxqir(1) = dj(2)*qir(3) - dj(3)*qir(2)
               djxqir(2) = dj(3)*qir(1) - dj(1)*qir(3)
               djxqir(3) = dj(1)*qir(2) - dj(2)*qir(1)
               uixqjr(1) = uind(2,i)*qjr(3) - uind(3,i)*qjr(2)
               uixqjr(2) = uind(3,i)*qjr(1) - uind(1,i)*qjr(3)
               uixqjr(3) = uind(1,i)*qjr(2) - uind(2,i)*qjr(1)
               ujxqir(1) = uind(2,j)*qir(3) - uind(3,j)*qir(2)
               ujxqir(2) = uind(3,j)*qir(1) - uind(1,j)*qir(3)
               ujxqir(3) = uind(1,j)*qir(2) - uind(2,j)*qir(1)
               uixqjrp(1) = uinp(2,i)*qjr(3) - uinp(3,i)*qjr(2)
               uixqjrp(2) = uinp(3,i)*qjr(1) - uinp(1,i)*qjr(3)
               uixqjrp(3) = uinp(1,i)*qjr(2) - uinp(2,i)*qjr(1)
               ujxqirp(1) = uinp(2,j)*qir(3) - uinp(3,j)*qir(2)
               ujxqirp(2) = uinp(3,j)*qir(1) - uinp(1,j)*qir(3)
               ujxqirp(3) = uinp(1,j)*qir(2) - uinp(2,j)*qir(1)
               rxqidj(1) = yji*qidj(3) - zji*qidj(2)
               rxqidj(2) = zji*qidj(1) - xji*qidj(3)
               rxqidj(3) = xji*qidj(2) - yji*qidj(1)
               rxqjdi(1) = yji*qjdi(3) - zji*qjdi(2)
               rxqjdi(2) = zji*qjdi(1) - xji*qjdi(3)
               rxqjdi(3) = xji*qjdi(2) - yji*qjdi(1)
               rxqiuj(1) = yji*qiuj(3) - zji*qiuj(2)
               rxqiuj(2) = zji*qiuj(1) - xji*qiuj(3)
               rxqiuj(3) = xji*qiuj(2) - yji*qiuj(1)
               rxqjui(1) = yji*qjui(3) - zji*qjui(2)
               rxqjui(2) = zji*qjui(1) - xji*qjui(3)
               rxqjui(3) = xji*qjui(2) - yji*qjui(1)
               rxqiujp(1) = yji*qiujp(3) - zji*qiujp(2)
               rxqiujp(2) = zji*qiujp(1) - xji*qiujp(3)
               rxqiujp(3) = xji*qiujp(2) - yji*qiujp(1)
               rxqjuip(1) = yji*qjuip(3) - zji*qjuip(2)
               rxqjuip(2) = zji*qjuip(1) - xji*qjuip(3)
               rxqjuip(3) = xji*qjuip(2) - yji*qjuip(1)
c
c     get intermediate variables for permanent energy terms
c
               sc(2) = di(1)*dj(1) + di(2)*dj(2) + di(3)*dj(3)
               sc(3) = di(1)*xji + di(2)*yji + di(3)*zji
               sc(4) = dj(1)*xji + dj(2)*yji + dj(3)*zji
               sc(5) = qir(1)*xji + qir(2)*yji + qir(3)*zji
               sc(6) = qjr(1)*xji + qjr(2)*yji + qjr(3)*zji
               sc(7) = qir(1)*dj(1) + qir(2)*dj(2) + qir(3)*dj(3)
               sc(8) = qjr(1)*di(1) + qjr(2)*di(2) + qjr(3)*di(3)
               sc(9) = qir(1)*qjr(1) + qir(2)*qjr(2) + qir(3)*qjr(3)
               sc(10) = qi(1)*qj(1) + qi(2)*qj(2) + qi(3)*qj(3)
     &                     + qi(4)*qj(4) + qi(5)*qj(5) + qi(6)*qj(6)
     &                     + qi(7)*qj(7) + qi(8)*qj(8) + qi(9)*qj(9)
c
c     get intermediate variables for induction energy;
c     interaction between induce and permanent multipoles
c     final induction energy exclude induce-induce term
c
               sci(1) = uind(1,i)*dj(1) + uind(2,i)*dj(2)
     &                     + uind(3,i)*dj(3) + di(1)*uind(1,j)
     &                     + di(2)*uind(2,j) + di(3)*uind(3,j)
               sci(2) = uind(1,i)*uind(1,j) + uind(2,i)*uind(2,j)
     &                     + uind(3,i)*uind(3,j)
               sci(3) = uind(1,i)*xji + uind(2,i)*yji + uind(3,i)*zji
               sci(4) = uind(1,j)*xji + uind(2,j)*yji + uind(3,j)*zji
               sci(7) = qir(1)*uind(1,j) + qir(2)*uind(2,j)
     &                     + qir(3)*uind(3,j)
               sci(8) = qjr(1)*uind(1,i) + qjr(2)*uind(2,i)
     &                     + qjr(3)*uind(3,i)
               scip(1) = uinp(1,i)*dj(1) + uinp(2,i)*dj(2)
     &                      + uinp(3,i)*dj(3) + di(1)*uinp(1,j)
     &                      + di(2)*uinp(2,j) + di(3)*uinp(3,j)
               scip(2) = uind(1,i)*uinp(1,j)+uind(2,i)*uinp(2,j)
     &                      + uind(3,i)*uinp(3,j)+uinp(1,i)*uind(1,j)
     &                      + uinp(2,i)*uind(2,j)+uinp(3,i)*uind(3,j)
               scip(3) = uinp(1,i)*xji + uinp(2,i)*yji + uinp(3,i)*zji
               scip(4) = uinp(1,j)*xji + uinp(2,j)*yji + uinp(3,j)*zji
               scip(7) = qir(1)*uinp(1,j) + qir(2)*uinp(2,j)
     &                      + qir(3)*uinp(3,j)
               scip(8) = qjr(1)*uinp(1,i) + qjr(2)*uinp(2,i)
     &                      + qjr(3)*uinp(3,i)
c
c     get the induced-induced term
c
               einin = sci(2)*rr3 - sci(3)*sci(4)*rr5
               findmp(1) = uscale(jj) * (scip(2)*rr3*ddsc3(1)
     &          -(sci(3)*scip(4)+scip(3)*sci(4))*rr5*ddsc5(1))*0.5d0
               findmp(2) = uscale(jj) * (scip(2)*rr3*ddsc3(2)
     &          -(sci(3)*scip(4)+scip(3)*sci(4))*rr5*ddsc5(2))*0.5d0
               findmp(3) = uscale(jj) * (scip(2)*rr3*ddsc3(3)
     &          -(sci(3)*scip(4)+scip(3)*sci(4))*rr5*ddsc5(3))*0.5d0
c
c     calculate the gl functions for potential energy
c
               gl(0) = ci*cj
               gl(1) = cj*sc(3) - ci*sc(4)
               gl(2) = ci*sc(6) + cj*sc(5) - sc(3)*sc(4)
               gl(3) = sc(3)*sc(6) - sc(4)*sc(5)
               gl(4) = sc(5)*sc(6)
               gl(6) = sc(2)
               gl(7) = 2.0d0 * (sc(7)-sc(8))
               gl(8) = 2.0d0 * sc(10)
               gl(5) = -4.0d0 * sc(9)
               gli(1) = cj*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) = cj*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     calculate energy for this interaction and increment total
c
               e = bn(0)*gl(0) + bn(1)*(gl(1)+gl(6))
     &                + bn(2)*(gl(2)+gl(7)+gl(8))
     &                + bn(3)*(gl(3)+gl(5)) + bn(4)*gl(4)
               ei = 0.5d0 * (bn(1)*(gli(1)+gli(6))
     &                      + bn(2)*(gli(2)+gli(7)) + bn(3)*gli(3))
c
c    real energy without screening function
c
               erl = rr1*gl(0) + rr3*(gl(1)+gl(6))
     &                  + rr5*(gl(2)+gl(7)+gl(8))
     &                  + rr7*(gl(3)+gl(5)) + rr9*gl(4)
               erli = 0.5d0*(rr3*(gli(1)+gli(6))*psc3
     &                   + rr5*(gli(2)+gli(7))*psc5
     &                   + rr7*gli(3)*psc7)
               fridmp(1) = 0.5d0*(rr3*((gli(1)+gli(6))*pscale(jj)
     &           + (glip(1)+glip(6))*dscale(jj))*ddsc3(1)
     &           + rr5*((gli(2)+gli(7))*pscale(jj)
     &           + (glip(2)+glip(7))*dscale(jj))*ddsc5(1)
     &           + rr7*(gli(3)*pscale(jj)+glip(3)*dscale(jj))*ddsc7(1))
               fridmp(2) = 0.5d0*(rr3*((gli(1)+gli(6))*pscale(jj)
     &           + (glip(1)+glip(6))*dscale(jj))*ddsc3(2)
     &           + rr5*((gli(2)+gli(7))*pscale(jj)
     &           + (glip(2)+glip(7))*dscale(jj))*ddsc5(2)
     &           + rr7*(gli(3)*pscale(jj)+glip(3)*dscale(jj))*ddsc7(2))
               fridmp(3) = 0.5d0*(rr3*((gli(1)+gli(6))*pscale(jj)
     &           + (glip(1)+glip(6))*dscale(jj))*ddsc3(3)
     &           + rr5*((gli(2)+gli(7))*pscale(jj)
     &           + (glip(2)+glip(7))*dscale(jj))*ddsc5(3)
     &           + rr7*(gli(3)*pscale(jj)+glip(3)*dscale(jj))*ddsc7(3))
               e = e - (1.0d0-mscale(jj))*erl
               ei = ei - erli
               e = f * e
               ei = f * ei
               em = em + e
               ep = ep + ei
c
c     increment the intramolecular energy if appropriate;
c     assumes intramolecular distances are less than half
c     of cell length and less than the ewald cutoff
c
               if (molcule(ii) .eq. molcule(jj)) then
                  eintra = eintra + mscale(jj)*erl*f
                  eintra = eintra + 0.5d0*pscale(jj)
     &                        * (rr3*(gli(1)+gli(6))*scale3
     &                              + rr5*(gli(2)+gli(7))*scale5
     &                              + rr7*gli(3)*scale7)
               end if
c
c     intermediate variables for permanent multipole force terms
c
               gf(1) = bn(1)*gl(0) + bn(2)*(gl(1)+gl(6))
     &                    + bn(3)*(gl(2)+gl(7)+gl(8))
     &                    + bn(4)*(gl(3)+gl(5)) + bn(5)*gl(4)
               gf(2) = -cj*bn(1) + sc(4)*bn(2) - sc(6)*bn(3)
               gf(3) = ci*bn(1) + sc(3)*bn(2) + sc(5)*bn(3)
               gf(4) = 2.0d0 * bn(2)
               gf(5) = 2.0d0 * (-cj*bn(2)+sc(4)*bn(3)-sc(6)*bn(4))
               gf(6) = 2.0d0 * (-ci*bn(2)-sc(3)*bn(3)-sc(5)*bn(4))
               gf(7) = 4.0d0 * bn(3)
               gfr(1) = rr3*gl(0) + rr5*(gl(1)+gl(6))
     &                     + rr7*(gl(2)+gl(7)+gl(8))
     &                     + rr9*(gl(3)+gl(5)) + rr11*gl(4)
               gfr(2) = -cj*rr3 + sc(4)*rr5 - sc(6)*rr7
               gfr(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7
               gfr(4) = 2.0d0 * rr5
               gfr(5) = 2.0d0 * (-cj*rr5+sc(4)*rr7-sc(6)*rr9)
               gfr(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9)
               gfr(7) = 4.0d0 * rr7
c
c     get the induced-permanent term
c
               gfi(1) = bn(2)*(gli(1)+glip(1)+gli(6)+glip(6))*0.5d0
     &                + bn(2)* scip(2)*0.5d0
     &                + bn(3)*(gli(2)+glip(2)+gli(7)+glip(7))*0.5d0
     &                - bn(3)*0.5d0*(sci(3)*scip(4)+scip(3)*sci(4))
     &                + bn(4)*(gli(3)+glip(3))*0.5d0
               gfi(2) = -cj*bn(1) + sc(4)*bn(2) - sc(6)*bn(3)
               gfi(3) = ci*bn(1) + sc(3)*bn(2) + sc(5)*bn(3)
               gfi(4) = 2.0d0 * bn(2)
               gfi(5) = (sci(4) + scip(4))*bn(3)
               gfi(6) = -(sci(3) + scip(3))*bn(3)
               gfri(1) = rr5*0.5d0*((gli(1)+gli(6))*psc3 
     &             + (glip(1)+glip(6))*dsc3 + scip(2)*ruscale3)
     &             + rr7*((gli(7)+gli(2))*psc5 + (glip(7)+glip(2))*dsc5
     &             - (sci(3)*scip(4)+scip(3)*sci(4))*ruscale5)*0.5d0
     &             + rr9*(gli(3)*psc7+glip(3)*dsc7)*0.5d0
               gfri(2) = -rr3*cj + rr5*sc(4) - rr7*sc(6)
               gfri(3) = rr3*ci + rr5*sc(3) + rr7*sc(5)
               gfri(4) = 2.0d0 * rr5 
               gfri(5) = rr7 * (sci(4)*psc7 + scip(4)*dsc7)
               gfri(6) = -rr7 * (sci(3)*psc7 + scip(3)*dsc7)
c
c       get the induced-induced terms for direct versus mutual
c
               gfdr = 0.5d0 * (rr5*scip(2)*ruscale3
     &                  - rr7*(scip(3)*sci(4)
     &                        +sci(3)*scip(4))*ruscale5)
               gfd = 0.5d0 * (bn(2)*scip(2)
     &                  - bn(3)*(scip(3)*sci(4)+sci(3)*scip(4)))
c
c     get the unscreened induced force components
c
               ftm2ri(1) = gfri(1)*xji + 0.5d0*
     &          (- rr3*cj*(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,j)*psc3+uinp(1,j)*dsc3)
     &           + rr5*sc(3)*(uind(1,j)*psc5+uinp(1,j)*dsc5)
     &           + rr7*sc(5)*(uind(1,j)*psc7+uinp(1,j)*dsc7))*0.5d0
     &           + rr5*ruscale5*(sci(4)*uinp(1,i)+scip(4)*uind(1,i)
     &           + sci(3)*uinp(1,j)+scip(3)*uind(1,j))*0.5d0
     &           + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1)
     &           + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dj(1)
     &           + 0.5d0*gfri(4)*((qjui(1)-qiuj(1))*psc5
     &           + (qjuip(1)-qiujp(1))*dsc5)
     &           + gfri(5)*qir(1) + gfri(6)*qjr(1)
               ftm2ri(2) = gfri(1)*yji + 0.5d0*
     &          (- rr3*cj*(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,j)*psc3+uinp(2,j)*dsc3)
     &           + rr5*sc(3)*(uind(2,j)*psc5+uinp(2,j)*dsc5)
     &           + rr7*sc(5)*(uind(2,j)*psc7+uinp(2,j)*dsc7))*0.5d0
     &           + rr5*ruscale5*(sci(4)*uinp(2,i)+scip(4)*uind(2,i)
     &           + sci(3)*uinp(2,j)+scip(3)*uind(2,j))*0.5d0
     &           + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2)
     &           + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dj(2)
     &           + 0.5d0*gfri(4)*((qjui(2)-qiuj(2))*psc5
     &           + (qjuip(2)-qiujp(2))*dsc5)
     &           + gfri(5)*qir(2) + gfri(6)*qjr(2)
               ftm2ri(3) = gfri(1)*zji  + 0.5d0*
     &          (- rr3*cj*(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,j)*psc3+uinp(3,j)*dsc3)
     &           + rr5*sc(3)*(uind(3,j)*psc5+uinp(3,j)*dsc5)
     &           + rr7*sc(5)*(uind(3,j)*psc7+uinp(3,j)*dsc7))*0.5d0
     &           + rr5*ruscale5*(sci(4)*uinp(3,i)+scip(4)*uind(3,i)
     &           + sci(3)*uinp(3,j)+scip(3)*uind(3,j))*0.5d0
     &           + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3)
     &           + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dj(3)
     &           + 0.5d0*gfri(4)*((qjui(3)-qiuj(3))*psc5
     &           + (qjuip(3)-qiujp(3))*dsc5)
     &           + gfri(5)*qir(3) + gfri(6)*qjr(3)
c
c     get the real-space induced force
c
               ftm2i(1)=gfi(1)*xji + 0.5d0*(gfi(2)*(uind(1,i)+uinp(1,i))
     &              + bn(2)*(sci(4)*uinp(1,i)+scip(4)*uind(1,i))
     &              + gfi(3)*(uind(1,j)+uinp(1,j)) 
     &              + bn(2)*(sci(3)*uinp(1,j)+scip(3)*uind(1,j))
     &              + (sci(4)+scip(4))*bn(2)*di(1)
     &              + (sci(3)+scip(3))*bn(2)*dj(1)
     &              + gfi(4)*(qjui(1)+qjuip(1)-qiuj(1)-qiujp(1)))
     &              + gfi(5)*qir(1) + gfi(6)*qjr(1)
               ftm2i(2)=gfi(1)*yji + 0.5d0*(gfi(2)*(uind(2,i)+uinp(2,i))
     &              + bn(2)*(sci(4)*uinp(2,i)+scip(4)*uind(2,i))
     &              + gfi(3)*(uind(2,j)+uinp(2,j)) 
     &              + bn(2)*(sci(3)*uinp(2,j)+scip(3)*uind(2,j))
     &              + (sci(4)+scip(4))*bn(2)*di(2)
     &              + (sci(3)+scip(3))*bn(2)*dj(2) 
     &              + gfi(4)*(qjui(2)+qjuip(2)-qiuj(2)-qiujp(2)))
     &              + gfi(5)*qir(2) + gfi(6)*qjr(2)
               ftm2i(3)=gfi(1)*zji + 0.5d0*(gfi(2)*(uind(3,i)+uinp(3,i))
     &              + bn(2)*(sci(4)*uinp(3,i)+scip(4)*uind(3,i))
     &              + gfi(3)*(uind(3,j)+uinp(3,j)) 
     &              + bn(2)*(sci(3)*uinp(3,j)+scip(3)*uind(3,j))
     &              + (sci(4)+scip(4))*bn(2)*di(3)
     &              + (sci(3)+scip(3))*bn(2)*dj(3) 
     &              + gfi(4)*(qjui(3)+qjuip(3)-qiuj(3)-qiujp(3)))
     &              + gfi(5)*qir(3) + gfi(6)*qjr(3)
c
c     get the real permanent force without screening function
c
               ftm2r(1) = gfr(1)*xji + gfr(2)*di(1) + gfr(3)*dj(1)
     &                     + gfr(4)*(qjdi(1)-qidj(1)) + gfr(5)*qir(1)
     &                     + gfr(6)*qjr(1) + gfr(7)*(qiqjr(1)+qjqir(1))
               ftm2r(2) = gfr(1)*yji + gfr(2)*di(2) + gfr(3)*dj(2)
     &                     + gfr(4)*(qjdi(2)-qidj(2)) + gfr(5)*qir(2)
     &                     + gfr(6)*qjr(2) + gfr(7)*(qiqjr(2)+qjqir(2))
               ftm2r(3) = gfr(1)*zji + gfr(2)*di(3) + gfr(3)*dj(3)
     &                     + gfr(4)*(qjdi(3)-qidj(3)) + gfr(5)*qir(3)
     &                     + gfr(6)*qjr(3) + gfr(7)*(qiqjr(3)+qjqir(3))
c
c     get the real-space permanent force
c
               ftm2(1) = gf(1)*xji + gf(2)*di(1) + gf(3)*dj(1)
     &                      + gf(4)*(qjdi(1)-qidj(1)) + gf(5)*qir(1)
     &                      + gf(6)*qjr(1) + gf(7)*(qiqjr(1)+qjqir(1))
               ftm2(2) = gf(1)*yji + gf(2)*di(2) + gf(3)*dj(2)
     &                      + gf(4)*(qjdi(2)-qidj(2)) + gf(5)*qir(2)
     &                      + gf(6)*qjr(2) + gf(7)*(qiqjr(2)+qjqir(2))
               ftm2(3) = gf(1)*zji + gf(2)*di(3) + gf(3)*dj(3)
     &                      + gf(4)*(qjdi(3)-qidj(3)) + gf(5)*qir(3)
     &                      + gf(6)*qjr(3) + gf(7)*(qiqjr(3)+qjqir(3))
               if (poltyp .eq. 'DIRECT') then
                  ftm2i(1) = ftm2i(1) - gfd*xji - 0.5d0*
     &               (bn(2)*(sci(4)*uinp(1,i)+scip(4)*uind(1,i))
     &               + bn(2)*(sci(3)*uinp(1,j)+scip(3)*uind(1,j)))
                  ftm2i(2) = ftm2i(2) - gfd*yji -0.5d0*
     &               (bn(2)*(sci(4)*uinp(2,i)+scip(4)*uind(2,i))
     &               + bn(2)*(sci(3)*uinp(2,j)+scip(3)*uind(2,j)))
                  ftm2i(3) = ftm2i(3) - gfd*zji -0.5d0*
     &               (bn(2)*(sci(4)*uinp(3,i)+scip(4)*uind(3,i))
     &               + bn(2)*(sci(3)*uinp(3,j)+scip(3)*uind(3,j)))
                  fdir(1) = gfdr*xji + 0.5d0*ruscale5*rr5*
     &               (sci(4)*uinp(1,i)+scip(4)*uind(1,i)
     &               + sci(3)*uinp(1,j)+scip(3)*uind(1,j))
                  fdir(2) = gfdr*yji + 0.5d0*ruscale5*rr5*
     &               (sci(4)*uinp(2,i)+scip(4)*uind(2,i)
     &               + sci(3)*uinp(2,j)+scip(3)*uind(2,j))
                  fdir(3) = gfdr*zji + 0.5d0*ruscale5*rr5*
     &               (sci(4)*uinp(3,i)+scip(4)*uind(3,i)
     &               + sci(3)*uinp(3,j)+scip(3)*uind(3,j))
               end if
c
c     handle of scaling for partially excluded interactions
c
               ftm2(1) = ftm2(1) - (1.0d0-mscale(jj))*ftm2r(1)
               ftm2(2) = ftm2(2) - (1.0d0-mscale(jj))*ftm2r(2)
               ftm2(3) = ftm2(3) - (1.0d0-mscale(jj))*ftm2r(3)
               ftm2i(1) = ftm2i(1) - ftm2ri(1) - fridmp(1) - findmp(1)
               ftm2i(2) = ftm2i(2) - ftm2ri(2) - fridmp(2) - findmp(2)
               ftm2i(3) = ftm2i(3) - ftm2ri(3) - fridmp(3) - findmp(3)
               if (poltyp .eq. 'DIRECT') then
                  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     now perform the torque calculation
c     intermediate terms for torque between multipoles i and j
c
               gtri(2) = 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5
               gtri(3) = 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5
               gtri(4) = gfri(4)
               gtri(5) = gfri(5)
               gtri(6) = gfri(6)
               gti(2) = 0.5d0*(sci(4)+scip(4))*bn(2)
               gti(3) = 0.5d0*(sci(3)+scip(3))*bn(2)
               gti(4) = gfi(4)
               gti(5) = gfi(5)
               gti(6) = gfi(6)
c
c     get the unscreened induced torque
c
               ttm2ri(1) = -rr3*(dixuj(1)*psc3+dixujp(1)*dsc3)*0.5d0
     &           + gtri(2)*dixr(1) + gtri(4)*((ujxqir(1)+rxqiuj(1))*psc5
     &           +(ujxqirp(1)+rxqiujp(1))*dsc5)*0.5d0 - gtri(5)*rxqir(1)
               ttm2ri(2) = -rr3*(dixuj(2)*psc3+dixujp(2)*dsc3)*0.5d0
     &           + gtri(2)*dixr(2) + gtri(4)*((ujxqir(2)+rxqiuj(2))*psc5
     &           +(ujxqirp(2)+rxqiujp(2))*dsc5)*0.5d0 - gtri(5)*rxqir(2)
               ttm2ri(3) = -rr3*(dixuj(3)*psc3+dixujp(3)*dsc3)*0.5d0
     &           + gtri(2)*dixr(3) + gtri(4)*((ujxqir(3)+rxqiuj(3))*psc5
     &           +(ujxqirp(3)+rxqiujp(3))*dsc5)*0.5d0 - gtri(5)*rxqir(3)
               ttm3ri(1) = -rr3*(djxui(1)*psc3+djxuip(1)*dsc3)*0.5d0
     &           + gtri(3)*djxr(1) - gtri(4)*((uixqjr(1)+rxqjui(1))*psc5
     &           +(uixqjrp(1)+rxqjuip(1))*dsc5)*0.5d0 - gtri(6)*rxqjr(1)
               ttm3ri(2) = -rr3*(djxui(2)*psc3+djxuip(2)*dsc3)*0.5d0
     &           + gtri(3)*djxr(2) - gtri(4)*((uixqjr(2)+rxqjui(2))*psc5
     &           +(uixqjrp(2)+rxqjuip(2))*dsc5)*0.5d0 - gtri(6)*rxqjr(2)
               ttm3ri(3) = -rr3*(djxui(3)*psc3+djxuip(3)*dsc3)*0.5d0
     &           + gtri(3)*djxr(3) - gtri(4)*((uixqjr(3)+rxqjui(3))*psc5
     &           +(uixqjrp(3)+rxqjuip(3))*dsc5)*0.5d0 - gtri(6)*rxqjr(3)
c
c     get the real-space induced torque
c
               ttm2i(1) = -bn(1)*(dixuj(1)+dixujp(1))*0.5d0
     &              + gti(2)*dixr(1) + gti(4)*(ujxqir(1)+rxqiuj(1)
     &              + ujxqirp(1)+rxqiujp(1))*0.5d0 - gti(5)*rxqir(1)
               ttm2i(2) = -bn(1)*(dixuj(2)+dixujp(2))*0.5d0
     &              + gti(2)*dixr(2) + gti(4)*(ujxqir(2)+rxqiuj(2)
     &              + ujxqirp(2)+rxqiujp(2))*0.5d0 - gti(5)*rxqir(2)
               ttm2i(3) = -bn(1)*(dixuj(3)+dixujp(3))*0.5d0
     &              + gti(2)*dixr(3) + gti(4)*(ujxqir(3)+rxqiuj(3)
     &              + ujxqirp(3)+rxqiujp(3))*0.5d0 - gti(5)*rxqir(3)
               ttm3i(1) = -bn(1)*(djxui(1)+djxuip(1))*0.5d0 
     &              + gti(3)*djxr(1) - gti(4)*(uixqjr(1)+rxqjui(1)
     &              + uixqjrp(1)+rxqjuip(1))*0.5d0 - gti(6)*rxqjr(1)
               ttm3i(2) = -bn(1)*(djxui(2)+djxuip(2))*0.5d0 
     &              + gti(3)*djxr(2) - gti(4)*(uixqjr(2)+rxqjui(2)
     &              + uixqjrp(2)+rxqjuip(2))*0.5d0 - gti(6)*rxqjr(2)
               ttm3i(3) = -bn(1)*(djxui(3)+djxuip(3))*0.5d0
     &              + gti(3)*djxr(3) - gti(4)*(uixqjr(3)+rxqjui(3)
     &              + uixqjrp(3)+rxqjuip(3))*0.5d0 - gti(6)*rxqjr(3)
c
c     get the real-space permanent torques
c
               ttm2(1) = -bn(1)*dixdj(1) + gf(2)*dixr(1)
     &            + gf(4)*(dixqjr(1)+djxqir(1)+rxqidj(1)-2.0d0*qixqj(1))
     &            - gf(5)*rxqir(1) - gf(7)*(rxqijr(1)+qjrxqir(1))
               ttm2(2) = -bn(1)*dixdj(2) + gf(2)*dixr(2)
     &            + gf(4)*(dixqjr(2)+djxqir(2)+rxqidj(2)-2.0d0*qixqj(2))
     &            - gf(5)*rxqir(2) - gf(7)*(rxqijr(2)+qjrxqir(2))
               ttm2(3) = -bn(1)*dixdj(3) + gf(2)*dixr(3)
     &            + gf(4)*(dixqjr(3)+djxqir(3)+rxqidj(3)-2.0d0*qixqj(3))
     &            - gf(5)*rxqir(3) - gf(7)*(rxqijr(3)+qjrxqir(3))
               ttm3(1) = bn(1)*dixdj(1) + gf(3)*djxr(1)
     &            - gf(4)*(dixqjr(1)+djxqir(1)+rxqjdi(1)-2.0d0*qixqj(1))
     &            - gf(6)*rxqjr(1) - gf(7)*(rxqjir(1)-qjrxqir(1))
               ttm3(2) = bn(1)*dixdj(2) + gf(3)*djxr(2)
     &            - gf(4)*(dixqjr(2)+djxqir(2)+rxqjdi(2)-2.0d0*qixqj(2))
     &            - gf(6)*rxqjr(2) - gf(7)*(rxqjir(2)-qjrxqir(2))
               ttm3(3) = bn(1)*dixdj(3) +gf(3)*djxr(3)
     &            - gf(4)*(dixqjr(3)+djxqir(3)+rxqjdi(3)-2.0d0*qixqj(3))
     &            - gf(6)*rxqjr(3) - gf(7)*(rxqjir(3)-qjrxqir(3))
c
c     get the real permanent torques
c
               ttm2r(1) = -rr3*dixdj(1) + gfr(2)*dixr(1)-gfr(5)*rxqir(1)
     &           + gfr(4)*(dixqjr(1)+djxqir(1)+rxqidj(1)-2.0d0*qixqj(1))
     &           - gfr(7)*(rxqijr(1)+qjrxqir(1))
               ttm2r(2) = -rr3*dixdj(2) + gfr(2)*dixr(2)-gfr(5)*rxqir(2)
     &           + gfr(4)*(dixqjr(2)+djxqir(2)+rxqidj(2)-2.0d0*qixqj(2))
     &           - gfr(7)*(rxqijr(2)+qjrxqir(2))
               ttm2r(3) = -rr3*dixdj(3) + gfr(2)*dixr(3)-gfr(5)*rxqir(3)
     &           + gfr(4)*(dixqjr(3)+djxqir(3)+rxqidj(3)-2.0d0*qixqj(3))
     &           - gfr(7)*(rxqijr(3)+qjrxqir(3))
               ttm3r(1) = rr3*dixdj(1) + gfr(3)*djxr(1) -gfr(6)*rxqjr(1)
     &           - gfr(4)*(dixqjr(1)+djxqir(1)+rxqjdi(1)-2.0d0*qixqj(1))
     &           - gfr(7)*(rxqjir(1)-qjrxqir(1))
               ttm3r(2) = rr3*dixdj(2) + gfr(3)*djxr(2) -gfr(6)*rxqjr(2)
     &           - gfr(4)*(dixqjr(2)+djxqir(2)+rxqjdi(2)-2.0d0*qixqj(2))
     &           - gfr(7)*(rxqjir(2)-qjrxqir(2))
               ttm3r(3) = rr3*dixdj(3) + gfr(3)*djxr(3) -gfr(6)*rxqjr(3)
     &           - gfr(4)*(dixqjr(3)+djxqir(3)+rxqjdi(3)-2.0d0*qixqj(3))
     &           - gfr(7)*(rxqjir(3)-qjrxqir(3))
c
c     handle the case where scaling is used
c
               ttm2(1) = ttm2(1) - ttm2r(1) * (1.0d0-mscale(jj))
               ttm2(2) = ttm2(2) - ttm2r(2) * (1.0d0-mscale(jj))
               ttm2(3) = ttm2(3) - ttm2r(3) * (1.0d0-mscale(jj))
               ttm3(1) = ttm3(1) - ttm3r(1) * (1.0d0-mscale(jj))
               ttm3(2) = ttm3(2) - ttm3r(2) * (1.0d0-mscale(jj))
               ttm3(3) = ttm3(3) - ttm3r(3) * (1.0d0-mscale(jj))
               ttm2i(1) = ttm2i(1) - ttm2ri(1)
               ttm2i(2) = ttm2i(2) - ttm2ri(2)
               ttm2i(3) = ttm2i(3) - ttm2ri(3)
               ttm3i(1) = ttm3i(1) - ttm3ri(1)
               ttm3i(2) = ttm3i(2) - ttm3ri(2)
               ttm3i(3) = ttm3i(3) - ttm3ri(3)
c
c     now compute the virial components for this interaction
c
               do k = 1, 3
                  frczi(k) = 0.0d0
                  frcxi(k) = 0.0d0
                  frczj(k) = 0.0d0
                  frcxj(k) = 0.0d0
               end do
               xiz = x(zaxis(i)) - x(ii)
               yiz = y(zaxis(i)) - y(ii)
               ziz = z(zaxis(i)) - z(ii)
               xix = x(xaxis(i)) - x(ii)
               yix = y(xaxis(i)) - y(ii)
               zix = z(xaxis(i)) - z(ii)
               xjz = x(zaxis(j)) - x(jj)
               yjz = y(zaxis(j)) - y(jj)
               zjz = z(zaxis(j)) - z(jj)
               xjx = x(xaxis(j)) - x(jj)
               yjx = y(xaxis(j)) - y(jj)
               zjx = z(xaxis(j)) - z(jj)
               do k = 1, 3
                  tq(k) = ttm2(k) + ttm2i(k)
               end do
               call torque1 (i,tq,frczi,frcxi)
               do k = 1, 3
                  tq(k) = ttm3(k) + ttm3i(k)
               end do
               call torque1 (j,tq,frczj,frcxj)
               vx = -xji*(ftm2(1)+ftm2i(1)) + xix*frcxi(1)
     &                 + xjz*frczj(1) + xjx*frcxj(1) + xiz*frczi(1)
               vy = -yji*(ftm2(2)+ftm2i(2)) + yix*frcxi(2)
     &                 + yjz*frczj(2) + yjx*frcxj(2) + yiz*frczi(2)
               vz = -zji*(ftm2(3)+ftm2i(3)) + zix*frcxi(3)
     &                 + zjz*frczj(3) + zjx*frcxj(3) + ziz*frczi(3)
               virx = virx + f*vx
               viry = viry + f*vy
               virz = virz + f*vz
c
c     update force and torque on site j
c
               ftm1(1,j) = ftm1(1,j) + ftm2(1)
               ftm1(2,j) = ftm1(2,j) + ftm2(2)
               ftm1(3,j) = ftm1(3,j) + ftm2(3)
               ttm1(1,j) = ttm1(1,j) + ttm3(1)
               ttm1(2,j) = ttm1(2,j) + ttm3(2)
               ttm1(3,j) = ttm1(3,j) + ttm3(3)
               ftm1i(1,j) = ftm1i(1,j) + ftm2i(1)
               ftm1i(2,j) = ftm1i(2,j) + ftm2i(2)
               ftm1i(3,j) = ftm1i(3,j) + ftm2i(3)
               ttm1i(1,j) = ttm1i(1,j) + ttm3i(1)
               ttm1i(2,j) = ttm1i(2,j) + ttm3i(2)
               ttm1i(3,j) = ttm1i(3,j) + ttm3i(3)
c
c     update force and torque on site i
c
               ftm1(1,i) = ftm1(1,i) - ftm2(1)
               ftm1(2,i) = ftm1(2,i) - ftm2(2)
               ftm1(3,i) = ftm1(3,i) - ftm2(3)
               ttm1(1,i) = ttm1(1,i) + ttm2(1)
               ttm1(2,i) = ttm1(2,i) + ttm2(2)
               ttm1(3,i) = ttm1(3,i) + ttm2(3)
               ftm1i(1,i) = ftm1i(1,i) - ftm2i(1)
               ftm1i(2,i) = ftm1i(2,i) - ftm2i(2)
               ftm1i(3,i) = ftm1i(3,i) - ftm2i(3)
               ttm1i(1,i) = ttm1i(1,i) + ttm2i(1)
               ttm1i(2,i) = ttm1i(2,i) + ttm2i(2)
               ttm1i(3,i) = ttm1i(3,i) + ttm2i(3)
            end if
         end do
      end do
c
c     increment the total forces and torques
c
      do i = 1, npole
         ii = ipole(i)
         dem(1,ii) = dem(1,ii) - f*ftm1(1,i)
         dem(2,ii) = dem(2,ii) - f*ftm1(2,i)
         dem(3,ii) = dem(3,ii) - f*ftm1(3,i)
         dep(1,ii) = dep(1,ii) - f*ftm1i(1,i)
         dep(2,ii) = dep(2,ii) - f*ftm1i(2,i)
         dep(3,ii) = dep(3,ii) - f*ftm1i(3,i)
         trq(1,ii) = trq(1,ii) + f*ttm1(1,i)
         trq(2,ii) = trq(2,ii) + f*ttm1(2,i)
         trq(3,ii) = trq(3,ii) + f*ttm1(3,i)
         trqi(1,ii) = trqi(1,ii) + f*ttm1i(1,i)
         trqi(2,ii) = trqi(2,ii) + f*ttm1i(2,i)
         trqi(3,ii) = trqi(3,ii) + f*ttm1i(3,i)
      end do
      call torque (trq,dem)
      call torque (trqi,dep)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine torque  --  convert multipole torque to force  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "torque" takes the torque values on sites defined by local
c     coordinate frames and distributes thme to convert to forces
c     on the original sites and sites specifying the local frames
c
c     literature reference:
c
c     A. J. Stone and M. Alderton, "Distributed Multipole Analysis -
c     Methods and Applications", Molecular Physics, 56, 1047-1064 (1985)
c
c
      subroutine torque (trq,derivs)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'mpole.i'
      integer i,j,ia,ib,ic
      real*8 usiz,vsiz,wsiz
      real*8 upsiz,vpsiz
      real*8 dotdu,dotdv
      real*8 dphidu,dphidv,dphidw
      real*8 c,s,uvdis,vudis,du,dv
      real*8 u(3),v(3),w(3)
      real*8 up(3),vp(3),diff(3)
      real*8 trq(3,maxatm)
      real*8 derivs(3,maxatm)
c
c
c     coordinate frame motion described by rotation about u, v and w
c
      do i = 1, npole
         ia = zaxis(i)
         ib = ipole(i)
         ic = xaxis(i)
         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))
         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))
         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)
         wsiz = sqrt(w(1)*w(1) + w(2)*w(2) + w(3)*w(3))
         dotdu = 0.0d0
         dotdv = 0.0d0
         do j = 1, 3
            u(j) = u(j) / usiz
            v(j) = v(j) / vsiz
            w(j) = w(j) / wsiz
            diff(j) = v(j) - u(j)
            dotdu = dotdu + u(j)*diff(j)
            dotdv = dotdv + v(j)*diff(j)
         end do
c
c     get perpendiculars to u,v to get direction of motion of
c     u or v due to rotation about the cross product vector w
c
         upsiz = 0.0d0
         vpsiz = 0.0d0
         do j = 1, 3
            up(j) = diff(j) - dotdu*u(j)
            vp(j) = diff(j) - dotdv*v(j)
            upsiz = upsiz + up(j)*up(j)
            vpsiz = vpsiz + vp(j)*vp(j)
         end do
         upsiz = sqrt(upsiz)
         vpsiz = sqrt(vpsiz)
         do j = 1, 3
            up(j) = up(j) / upsiz
            vp(j) = vp(j) / vpsiz
         end do
c
c     negative of dot product of torque with unit vectors along u, v
c     and w give result of infinitesmal rotation along these vectors
c     i.e. dphi/dtheta = dot product, where dphi is work, dtheta is
c     angle; then dphi/dtheta is torque and the dot product is torque
c     component along unit vector
c
         dphidu = -trq(1,ib)*u(1) - trq(2,ib)*u(2) - trq(3,ib)*u(3)
         dphidv = -trq(1,ib)*v(1) - trq(2,ib)*v(2) - trq(3,ib)*v(3)
         dphidw = -trq(1,ib)*w(1) - trq(2,ib)*w(2) - trq(3,ib)*w(3)
c
c     get the projected distances between the vectors
c
         c = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)
         s = sqrt(1.0d0 - c*c)
         uvdis = usiz * s
         vudis = vsiz * s
c
c     force distribution for the bisector local coordinate method
c
         if (polaxe(i) .eq. 'Bisector') then
            do j = 1, 3
               du = -w(j)*dphidv/uvdis + up(j)*dphidw/(2.0d0*usiz)
               dv = w(j)*dphidu/vudis + vp(j)*dphidw/(2.0d0*vsiz)
               derivs(j,ia) = derivs(j,ia) + du
               derivs(j,ic) = derivs(j,ic) + dv
               derivs(j,ib) = derivs(j,ib) - dv - du
            end do
c
c     force distribution for the Z-then-X local coordinate method
c
         else if (polaxe(i) .eq. 'Z-then-X') then
            do j = 1, 3
               du = -w(j)*dphidv/uvdis + up(j)*dphidw/usiz
               dv = w(j)*dphidu/vudis
               derivs(j,ia) = derivs(j,ia) + du
               derivs(j,ic) = derivs(j,ic) + dv
               derivs(j,ib) = derivs(j,ib) - dv - du
            end do
         end if
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine torque1  --  convert torque to force; 1-site  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "torque1" takes the torque value on a site defined by a local
c     coordinate frame and distributes it to convert to forces on
c     the original site and sites specifying the local frame
c
c     literature reference:
c
c     A. J. Stone and M. Alderton, "Distributed Multipole Analysis -
c     Methods and Applications", Molecular Physics, 56, 1047-1064 (1985)
c
c
      subroutine torque1 (i,trq,frcz,frcx)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'mpole.i'
      integer i,j,ia,ib,ic
      real*8 usiz,vsiz,wsiz
      real*8 upsiz,vpsiz
      real*8 dotdu,dotdv
      real*8 dphidu,dphidv,dphidw
      real*8 c,s,uvdis,vudis
      real*8 u(3),v(3),w(3)
      real*8 up(3),vp(3)
      real*8 trq(3),diff(3)
      real*8 frcz(3),frcx(3)
c
c
c     coordinate frame motion described by rotation about u, v and w
c
      ia = zaxis(i)
      ib = ipole(i)
      ic = xaxis(i)
      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))
      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))
      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)
      wsiz = sqrt(w(1)*w(1) + w(2)*w(2) + w(3)*w(3))
      dotdu = 0.0d0
      dotdv = 0.0d0
      do j = 1, 3
         u(j) = u(j) / usiz
         v(j) = v(j) / vsiz
         w(j) = w(j) / wsiz
         diff(j) = v(j) - u(j)
         dotdu = dotdu + u(j)*diff(j)
         dotdv = dotdv + v(j)*diff(j)
      end do
c
c     get perpendiculars to u,v to get direction of motion of
c     u or v due to rotation about the cross product vector w
c
      upsiz = 0.0d0
      vpsiz = 0.0d0
      do j = 1, 3
         up(j) = diff(j) - dotdu*u(j)
         vp(j) = diff(j) - dotdv*v(j)
         upsiz = upsiz + up(j)*up(j)
         vpsiz = vpsiz + vp(j)*vp(j)
      end do
      upsiz = sqrt(upsiz)
      vpsiz = sqrt(vpsiz)
      do j = 1, 3
         up(j) = up(j) / upsiz
         vp(j) = vp(j) / vpsiz
      end do
c
c     negative of dot product of torque with unit vectors along u, v
c     and w give result of infinitesmal rotation along these vectors
c     i.e. dphi/dtheta = dot product, where dphi is work, dtheta is
c     angle; then dphi/dtheta is torque and the dot product is torque
c     component along unit vector
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)
c
c     get the projected distances between the vectors
c
      c = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)
      s = sqrt(1.0d0 - c*c)
      uvdis = usiz * s
      vudis = vsiz * s
c
c     force distribution for the bisector local coordinate method
c
      if (polaxe(i) .eq. 'Bisector') then
         do j = 1, 3
            frcz(j) = -w(j)*dphidv/uvdis + up(j)*dphidw/(2.0d0*usiz)
            frcx(j) = w(j)*dphidu/vudis + vp(j)*dphidw/(2.0d0*vsiz)
         end do
c
c     force distribution for the Z-then-X local coordinate method
c
      else
         do j = 1, 3
            frcz(j) = -w(j)*dphidv/uvdis + up(j)*dphidw/usiz
            frcx(j) = w(j)*dphidu/vudis
         end do
      end if
      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 empole2  --  multipole & polarization Hessian  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "empole2" calculates second derivatives of the multipole
c     and dipole polarization energy for a single atom at a time
c
c
      subroutine empole2 (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'hessn.i'
      include 'mpole.i'
      integer i,j,k
      integer nlist
      integer list(maxatm)
      real*8 eps,old
      real*8 d0(3,maxatm)
c
c
c     set the stepsize to be used for numerical derivatives
c
      eps = 1.0d-7
c
c     find the multipole definitions involving the current atom
c
      nlist = 0
      do k = 1, npole
         if (ipole(k).eq.i .or. zaxis(k).eq.i .or. xaxis(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
      call empole2a (nlist,list)
      do k = 1, n
         do j = 1, 3
            d0(j,k) = dem(j,k) + dep(j,k)
         end do
      end do
c
c     find numerical x-components via perturbed structures
c
      old = x(i)
      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)+dep(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical y-components via perturbed structures
c
      old = y(i)
      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)+dep(j,k)-d0(j,k))/eps
         end do
      end do
c
c     find numerical z-components via perturbed structures
c
      old = z(i)
      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)+dep(j,k)-d0(j,k))/eps
         end do
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine empole2a  --  mpole & polar Hessian; numerical  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "empole2a" computes multipole and dipole polarization first
c     derivatives for a single atom with respect to Cartesian
c     coordinates; used to get finite difference second derivatives
c
c     note that since polarization effects are many body, it is not
c     really correct to neglect interactions where "iatom" is not
c     directly involved as a multipole site or local coordinate axis;
c     however, other sites are neglected in this version via the
c     "ipart" and "kpart" checks to quickly get approximate values
c
c     also, in the current version, the induced dipoles are not
c     recomputed every time an atom is moved during computation of
c     the numerical Hessian resulting in a further approximation
c
c
      subroutine empole2a (nlist,list)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'cutoff.i'
      include 'deriv.i'
      include 'group.i'
      include 'molcul.i'
      include 'mplpot.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k
      integer ii,jj
      integer ix,iz
      integer jx,jz
      integer iii,nlist
      integer list(maxatm)
      real*8 f,fgrp
      real*8 pterm,damp
      real*8 scale3,scale5
      real*8 scale7,scale9
      real*8 scale3i,scale5i
      real*8 scale7i
      real*8 xji,yji,zji
      real*8 r,r2,rr1,rr3
      real*8 rr5,rr7,rr9,rr11
      real*8 ci,di(3),qi(9)
      real*8 cj,dj(3),qj(9)
      real*8 fridmp(3),findmp(3)
      real*8 ftm2(3),ftm2i(3)
      real*8 ttm2(3),ttm3(3)
      real*8 ttm2i(3),ttm3i(3)
      real*8 dixdj(3),dixuj(3)
      real*8 djxui(3),fdir(3)
      real*8 uixr(3),ujxr(3)
      real*8 uixqjr(3),ujxqir(3)
      real*8 qiuj(3),qjui(3)
      real*8 rxqiuj(3),rxqjui(3)
      real*8 qidj(3),qjdi(3)
      real*8 qir(3),qjr(3)
      real*8 qiqjr(3),qjqir(3)
      real*8 qixqj(3),rxqir(3)
      real*8 dixr(3),djxr(3)
      real*8 dixqjr(3),djxqir(3)
      real*8 rxqjr(3),qjrxqir(3)
      real*8 rxqijr(3),rxqjir(3)
      real*8 rxqidj(3),rxqjdi(3)
      real*8 dscale3(3),dscale5(3)
      real*8 dscale7(3),a(3,3)
      real*8 sc(10),sci(10)
      real*8 gl(0:8),gli(0:8)
      real*8 gf(0:8),gfi(0:8)
      real*8 gfd(0:8),gti(0:8)
      real*8 mscale(maxatm)
      real*8 pscale(maxatm)
      real*8 uscale(maxatm)
      real*8 ftm1(3,maxatm)
      real*8 ftm1i(3,maxatm)
      real*8 ttm1(3,maxatm)
      real*8 ttm1i(3,maxatm)
      real*8 trq(3,maxatm)
      real*8 trqi(3,maxatm)
      logical proceed,iuse,juse
c
c
c     zero out the multipole and polarization first derivatives
c
      do i = 1, n
         do j = 1, 3
            dem(j,i) = 0.0d0
            dep(j,i) = 0.0d0
         end do
      end do
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (nlist .eq. 0)  return
      f = electric / dielec
      call switch ('MPOLE')
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
c
c     compute the induced dipoles at each polarizable atom;
c     currently, we assume this was done in a calling routine
c
c     call induce
c
c     zero out local accumulation arrays for derivatives
c
      do i = 1, n
         trq(1,i) = 0.0d0
         trq(2,i) = 0.0d0
         trq(3,i) = 0.0d0
         trqi(1,i) = 0.0d0
         trqi(2,i) = 0.0d0
         trqi(3,i) = 0.0d0
      end do
c
c     initialise temporary force and torque accumulators
c
      do i = 1, npole
         do k = 1, 3
            ftm1(k,i) = 0.0d0
            ftm1i(k,i) = 0.0d0
            ttm1(k,i) = 0.0d0
            ttm1i(k,i) = 0.0d0
         end do
      end do
c
c     set scale factors for permanent multipole and induced terms
c
      do iii = 1, nlist
         i = list(iii)
         ii = ipole(i)
         iz = zaxis(i)
         ix = xaxis(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)
         iuse = (use(ii) .or. use(iz) .or. use(ix))
         do j = 1, n
            mscale(j) = 1.0d0
            pscale(j) = 1.0d0
            uscale(j) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
         do j = 1, np11(ii)
            uscale(ip11(j,ii)) = u1scale
         end do
         do j = 1, np12(ii)
            uscale(ip12(j,ii)) = u2scale
         end do
         do j = 1, np13(ii)
            uscale(ip13(j,ii)) = u3scale
         end do
         do j = 1, np14(ii)
            uscale(ip14(j,ii)) = u4scale
         end do
         do j = i+1, npole
            jj = ipole(j)
            jz = zaxis(j)
            jx = xaxis(j)
            juse = (use(jj) .or. use(jz) .or. use(jx))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,ii,jj,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (iuse .or. juse)
            if (.not. proceed)  goto 10
            cj = rpole(1,j)
            dj(1) = rpole(2,j)
            dj(2) = rpole(3,j)
            dj(3) = rpole(4,j)
            qj(1) = rpole(5,j)
            qj(2) = rpole(6,j)
            qj(3) = rpole(7,j)
            qj(4) = rpole(8,j)
            qj(5) = rpole(9,j)
            qj(6) = rpole(10,j)
            qj(7) = rpole(11,j)
            qj(8) = rpole(12,j)
            qj(9) = rpole(13,j)
            xji = x(jj) - x(ii)
            yji = y(jj) - y(ii)
            zji = z(jj) - z(ii)
            if (use_image)  call image (xji,yji,zji,0)
            r2 = xji*xji + yji*yji + zji*zji
            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
               rr11 = 9.0d0 * rr9 / r2
               scale3 = 1.0d0
               scale5 = 1.0d0
               scale7 = 1.0d0
               scale9 = 1.0d0
               do k = 1, 3
                  dscale3(k) = 0.0d0
                  dscale5(k) = 0.0d0
                  dscale7(k) = 0.0d0
               end do
c
c     apply Thole polarization damping to scale factors
c
               pterm = pdamp(i) * pdamp(j)
               if (pterm .ne. 0.0d0) then
                  damp = -pgamma * (r/pterm)**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)
                     dscale3(1) = -3.0d0*damp*exp(damp) * xji/r2
                     dscale3(2) = -3.0d0*damp*exp(damp) * yji/r2
                     dscale3(3) = -3.0d0*damp*exp(damp) * zji/r2
                     dscale5(1) = -damp * dscale3(1)
                     dscale5(2) = -damp * dscale3(2)
                     dscale5(3) = -damp * dscale3(3)
                     dscale7(1) = (-0.2d0-0.6d0*damp) * dscale5(1)
                     dscale7(2) = (-0.2d0-0.6d0*damp) * dscale5(2)
                     dscale7(3) = (-0.2d0-0.6d0*damp) * dscale5(3)
                  end if
               end if
               scale3i = scale3 * uscale(jj)
               scale5i = scale5 * uscale(jj)
               scale7i = scale7 * uscale(jj)
               scale3 = scale3 * pscale(jj)
               scale5 = scale5 * pscale(jj)
               scale7 = scale7 * pscale(jj)
               scale9 = scale9 * pscale(jj)
c
c     construct auxiliary vectors
c
               dixdj(1) = di(2)*dj(3) - di(3)*dj(2)
               dixdj(2) = di(3)*dj(1) - di(1)*dj(3)
               dixdj(3) = di(1)*dj(2) - di(2)*dj(1)
               dixuj(1) = di(2)*uind(3,j) - di(3)*uind(2,j)
               dixuj(2) = di(3)*uind(1,j) - di(1)*uind(3,j)
               dixuj(3) = di(1)*uind(2,j) - di(2)*uind(1,j)
               djxui(1) = dj(2)*uind(3,i) - dj(3)*uind(2,i)
               djxui(2) = dj(3)*uind(1,i) - dj(1)*uind(3,i)
               djxui(3) = dj(1)*uind(2,i) - dj(2)*uind(1,i)
               dixr(1) = di(2)*zji - di(3)*yji
               dixr(2) = di(3)*xji - di(1)*zji
               dixr(3) = di(1)*yji - di(2)*xji
               djxr(1) = dj(2)*zji - dj(3)*yji
               djxr(2) = dj(3)*xji - dj(1)*zji
               djxr(3) = dj(1)*yji - dj(2)*xji
               uixr(1) = uind(2,i)*zji - uind(3,i)*yji
               uixr(2) = uind(3,i)*xji - uind(1,i)*zji
               uixr(3) = uind(1,i)*yji - uind(2,i)*xji
               ujxr(1) = uind(2,j)*zji - uind(3,j)*yji
               ujxr(2) = uind(3,j)*xji - uind(1,j)*zji
               ujxr(3) = uind(1,j)*yji - uind(2,j)*xji
               qir(1) = qi(1)*xji + qi(4)*yji + qi(7)*zji
               qir(2) = qi(2)*xji + qi(5)*yji + qi(8)*zji
               qir(3) = qi(3)*xji + qi(6)*yji + qi(9)*zji
               qjr(1) = qj(1)*xji + qj(4)*yji + qj(7)*zji
               qjr(2) = qj(2)*xji + qj(5)*yji + qj(8)*zji
               qjr(3) = qj(3)*xji + qj(6)*yji + qj(9)*zji
               qiqjr(1) = qi(1)*qjr(1) + qi(4)*qjr(2) + qi(7)*qjr(3)
               qiqjr(2) = qi(2)*qjr(1) + qi(5)*qjr(2) + qi(8)*qjr(3)
               qiqjr(3) = qi(3)*qjr(1) + qi(6)*qjr(2) + qi(9)*qjr(3)
               qjqir(1) = qj(1)*qir(1) + qj(4)*qir(2) + qj(7)*qir(3)
               qjqir(2) = qj(2)*qir(1) + qj(5)*qir(2) + qj(8)*qir(3)
               qjqir(3) = qj(3)*qir(1) + qj(6)*qir(2) + qj(9)*qir(3)
               qixqj(1) = qi(2)*qj(3) + qi(5)*qj(6) + qi(8)*qj(9)
     &                       - qi(3)*qj(2) - qi(6)*qj(5) - qi(9)*qj(8)
               qixqj(2) = qi(3)*qj(1) + qi(6)*qj(4) + qi(9)*qj(7)
     &                       - qi(1)*qj(3) - qi(4)*qj(6) - qi(7)*qj(9)
               qixqj(3) = qi(1)*qj(2) + qi(4)*qj(5) + qi(7)*qj(8)
     &                       - qi(2)*qj(1) - qi(5)*qj(4) - qi(8)*qj(7)
               rxqir(1) = yji*qir(3) - zji*qir(2)
               rxqir(2) = zji*qir(1) - xji*qir(3)
               rxqir(3) = xji*qir(2) - yji*qir(1)
               rxqjr(1) = yji*qjr(3) - zji*qjr(2)
               rxqjr(2) = zji*qjr(1) - xji*qjr(3)
               rxqjr(3) = xji*qjr(2) - yji*qjr(1)
               rxqijr(1) = yji*qiqjr(3) - zji*qiqjr(2)
               rxqijr(2) = zji*qiqjr(1) - xji*qiqjr(3)
               rxqijr(3) = xji*qiqjr(2) - yji*qiqjr(1)
               rxqjir(1) = yji*qjqir(3) - zji*qjqir(2)
               rxqjir(2) = zji*qjqir(1) - xji*qjqir(3)
               rxqjir(3) = xji*qjqir(2) - yji*qjqir(1)
               qjrxqir(1) = qjr(2)*qir(3) - qjr(3)*qir(2)
               qjrxqir(2) = qjr(3)*qir(1) - qjr(1)*qir(3)
               qjrxqir(3) = qjr(1)*qir(2) - qjr(2)*qir(1)
               qidj(1) = qi(1)*dj(1) + qi(4)*dj(2) + qi(7)*dj(3)
               qidj(2) = qi(2)*dj(1) + qi(5)*dj(2) + qi(8)*dj(3)
               qidj(3) = qi(3)*dj(1) + qi(6)*dj(2) + qi(9)*dj(3)
               qjdi(1) = qj(1)*di(1) + qj(4)*di(2) + qj(7)*di(3)
               qjdi(2) = qj(2)*di(1) + qj(5)*di(2) + qj(8)*di(3)
               qjdi(3) = qj(3)*di(1) + qj(6)*di(2) + qj(9)*di(3)
               qiuj(1) = qi(1)*uind(1,j)+qi(4)*uind(2,j)+qi(7)*uind(3,j)
               qiuj(2) = qi(2)*uind(1,j)+qi(5)*uind(2,j)+qi(8)*uind(3,j)
               qiuj(3) = qi(3)*uind(1,j)+qi(6)*uind(2,j)+qi(9)*uind(3,j)
               qjui(1) = qj(1)*uind(1,i)+qj(4)*uind(2,i)+qj(7)*uind(3,i)
               qjui(2) = qj(2)*uind(1,i)+qj(5)*uind(2,i)+qj(8)*uind(3,i)
               qjui(3) = qj(3)*uind(1,i)+qj(6)*uind(2,i)+qj(9)*uind(3,i)
               dixqjr(1) = di(2)*qjr(3) - di(3)*qjr(2)
               dixqjr(2) = di(3)*qjr(1) - di(1)*qjr(3)
               dixqjr(3) = di(1)*qjr(2) - di(2)*qjr(1)
               djxqir(1) = dj(2)*qir(3) - dj(3)*qir(2)
               djxqir(2) = dj(3)*qir(1) - dj(1)*qir(3)
               djxqir(3) = dj(1)*qir(2) - dj(2)*qir(1)
               uixqjr(1) = uind(2,i)*qjr(3) - uind(3,i)*qjr(2)
               uixqjr(2) = uind(3,i)*qjr(1) - uind(1,i)*qjr(3)
               uixqjr(3) = uind(1,i)*qjr(2) - uind(2,i)*qjr(1)
               ujxqir(1) = uind(2,j)*qir(3) - uind(3,j)*qir(2)
               ujxqir(2) = uind(3,j)*qir(1) - uind(1,j)*qir(3)
               ujxqir(3) = uind(1,j)*qir(2) - uind(2,j)*qir(1)
               rxqidj(1) = yji*qidj(3) - zji*qidj(2)
               rxqidj(2) = zji*qidj(1) - xji*qidj(3)
               rxqidj(3) = xji*qidj(2) - yji*qidj(1)
               rxqjdi(1) = yji*qjdi(3) - zji*qjdi(2)
               rxqjdi(2) = zji*qjdi(1) - xji*qjdi(3)
               rxqjdi(3) = xji*qjdi(2) - yji*qjdi(1)
               rxqiuj(1) = yji*qiuj(3) - zji*qiuj(2)
               rxqiuj(2) = zji*qiuj(1) - xji*qiuj(3)
               rxqiuj(3) = xji*qiuj(2) - yji*qiuj(1)
               rxqjui(1) = yji*qjui(3) - zji*qjui(2)
               rxqjui(2) = zji*qjui(1) - xji*qjui(3)
               rxqjui(3) = xji*qjui(2) - yji*qjui(1)
c
c     get intermediate variables for permanent energy terms
c
               sc(2) = di(1)*dj(1) + di(2)*dj(2) + di(3)*dj(3)
               sc(3) = di(1)*xji + di(2)*yji + di(3)*zji
               sc(4) = dj(1)*xji + dj(2)*yji + dj(3)*zji
               sc(5) = qir(1)*xji + qir(2)*yji + qir(3)*zji
               sc(6) = qjr(1)*xji + qjr(2)*yji + qjr(3)*zji
               sc(7) = qir(1)*dj(1) + qir(2)*dj(2) + qir(3)*dj(3)
               sc(8) = qjr(1)*di(1) + qjr(2)*di(2) + qjr(3)*di(3)
               sc(9) = qir(1)*qjr(1) + qir(2)*qjr(2) + qir(3)*qjr(3)
               sc(10) = qi(1)*qj(1) + qi(2)*qj(2) + qi(3)*qj(3)
     &                     + qi(4)*qj(4) + qi(5)*qj(5) + qi(6)*qj(6)
     &                     + qi(7)*qj(7) + qi(8)*qj(8) + qi(9)*qj(9)
c
c     get intermediate variables for induction energy terms
c
               sci(1) = uind(1,i)*dj(1) + uind(2,i)*dj(2)
     &                     + uind(3,i)*dj(3) + di(1)*uind(1,j)
     &                     + di(2)*uind(2,j) + di(3)*uind(3,j)
               sci(2) = uind(1,i)*uind(1,j) + uind(2,i)*uind(2,j)
     &                     + uind(3,i)*uind(3,j)
               sci(3) = uind(1,i)*xji + uind(2,i)*yji + uind(3,i)*zji
               sci(4) = uind(1,j)*xji + uind(2,j)*yji + uind(3,j)*zji
               sci(7) = qir(1)*uind(1,j) + qir(2)*uind(2,j)
     &                     + qir(3)*uind(3,j)
               sci(8) = qjr(1)*uind(1,i) + qjr(2)*uind(2,i)
     &                     + qjr(3)*uind(3,i)
c
c     get the induced-induced derivative terms
c
               findmp(1) = uscale(jj) * (sci(2)*rr3*dscale3(1)
     &                            - sci(3)*sci(4)*rr5*dscale5(1))
               findmp(2) = uscale(jj) * (sci(2)*rr3*dscale3(2)
     &                            - sci(3)*sci(4)*rr5*dscale5(2))
               findmp(3) = uscale(jj) * (sci(2)*rr3*dscale3(3)
     &                            - sci(3)*sci(4)*rr5*dscale5(3))
c
c     calculate the gl functions for potential energy
c
               gl(0) = ci*cj
               gl(1) = cj*sc(3) - ci*sc(4)
               gl(2) = ci*sc(6) + cj*sc(5) - sc(3)*sc(4)
               gl(3) = sc(3)*sc(6) - sc(4)*sc(5)
               gl(4) = sc(5)*sc(6)
               gl(6) = sc(2)
               gl(7) = 2.0d0 * (sc(7)-sc(8))
               gl(8) = 2.0d0 * sc(10)
               gl(5) = -4.0d0 * sc(9)
               gli(1) = cj*sci(3) - ci*sci(4)
               gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) - sci(3)*sci(4)
               gli(3) = sci(3)*sc(6) - sci(4)*sc(5)
               gli(6) = sci(1) + sci(2)
               gli(7) = 2.0d0 * (sci(7)-sci(8))
c
c    get the permanent and induced energy for this interaction
c
               fridmp(1) = (rr3*(gli(1)+gli(6)-sci(2))*dscale3(1)
     &                   + rr5*(gli(2)+gli(7)+sci(3)*sci(4))*dscale5(1)
     &                   + rr7*gli(3)*dscale7(1))*pscale(jj)
               fridmp(2) = (rr3*(gli(1)+gli(6)-sci(2))*dscale3(2)
     &                   + rr5*(gli(2)+gli(7)+sci(3)*sci(4))*dscale5(2)
     &                   + rr7*gli(3)*dscale7(2))*pscale(jj)
               fridmp(3) = (rr3*(gli(1)+gli(6)-sci(2))*dscale3(3)
     &                   + rr5*(gli(2)+gli(7)+sci(3)*sci(4))*dscale5(3)
     &                   + rr7*gli(3)*dscale7(3))*pscale(jj)
c
c     intermediate variables for the permanent multipole terms
c
               gf(1) = rr3*gl(0) + rr5*(gl(1)+gl(6))
     &                    + rr7*(gl(2)+gl(7)+gl(8))
     &                    + rr9*(gl(3)+gl(5)) + rr11*gl(4)
               gf(2) = -cj*rr3 + sc(4)*rr5 - sc(6)*rr7
               gf(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7
               gf(4) = 2.0d0 * rr5
               gf(5) = 2.0d0 * (-cj*rr5+sc(4)*rr7-sc(6)*rr9)
               gf(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9)
               gf(7) = 4.0d0 * rr7
c
c     intermediate variables for the induced-permanent terms
c
               gfi(1) = rr5*((gli(1)+sci(1))*scale3+sci(2)*scale3i)
     &                     + rr7*(gli(7)-sc(3)*sci(4)
     &                               -sc(4)*sci(3))*scale5
     &                     - rr7*sci(3)*sci(4)*scale5i
     &                     + rr9*gli(3)*scale7
               gfi(2) = -rr3*cj*scale3
     &                     + rr5*(sc(4)*scale5+sci(4)*scale5i)
     &                     - rr7*sc(6)*scale7
               gfi(3) = rr3*ci*scale3
     &                     + rr5*(sc(3)*scale5+sci(3)*scale5i)
     &                     + rr7*sc(5)*scale7
               gfi(4) = 2.0d0 * rr5 * scale5
               gfi(5) = 2.0d0 * rr7 * sci(4) * scale7
               gfi(6) = -2.0d0 * rr7 * sci(3) * scale7
c
c     get the permanent force
c
               ftm2(1) = gf(1)*xji + gf(2)*di(1) + gf(3)*dj(1)
     &                      + gf(4)*(qjdi(1)-qidj(1)) + gf(5)*qir(1)
     &                      + gf(6)*qjr(1) + gf(7)*(qiqjr(1)+qjqir(1))
               ftm2(2) = gf(1)*yji + gf(2)*di(2) + gf(3)*dj(2)
     &                      + gf(4)*(qjdi(2)-qidj(2)) + gf(5)*qir(2)
     &                      + gf(6)*qjr(2) + gf(7)*(qiqjr(2)+qjqir(2))
               ftm2(3) = gf(1)*zji + gf(2)*di(3) + gf(3)*dj(3)
     &                      + gf(4)*(qjdi(3)-qidj(3)) + gf(5)*qir(3)
     &                      + gf(6)*qjr(3) + gf(7)*(qiqjr(3)+qjqir(3))
c
c     get the induced force
c
               ftm2i(1) = gfi(1)*xji + gfi(2)*uind(1,i)
     &           + gfi(3)*uind(1,j) + sci(4)*rr5*di(1)*scale5
     &           + sci(3)*rr5*dj(1)*scale5 + gfi(4)*(qjui(1)-qiuj(1))
     &           + gfi(5)*qir(1) + gfi(6)*qjr(1)
               ftm2i(2) = gfi(1)*yji + gfi(2)*uind(2,i)
     &           + gfi(3)*uind(2,j) + sci(4)*rr5*di(2)*scale5
     &           + sci(3)*rr5*dj(2)*scale5 + gfi(4)*(qjui(2)-qiuj(2))
     &           + gfi(5)*qir(2) + gfi(6)*qjr(2)
               ftm2i(3) = gfi(1)*zji + gfi(2)*uind(3,i)
     &           + gfi(3)*uind(3,j) + sci(4)*rr5*di(3)*scale5
     &           + sci(3)*rr5*dj(3)*scale5 + gfi(4)*(qjui(3)-qiuj(3))
     &           + gfi(5)*qir(3) + gfi(6)*qjr(3)
c
c     handle of scaling for partially excluded interactions
c
               ftm2(1) = mscale(jj) * ftm2(1)
               ftm2(2) = mscale(jj) * ftm2(2)
               ftm2(3) = mscale(jj) * ftm2(3)
               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(1) = rr5*sci(2)*scale3i
     &                        - rr7*sci(3)*sci(4)*scale5i
                  gfd(2) = rr5 * sci(4) * scale5i
                  gfd(3) = rr5 * sci(3) * scale5i
                  fdir(1) = gfd(1)*xji + gfd(2)*uind(1,i)
     &                         + gfd(3)*uind(1,j)
                  fdir(2) = gfd(1)*yji + gfd(2)*uind(2,i)
     &                         + gfd(3)*uind(2,j)
                  fdir(3) = gfd(1)*zji + gfd(2)*uind(3,i)
     &                         + gfd(3)*uind(3,j)
                  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     now perform the torque calculation
c     intermediate terms for torque between multipoles i and j
c
               gti(2) = sci(4) * rr5 * scale5
               gti(3) = sci(3) * rr5 * scale5
               gti(4) = gfi(4)
               gti(5) = gfi(5)
               gti(6) = gfi(6)
c
c     get the permanent interaction torques
c
               ttm2(1) = -rr3*dixdj(1) + gf(2)*dixr(1)-gf(5)*rxqir(1)
     &           + gf(4)*(dixqjr(1)+djxqir(1)+rxqidj(1)-2.0d0*qixqj(1))
     &           - gf(7)*(rxqijr(1)+qjrxqir(1))
               ttm2(2) = -rr3*dixdj(2) + gf(2)*dixr(2)-gf(5)*rxqir(2)
     &           + gf(4)*(dixqjr(2)+djxqir(2)+rxqidj(2)-2.0d0*qixqj(2))
     &           - gf(7)*(rxqijr(2)+qjrxqir(2))
               ttm2(3) = -rr3*dixdj(3) + gf(2)*dixr(3)-gf(5)*rxqir(3)
     &           + gf(4)*(dixqjr(3)+djxqir(3)+rxqidj(3)-2.0d0*qixqj(3))
     &           - gf(7)*(rxqijr(3)+qjrxqir(3))
               ttm3(1) = rr3*dixdj(1) + gf(3)*djxr(1) -gf(6)*rxqjr(1)
     &           - gf(4)*(dixqjr(1)+djxqir(1)+rxqjdi(1)-2.0d0*qixqj(1))
     &           - gf(7)*(rxqjir(1)-qjrxqir(1))
               ttm3(2) = rr3*dixdj(2) + gf(3)*djxr(2) -gf(6)*rxqjr(2)
     &           - gf(4)*(dixqjr(2)+djxqir(2)+rxqjdi(2)-2.0d0*qixqj(2))
     &           - gf(7)*(rxqjir(2)-qjrxqir(2))
               ttm3(3) = rr3*dixdj(3) + gf(3)*djxr(3) -gf(6)*rxqjr(3)
     &           - gf(4)*(dixqjr(3)+djxqir(3)+rxqjdi(3)-2.0d0*qixqj(3))
     &           - gf(7)*(rxqjir(3)-qjrxqir(3))
c
c     induced-torque on site i is due to the field of induced
c     dipole on site j interacting with permanent D and Q on site i;
c     di x fuindj + qi x fuindj
c
               ttm2i(1) = -rr3*dixuj(1)*scale3 + gti(2)*dixr(1)
     &              + gti(4)*(ujxqir(1)+rxqiuj(1)) - gti(5)*rxqir(1)
               ttm2i(2) = -rr3*dixuj(2)*scale3 + gti(2)*dixr(2)
     &              + gti(4)*(ujxqir(2)+rxqiuj(2)) - gti(5)*rxqir(2)
               ttm2i(3) = -rr3*dixuj(3)*scale3 + gti(2)*dixr(3)
     &              + gti(4)*(ujxqir(3)+rxqiuj(3)) - gti(5)*rxqir(3)
               ttm3i(1) = -rr3*djxui(1)*scale3 + gti(3)*djxr(1)
     &              - gti(4)*(uixqjr(1)+rxqjui(1)) - gti(6)*rxqjr(1)
               ttm3i(2) = -rr3*djxui(2)*scale3 + gti(3)*djxr(2)
     &              - gti(4)*(uixqjr(2)+rxqjui(2)) - gti(6)*rxqjr(2)
               ttm3i(3) = -rr3*djxui(3)*scale3 + gti(3)*djxr(3)
     &              - gti(4)*(uixqjr(3)+rxqjui(3)) - gti(6)*rxqjr(3)
c
c     handle the case where scaling is used
c
               ttm2(1) = ttm2(1) * mscale(jj)
               ttm2(2) = ttm2(2) * mscale(jj)
               ttm2(3) = ttm2(3) * mscale(jj)
               ttm3(1) = ttm3(1) * mscale(jj)
               ttm3(2) = ttm3(2) * mscale(jj)
               ttm3(3) = ttm3(3) * mscale(jj)
c
c     update force and torque on site j
c
               ftm1(1,j) = ftm1(1,j) + ftm2(1)
               ftm1(2,j) = ftm1(2,j) + ftm2(2)
               ftm1(3,j) = ftm1(3,j) + ftm2(3)
               ttm1(1,j) = ttm1(1,j) + ttm3(1)
               ttm1(2,j) = ttm1(2,j) + ttm3(2)
               ttm1(3,j) = ttm1(3,j) + ttm3(3)
               ftm1i(1,j) = ftm1i(1,j) + ftm2i(1)
               ftm1i(2,j) = ftm1i(2,j) + ftm2i(2)
               ftm1i(3,j) = ftm1i(3,j) + ftm2i(3)
               ttm1i(1,j) = ttm1i(1,j) + ttm3i(1)
               ttm1i(2,j) = ttm1i(2,j) + ttm3i(2)
               ttm1i(3,j) = ttm1i(3,j) + ttm3i(3)
c
c     update force and torque on site i
c
               ftm1(1,i) = ftm1(1,i) - ftm2(1)
               ftm1(2,i) = ftm1(2,i) - ftm2(2)
               ftm1(3,i) = ftm1(3,i) - ftm2(3)
               ttm1(1,i) = ttm1(1,i) + ttm2(1)
               ttm1(2,i) = ttm1(2,i) + ttm2(2)
               ttm1(3,i) = ttm1(3,i) + ttm2(3)
               ftm1i(1,i) = ftm1i(1,i) - ftm2i(1)
               ftm1i(2,i) = ftm1i(2,i) - ftm2i(2)
               ftm1i(3,i) = ftm1i(3,i) - ftm2i(3)
               ttm1i(1,i) = ttm1i(1,i) + ttm2i(1)
               ttm1i(2,i) = ttm1i(2,i) + ttm2i(2)
               ttm1i(3,i) = ttm1i(3,i) + ttm2i(3)
            end if
   10       continue
         end do
      end do
c
c     increment the total forces and torques
c
      do i = 1, npole
         ii = ipole(i)
         dem(1,ii) = dem(1,ii) - f*ftm1(1,i)
         dem(2,ii) = dem(2,ii) - f*ftm1(2,i)
         dem(3,ii) = dem(3,ii) - f*ftm1(3,i)
         dep(1,ii) = dep(1,ii) - f*ftm1i(1,i)
         dep(2,ii) = dep(2,ii) - f*ftm1i(2,i)
         dep(3,ii) = dep(3,ii) - f*ftm1i(3,i)
         trq(1,ii) = trq(1,ii) + f*ttm1(1,i)
         trq(2,ii) = trq(2,ii) + f*ttm1(2,i)
         trq(3,ii) = trq(3,ii) + f*ttm1(3,i)
         trqi(1,ii) = trqi(1,ii) + f*ttm1i(1,i)
         trqi(2,ii) = trqi(2,ii) + f*ttm1i(2,i)
         trqi(3,ii) = trqi(3,ii) + f*ttm1i(3,i)
      end do
      call torque (trq,dem)
      call torque (trqi,dep)
      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  --  mpole/polar energy & analysis  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "empole3" calculates the electrostatic energy due to
c     atomic multipole interactions and dipole polarizability,
c     and partitions the energy among the atoms
c
c
      subroutine empole3
      implicit none
      include 'cutoff.i'
c
c
c     choose pairwise double loop or Ewald summation version
c
      if (use_ewald) then
         call empole3b
      else
         call empole3a
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine empole3a  --  double loop multipole analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "empole3a" calculates the electrostatic energy due to
c     atomic multipole interactions and dipole polarizability, and
c     partitions the energy among the atoms using a double loop
c
c
      subroutine empole3a
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'math.i'
      include 'molcul.i'
      include 'mplpot.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'potent.i'
      include 'shunt.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k
      integer ii,kk
      integer ix,iz
      integer kx,kz
      real*8 e,ei,f,fikm,fikp
      real*8 r,r2,xr,yr,zr
      real*8 fgrp,damp
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9
      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 scale3,scale5
      real*8 scale7
      real*8 sc(10),sci(8)
      real*8 gl(0:4),gli(3)
      real*8 a(3,3)
      real*8 mscale(maxatm)
      real*8 pscale(maxatm)
      logical proceed
      logical header,huge
      logical iuse,kuse
      logical muse,puse
c
c
c     zero out multipole and polarization energy and partitioning
c
      nem = 0
      nep = 0
      em = 0.0d0
      ep = 0.0d0
      do i = 1, n
         aem(i) = 0.0d0
         aep(i) = 0.0d0
      end do
      header = .true.
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (npole .eq. 0)  return
      f = electric / dielec
      call switch ('MPOLE')
c
c     calculate the multipole interaction energy term
c
      do i = 1, npole-1
         ii = ipole(i)
         iz = zaxis(i)
         ix = xaxis(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)
         iuse = (use(ii) .or. use(iz) .or. use(ix))
         do j = i+1, npole
            mscale(ipole(j)) = 1.0d0
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
c
c     decide whether to compute the current interaction
c
         do k = i+1, npole
            kk = ipole(k)
            kz = zaxis(k)
            kx = xaxis(k)
            kuse = (use(kk) .or. use(kz) .or. use(kx))
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,ii,kk,0,0,0)
            if (.not. use_intra)  proceed = .true.
            if (proceed)  proceed = (iuse .or. kuse)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               xr = x(kk) - x(ii)
               yr = y(kk) - y(ii)
               zr = z(kk) - z(ii)
               call image (xr,yr,zr,0)
               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     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(2) = dix*dkx + diy*dky + diz*dkz
                  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
                  sc(7) = qix*dkx + qiy*dky + qiz*dkz
                  sc(8) = qkx*dix + qky*diy + qkz*diz
                  sc(9) = qix*qkx + qiy*qky + qiz*qkz
                  sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                        + qixx*qkxx + qiyy*qkyy + qizz*qkzz
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 permanent multipoles
c
                  gl(0) = ci*ck
                  gl(1) = ck*sc(3) - ci*sc(4) + sc(2)
                  gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4)
     &                       + 2.0d0*(sc(7)-sc(8)+sc(10))
                  gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9)
                  gl(4) = sc(5)*sc(6)
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
                  rr9 = 7.0d0 * rr7 / r2
                  scale3 = 1.0d0 
                  scale5 = 1.0d0 
                  scale7 = 1.0d0 
                  damp = pdamp(i) * pdamp(k)
                  if (damp .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)
                     end if
                  end if
                  e = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5
     &                   + gl(3)*rr7 + gl(4)*rr9
                  ei = gli(1)*rr3*scale3 + gli(2)*rr5*scale5 
     &                    + gli(3)*rr7*scale7
c
c     make the adjustment for scaled interactions
c
                  fikm = f * mscale(kk)
                  fikp = f * pscale(kk)
                  e = fikm * e
                  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
                     e = e * fgrp
c                    ei = ei * fgrp
                  end if
c
c     increment the overall multipole and polarization energies
c
                  muse = (use_mpole .and. mscale(kk).ne.0.0d0)
                  puse = (use_polar .and. pscale(kk).ne.0.0d0)
                  if (muse)  nem = nem + 1
                  if (puse)  nep = nep + 1
                  em = em + e
                  ep = ep + ei
                  aem(ii) = aem(ii) + 0.5d0*e
                  aem(kk) = aem(kk) + 0.5d0*e
                  aep(ii) = aep(ii) + 0.5d0*ei
                  aep(kk) = aep(kk) + 0.5d0*ei
c
c     increment the total intermolecular energy
c
                  if (molcule(ii) .ne. molcule(kk)) then
                     einter = einter + e + ei
                  end if
c
c     print a message if the energy of this interaction is large
c
                  huge = (max(abs(e),abs(ei)) .gt. 100.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (muse .or. puse) then
                        if (header) then
                           header = .false.
                           write (iout,10)
   10                      format (/,' Individual Multipole and',
     &                                ' Polarization Interactions :',
     &                             //,' Type',13x,'Atom Names',
     &                                9x,'Distance',6x,'Energies',
     &                                ' (MPole, Polar)',/)
                        end if
                        write (iout,20)  ii,name(ii),kk,name(kk),r,e,ei
   20                   format (' M-Pole',5x,i5,'-',a3,1x,i5,
     &                             '-',a3,5x,f8.4,4x,2f12.4)
                     end if
                  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, npole
         ii = ipole(i)
         iz = zaxis(i)
         ix = xaxis(i)
         iuse = (use(ii) .or. use(iz) .or. use(ix))
         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)
         do j = i, npole
            mscale(ipole(j)) = 1.0d0
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
c
c     decide whether to compute the current interaction
c
         do k = i, npole
            kk = ipole(k)
            kz = zaxis(k)
            kx = xaxis(k)
            kuse = (use(kk) .or. use(kz) .or. use(kx))
            if (use_group)  call groups (proceed,fgrp,2,ii,kk,0,0,0)
            proceed = .true.
            if (proceed)  proceed = (iuse .or. kuse)
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               do j = 1, ncell
                  xr = x(kk) - x(ii)
                  yr = y(kk) - y(ii)
                  zr = z(kk) - z(ii)
                  call image (xr,yr,zr,j)
                  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     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(2) = dix*dkx + diy*dky + diz*dkz
                     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
                     sc(7) = qix*dkx + qiy*dky + qiz*dkz
                     sc(8) = qkx*dix + qky*diy + qkz*diz
                     sc(9) = qix*qkx + qiy*qky + qiz*qkz
                     sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                           + qixx*qkxx + qiyy*qkyy + qizz*qkzz
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 permanent multipoles
c
                     gl(0) = ci*ck
                     gl(1) = ck*sc(3) - ci*sc(4) + sc(2)
                     gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4)
     &                          + 2.0d0*(sc(7)-sc(8)+sc(10))
                     gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9)
                     gl(4) = sc(5)*sc(6)
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
                     rr9 = 7.0d0 * rr7 / r2
                     scale3 = 1.0d0 
                     scale5 = 1.0d0 
                     scale7 = 1.0d0 
                     damp = pdamp(i) * pdamp(k)
                     if (damp .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)
                        end if
                     end if
                     e = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5
     &                      + gl(3)*rr7 + gl(4)*rr9
                     ei = gli(1)*rr3*scale3 + gli(2)*rr5*scale5 
     &                       + gli(3)*rr7*scale7
                     fikm = f
                     fikp = f
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           fikm = fikm * mscale(kk)
                           fikp = fikp * pscale(kk)
                        end if
                     end if
                     e = fikm * e
                     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
                        e = e * fgrp
c                       ei = ei * fgrp
                     end if
c
c     increment the overall multipole and polarization energies
c
                     if (ii .eq. kk) then
                        e = 0.5d0 * e
                        ei = 0.5d0 * ei
                     end if
                     nem = nem + 1
                     nep = nep + 1
                     em = em + e
                     ep = ep + ei
                     aem(ii) = aem(ii) + 0.5d0*e
                     aem(kk) = aem(kk) + 0.5d0*e
                     aep(ii) = aep(ii) + 0.5d0*ei
                     aep(kk) = aep(kk) + 0.5d0*ei
c
c     increment the total intermolecular energy
c
                     einter = einter + e + ei
c
c     print a message if the energy of this interaction is large
c
                     huge = (max(abs(e),abs(ei)) .gt. 100.0d0)
                     if (debug .or. (verbose.and.huge)) then
                        if (header) then
                           header = .false.
                           write (iout,30)
   30                      format (/,' Individual Multipole and',
     &                                ' Polarization Interactions :',
     &                             //,' Type',13x,'Atom Names',
     &                                9x,'Distance',6x,'Energies',
     &                                ' (MPole, Polar)',/)
                        end if
                        write (iout,40)  ii,name(ii),kk,name(kk),r,e,ei
   40                   format (' M-Pole',5x,i5,'-',a3,1x,i5,'-',a3,
     &                             1x,'(X)',1x,f8.4,4x,2f12.4)
                     end if
                  end if
               end do
            end if
         end do
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine empole3b  --  Ewald summation mpole analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "empole3b" calculates the electrostatic energy due to atomic
c     multipole interactions and dipole polarizability, and partitions
c     the energy among the atoms using a regular Ewald summation
c
c
      subroutine empole3b
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'chgpot.i'
      include 'energi.i'
      include 'ewald.i'
      include 'inter.i'
      include 'math.i'
      include 'mpole.i'
      include 'polar.i'
      include 'units.i'
      integer i,ii
      real*8 e,ei,eintra
      real*8 f,term,fterm
      real*8 cii,dii,qii,uii
      real*8 xd,yd,zd
      real*8 xu,yu,zu
      real*8 ci,dix,diy,diz
      real*8 uix,uiy,uiz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 a(3,3)
c
c
c     zero out the multipole and polarization energies
c
      nem = 0
      nep = 0
      em = 0.0d0
      ep = 0.0d0
      do i = 1, n
         aem(i) = 0.0d0
         aep(i) = 0.0d0
      end do
c
c     set the energy unit conversion factor
c
      f = electric / dielec
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
c
c     compute the induced dipoles at each polarizable atom
c
      call induce
c
c     compute the reciprocal space part of the Ewald summation
c
      call erecip3
c
c     compute the real space part of the Ewald summation
c
      call ereal3 (eintra)
c
c     compute the self-energy part of the Ewald summation
c
      term = 2.0d0 * aewald * aewald
      fterm = -f * aewald / sqrtpi
      do i = 1, npole
         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)
         cii = ci*ci
         dii = dix*dix + diy*diy + diz*diz
         qii = qixx*qixx + qiyy*qiyy + qizz*qizz
     &            + 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz)
         uii = dix*uix + diy*uiy + diz*uiz
         e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0))
         ei = fterm * term * uii / 3.0d0
         nem = nem + 1
         nep = nep + 1
         em = em + e
         ep = ep + ei
         aem(i) = aem(i) + e
         aep(i) = aep(i) + ei
      end do
c
c     compute the cell dipole boundary correction term
c
      if (.not. tinfoil) then
         xd = 0.0d0
         yd = 0.0d0
         zd = 0.0d0
         xu = 0.0d0
         yu = 0.0d0
         zu = 0.0d0
         do i = 1, npole
            ii = ipole(i)
            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(ii)
            yd = yd + diy + rpole(1,i)*y(ii)
            zd = zd + diz + rpole(1,i)*z(ii)
            xu = xu + uix        
            yu = yu + uiy
            zu = zu + uiz       
         end do
         term = (2.0d0/3.0d0) * f * (pi/volbox)
         nem = nem + 1
         nep = nep + 1
         em = em + term*(xd*xd+yd*yd+zd*zd)
         ep = ep + term*(xd*xu+yd*yu+zd*zu)
      end if
c
c     intermolecular energy is total minus intramolecular part
c
      einter = einter + em + ep - eintra
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine erecip3  --  mpole Ewald reciprocal analysis  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "erecip3" evaluates the reciprocal space portion of the regular
c     Ewald summation energy due to atomic multipole interactions
c     and dipole polarizability, and prints information about the
c     energy over the reciprocal lattice vectors
c
c     literature reference:
c
c     W. Smith, "Point Multipoles in the Ewald Summation (Revisited)",
c     CCP5 Newsletter, 46, 18-30, 1998  (see http://www.ccp5.org/)
c
c
      subroutine erecip3
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'chgpot.i'
      include 'energi.i'
      include 'ewald.i'
      include 'ewreg.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'mpole.i'
      include 'polar.i'
      include 'units.i'
      integer i,j,k,l,ii
      integer jmin,jmax
      integer kmin,kmax
      integer lmin,lmax
      real*8 e,ei,f,term,cut
      real*8 eterm,expterm
      real*8 xfr,yfr,zfr
      real*8 rj,rk,rl
      real*8 h1,h2,h3
      real*8 hsq,hleng
      real*8 t1,t2,t3,t4
      real*8 ck,dk,qk,uk
      real*8 q1,q2,q3
      real*8 ckr,skr
      real*8 cm(maxatm)
      real*8 dm(3,maxatm)
      real*8 qm(9,maxatm)
      real*8 um(3,maxatm)
      real*8 cjk(maxatm)
      real*8 sjk(maxatm)
      logical header,huge
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      header = .true.
      f = electric / dielec
      term = -0.25d0 / aewald**2
      eterm = 4.0d0 * pi * f / volbox
c
c     set the number of vectors based on box dimensions
c
      cut = 4.0d0 * pi * pi * frecip
      jmin = 0
      kmin = 0
      lmin = 1
      jmax = min(maxvec,int(frecip/recip(1,1)))
      kmax = min(maxvec,int(frecip/recip(2,2)))
      lmax = min(maxvec,int(frecip/recip(3,3)))
c
c     copy the multipole moments into local storage areas
c
      do i = 1, npole
         cm(i) = rpole(1,i)
         dm(1,i) = rpole(2,i)
         dm(2,i) = rpole(3,i)
         dm(3,i) = rpole(4,i)
         qm(1,i) = rpole(5,i)
         qm(2,i) = rpole(6,i)
         qm(3,i) = rpole(7,i)
         qm(4,i) = rpole(8,i)
         qm(5,i) = rpole(9,i)
         qm(6,i) = rpole(10,i)
         qm(7,i) = rpole(11,i)
         qm(8,i) = rpole(12,i)
         qm(9,i) = rpole(13,i)
         um(1,i) = uind(1,i)
         um(2,i) = uind(2,i)
         um(3,i) = uind(3,i)
      end do
c
c     calculate and store the exponential factors
c
      do i = 1, npole
         ii = ipole(i)
         zfr = (z(ii)/gamma_term) / zbox
         yfr = ((y(ii)-zfr*zbox*beta_term)/gamma_sin) / ybox
         xfr = (x(ii)-yfr*ybox*gamma_cos-zfr*zbox*beta_cos) / xbox
         xfr = 2.0d0 * pi * xfr
         yfr = 2.0d0 * pi * yfr
         zfr = 2.0d0 * pi * zfr
         ejc(i,0) = 1.0d0
         ejs(i,0) = 0.0d0
         ekc(i,0) = 1.0d0
         eks(i,0) = 0.0d0
         elc(i,0) = 1.0d0
         els(i,0) = 0.0d0
         ejc(i,1) = cos(xfr)
         ejs(i,1) = sin(xfr)
         ekc(i,1) = cos(yfr)
         eks(i,1) = sin(yfr)
         elc(i,1) = cos(zfr)
         els(i,1) = sin(zfr)
         ekc(i,-1) = ekc(i,1)
         eks(i,-1) = -eks(i,1)
         elc(i,-1) = elc(i,1)
         els(i,-1) = -els(i,1)
         do j = 2, jmax
            ejc(i,j) = ejc(i,j-1)*ejc(i,1) - ejs(i,j-1)*ejs(i,1)
            ejs(i,j) = ejs(i,j-1)*ejc(i,1) + ejc(i,j-1)*ejs(i,1)
         end do
         do j = 2, kmax
            ekc(i,j) = ekc(i,j-1)*ekc(i,1) - eks(i,j-1)*eks(i,1)
            eks(i,j) = eks(i,j-1)*ekc(i,1) + ekc(i,j-1)*eks(i,1)
            ekc(i,-j) = ekc(i,j)
            eks(i,-j) = -eks(i,j)
         end do
         do j = 2, lmax
            elc(i,j) = elc(i,j-1)*elc(i,1) - els(i,j-1)*els(i,1)
            els(i,j) = els(i,j-1)*elc(i,1) + elc(i,j-1)*els(i,1)
            elc(i,-j) = elc(i,j)
            els(i,-j) = -els(i,j)
         end do
      end do
c
c     loop over all k vectors from the reciprocal lattice
c
      do j = jmin, jmax
         rj = 2.0d0 * pi * dble(j)
         do k = kmin, kmax
            rk = 2.0d0 * pi * dble(k)
            do i = 1, npole
               cjk(i) = ejc(i,j)*ekc(i,k) - ejs(i,j)*eks(i,k)
               sjk(i) = ejs(i,j)*ekc(i,k) + ejc(i,j)*eks(i,k)
            end do
            do l = lmin, lmax
               rl = 2.0d0 * pi * dble(l)
               h1 = recip(1,1)*rj
               h2 = recip(2,1)*rj + recip(2,2)*rk
               h3 = recip(3,1)*rj + recip(3,2)*rk + recip(3,3)*rl
               hsq = h1*h1 + h2*h2 + h3*h3
               if (hsq .le. cut) then
                  t1 = 0.0d0
                  t2 = 0.0d0
                  t3 = 0.0d0
                  t4 = 0.0d0
                  do i = 1, npole
                     ckr = cjk(i)*elc(i,l) - sjk(i)*els(i,l)
                     skr = sjk(i)*elc(i,l) + cjk(i)*els(i,l)
c
c     alternative phase cosine and sine is slower but avoids storage
c
c                    ii = ipole(i)
c                    phi = x(i)*h1 + y(i)*h2 + z(i)*h3
c                    ckr = cos(phi)
c                    skr = sin(phi)
                     ck = cm(i)
                     dk = h1*dm(1,i) + h2*dm(2,i) + h3*dm(3,i)
                     q1 = h1*qm(1,i) + h2*qm(4,i) + h3*qm(7,i)
                     q2 = h1*qm(2,i) + h2*qm(5,i) + h3*qm(8,i)
                     q3 = h1*qm(3,i) + h2*qm(6,i) + h3*qm(9,i)
                     qk = h1*q1 + h2*q2 + h3*q3
                     uk = h1*um(1,i) + h2*um(2,i) + h3*um(3,i)
                     t1 = t1 + (ck-qk)*skr + dk*ckr
                     t2 = t2 + (ck-qk)*ckr - dk*skr
                     t3 = t3 + uk*ckr
                     t4 = t4 - uk*skr
                  end do
                  expterm = eterm * exp(term*hsq) / hsq
                  e = expterm * (t1*t1+t2*t2)
                  ei = expterm * (t1*t3+t2*t4)
                  nem = nem + 1
                  nep = nep + 1
                  em = em + e
                  ep = ep + ei
c
c     print a message if the energy of this interaction is large
c
                  huge = (max(abs(e),abs(ei)) .gt. 10.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,10)
   10                   format (/,' Reciprocal Space Multipole',
     &                             ' and Polarization Terms :',
     &                          //,' Type',15x,'K-Vector',9x,'Fraction',
     &                             6x,'Energies (MPole, Polar)',/)
                     end if
                     hleng = hsq / (4.0d0*pi*pi)
                     write (iout,20)  j,k,l,hleng,e,ei
   20                format (' M-Pole',7x,3i5,7x,f8.4,4x,2f12.4)
                  end if
               end if
            end do
            lmin = -lmax
         end do
         kmin = -kmax
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine ereal3  --  mpole Ewald real space analysis  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "ereal3" evaluates the real space portion of the regular Ewald
c     summation energy due to atomic multipole interactions and dipole
c     polarizability and partitions 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  (see http://www.ccp5.org/)
c
c
      subroutine ereal3 (eintra)
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'bound.i'
      include 'cell.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'energi.i'
      include 'ewald.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'molcul.i'
      include 'mplpot.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'shunt.i'
      include 'units.i'
      integer i,j,k,m
      integer ii,kk
      real*8 e,ei,eintra
      real*8 f,erfc
      real*8 r,r2,xr,yr,zr
      real*8 bfac,exp2a
      real*8 efix,eifix
      real*8 ralpha,damp
      real*8 alsq2,alsq2n
      real*8 rr1,rr3,rr5
      real*8 rr7,rr9
      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 scale3,scale5
      real*8 scale7
      real*8 sc(10),sci(8)
      real*8 gl(0:4),gli(3)
      real*8 bn(0:4)
      real*8 mscale(maxatm)
      real*8 pscale(maxatm)
      logical header,huge
c
c
c     zero out the intramolecular portion of the Ewald energy
c
      eintra = 0.0d0
c
c     set conversion factor, cutoff and scaling coefficients
c
      if (npole .eq. 0)  return
      header = .true.
      f = electric / dielec
      call switch ('EWALD')
c
c     compute the real space portion of the Ewald summation
c
      do i = 1, npole-1
         ii = ipole(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)
         do j = i+1, npole
            mscale(ipole(j)) = 1.0d0
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
         do k = i+1, npole
            kk = ipole(k)
            xr = x(kk) - x(ii)
            yr = y(kk) - y(ii)
            zr = z(kk) - z(ii)
            call image (xr,yr,zr,0)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. cut2) 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     calculate the error function damping terms
c
               ralpha = aewald * r
               bn(0) = erfc(ralpha) / r
               alsq2 = 2.0d0 * aewald**2
               alsq2n = 0.0d0
               if (aewald .gt. 0.0d0)
     &            alsq2n = 1.0d0 / (sqrtpi*aewald)
               exp2a = exp(-ralpha**2)
               do m = 1, 4
                  bfac = dble(m+m-1)
                  alsq2n = alsq2 * alsq2n
                  bn(m) = (bfac*bn(m-1)+alsq2n*exp2a) / r2
               end do
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(2) = dix*dkx + diy*dky + diz*dkz
               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
               sc(7) = qix*dkx + qiy*dky + qiz*dkz
               sc(8) = qkx*dix + qky*diy + qkz*diz
               sc(9) = qix*qkx + qiy*qky + qiz*qkz
               sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                     + qixx*qkxx + qiyy*qkyy + qizz*qkzz
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 permanent multipoles
c
               gl(0) = ci*ck
               gl(1) = ck*sc(3) - ci*sc(4) + sc(2)
               gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4)
     &                    + 2.0d0*(sc(7)-sc(8)+sc(10))
               gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9)
               gl(4) = sc(5)*sc(6)
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
               e = gl(0)*bn(0) + gl(1)*bn(1) + gl(2)*bn(2)
     &                + gl(3)*bn(3) + gl(4)*bn(4)
               ei = gli(1)*bn(1) + gli(2)*bn(2) + gli(3)*bn(3)
c
c     full energies needeed for scaling and damping correction
c
               rr1 = 1.0d0 / r
               rr3 = rr1 / r2
               rr5 = 3.0d0 * rr3 / r2
               rr7 = 5.0d0 * rr5 / r2
               rr9 = 7.0d0 * rr7 / r2
               damp = pdamp(i) * pdamp(k)
               scale3 = pscale(kk) 
               scale5 = pscale(kk)
               scale7 = pscale(kk)
               damp = pdamp(i) * pdamp(k)
               if (damp .ne. 0.0d0) then
                  damp = -pgamma * (r/damp)**3
                  if (damp .gt. -50.0d0) then
                     scale3 = scale3 * (1.0d0-exp(damp))
                     scale5 = scale5 * (1.0d0-(1.0d0-damp)*exp(damp))
                     scale7 = scale7 * (1.0d0-(1.0d0-damp+0.6d0*damp**2)
     &                                               *exp(damp))
                  end if
               end if
               efix = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5
     &                   + gl(3)*rr7 + gl(4)*rr9
               eifix = gli(1)*rr3*(1.0d0-scale3)
     &                    + gli(2)*rr5*(1.0d0-scale5)
     &                    + gli(3)*rr7*(1.0d0-scale7)
c
c     correction for scaled interactions and polarization damping
c
               e = e - efix*(1.0d0-mscale(kk))
               ei = ei - eifix
c
c     increment the overall multipole and polarization energies
c
               e = f * e
               ei = 0.5d0 * f * ei
               if (mscale(kk) .ne. 0.0d0)  nem = nem + 1
               if (pscale(kk) .ne. 0.0d0)  nep = nep + 1
               em = em + e
               ep = ep + ei
               aem(ii) = aem(ii) + 0.5d0*e
               aem(kk) = aem(kk) + 0.5d0*e
               aep(ii) = aep(ii) + 0.5d0*ei
               aep(kk) = aep(kk) + 0.5d0*ei
c
c     increment the total intramolecular energy
c
               if (molcule(ii) .eq. molcule(kk)) then
                  eintra = eintra + f*efix*mscale(kk)
                  eifix = gli(1)*rr3*scale3 + gli(2)*rr5*scale5
     &                       + gli(3)*rr7*scale7
                  eintra = eintra + 0.5d0*f*eifix
               end if
c
c     print a message if the energy of this interaction is large
c
               huge = (max(abs(e),abs(ei)) .gt. 100.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,10)
   10                format (/,' Real Space Multipole and',
     &                          ' Polarization Interactions :',
     &                       //,' Type',13x,'Atom Names',
     &                          9x,'Distance',6x,'Energies',
     &                          ' (MPole, Polar)',/)
                  end if
                  write (iout,20)  ii,name(ii),kk,name(kk),r,e,ei
   20             format (' M-Pole',5x,i5,'-',a3,1x,i5,
     &                       '-',a3,5x,f8.4,4x,2f12.4)
               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, npole
         ii = ipole(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)
         do j = i, npole
            mscale(ipole(j)) = 1.0d0
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, n12(ii)
            mscale(i12(j,ii)) = m2scale
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            mscale(i13(j,ii)) = m3scale
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            mscale(i14(j,ii)) = m4scale
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            mscale(i15(j,ii)) = m5scale
            pscale(i15(j,ii)) = p5scale
         end do
         do k = i, npole
            kk = ipole(k)
            do j = 1, ncell
               xr = x(kk) - x(ii)
               yr = y(kk) - y(ii)
               zr = z(kk) - z(ii)
               call image (xr,yr,zr,j)
               r2 = xr*xr + yr* yr + zr*zr
               if (r2 .le. cut2) 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     calculate the error function damping terms
c
                  ralpha = aewald * r
                  bn(0) = erfc(ralpha) / r
                  alsq2 = 2.0d0 * aewald**2
                  alsq2n = 0.0d0
                  if (aewald .gt. 0.0d0)
     &               alsq2n = 1.0d0 / (sqrtpi*aewald)
                  exp2a = exp(-ralpha**2)
                  do m = 1, 4
                     bfac = dble(m+m-1)
                     alsq2n = alsq2 * alsq2n
                     bn(m) = (bfac*bn(m-1)+alsq2n*exp2a) / r2
                  end do
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(2) = dix*dkx + diy*dky + diz*dkz
                  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
                  sc(7) = qix*dkx + qiy*dky + qiz*dkz
                  sc(8) = qkx*dix + qky*diy + qkz*diz
                  sc(9) = qix*qkx + qiy*qky + qiz*qkz
                  sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz)
     &                        + qixx*qkxx + qiyy*qkyy + qizz*qkzz
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 permanent multipoles
c
                  gl(0) = ci*ck
                  gl(1) = ck*sc(3) - ci*sc(4) + sc(2)
                  gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4)
     &                       + 2.0d0*(sc(7)-sc(8)+sc(10))
                  gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9)
                  gl(4) = sc(5)*sc(6)
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
                  e = gl(0)*bn(0) + gl(1)*bn(1) + gl(2)*bn(2)
     &                   + gl(3)*bn(3) + gl(4)*bn(4)
                  ei = gli(1)*bn(1) + gli(2)*bn(2) + gli(3)*bn(3)
c
c     full energies needeed for scaling and damping correction
c
                  rr1 = 1.0d0 / r
                  rr3 = rr1 / r2
                  rr5 = 3.0d0 * rr3 / r2
                  rr7 = 5.0d0 * rr5 / r2
                  rr9 = 7.0d0 * rr7 / r2
                  damp = pdamp(i) * pdamp(k)
                  scale3 = 1.0d0 
                  scale5 = 1.0d0 
                  scale7 = 1.0d0 
                  damp = pdamp(i) * pdamp(k)
                  if (damp .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)
                     end if
                  end if
                  if (use_polymer .and. r2.le.polycut2) then
                     scale3 = scale3 * pscale(kk)
                     scale5 = scale5 * pscale(kk)
                     scale7 = scale7 * pscale(kk)
                  end if
                  efix = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5
     &                      + gl(3)*rr7 + gl(4)*rr9
                  eifix = gli(1)*rr3*(1.0d0-scale3) 
     &                       + gli(2)*rr5*(1.0d0-scale5) 
     &                       + gli(3)*rr7*(1.0d0-scale7)
c
c     correction for scaled interactions and polarization damping
c
                  if (use_polymer .and. r2.le.polycut2) 
     &               e = e - efix*(1.0d0-mscale(kk))
                  ei = ei - eifix
c
c     increment the overall multipole and polarization energies
c
                  e = f * e
                  ei = 0.5d0 * f * ei
                  if (ii .eq. kk) then
                     e = 0.5d0 * e
                     ei = 0.5d0 * ei
                  end if
                  nem = nem + 1
                  nep = nep + 1
                  em = em + e
                  ep = ep + ei
                  aem(ii) = aem(ii) + 0.5d0*e
                  aem(kk) = aem(kk) + 0.5d0*e
                  aep(ii) = aep(ii) + 0.5d0*ei
                  aep(kk) = aep(kk) + 0.5d0*ei
c
c     print a message if the energy of this interaction is large
c
                  huge = (max(abs(e),abs(ei)) .gt. 100.0d0)
                  if (debug .or. (verbose.and.huge)) then
                     if (header) then
                        header = .false.
                        write (iout,30)
   30                   format (/,' Real Space Multipole and',
     &                             ' Polarization Interactions :',
     &                          //,' Type',13x,'Atom Names',
     &                             9x,'Distance',6x,'Energies',
     &                             ' (MPole, Polar)',/)
                     end if
                     write (iout,40)  ii,name(ii),kk,name(kk),r,e,ei
   40                format (' M-Pole',5x,i5,'-',a3,1x,i5,'-',a3,
     &                          1x,'(X)',1x,f8.4,4x,2f12.4)
                  end if
               end if
            end do
         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     ##  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 ()
      implicit none
      include 'sizes.i'
      include 'bound.i'
      include 'energi.i'
      include 'potent.i'
      include 'vdwpot.i'
      real*8 energy
      real*8 cutoff
c
c
c     zero out each of the potential energy components
c
      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
      ebt = 0.0d0
      ett = 0.0d0
      ev = 0.0d0
      ec = 0.0d0
      ecd = 0.0d0
      ed = 0.0d0
      em = 0.0d0
      ep = 0.0d0
      er = 0.0d0
      es = 0.0d0
      elf = 0.0d0
      eg = 0.0d0
      ex = 0.0d0
c
c     maintain any periodic boundary conditions
c
      if (use_bounds)  call bounds
c
c     remove any previous use of the replicates method
c
      cutoff = 0.0d0
      if (use_image)  call replica (cutoff)
c
c     alter bond and torsion constants for pisystem
c
      if (use_orbit)  call piscf
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_strtor)  call estrtor
c     if (use_tortor)  call etortor
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
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 .or. use_polar)  call empole
      if (use_rxnfld)  call erxnfld
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
      energy = eb + ea + eba + eub + eaa + eopb + eopd + eid + eit
     &            + et + ebt + ett + ev + ec + ecd + ed + em + ep
     &            + er + es + elf + eg + ex
      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
c     at trigonal centers via a Wilson-Decius-Cross angle bend
c
c
      subroutine eopbend
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'math.i'
      include 'opbend.i'
      include 'usage.i'
      integer i,iopbend
      integer ia,ib,ic,id
      real*8 e,force,angle
      real*8 dot,cosine,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 xpd,ypd,zpd
      real*8 rbd2,rpd2
      real*8 xt,yt,zt
      real*8 rt2,delta
      logical proceed
c
c
c     zero out the out-of-plane bending energy component
c
      eopb = 0.0d0
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 = kopb(iopbend)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     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)
c
c     compute the out-of-plane bending angle
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,0)
               call image (xbd,ybd,zbd,0)
               call image (xcd,ycd,zcd,0)
            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
            xpd = xbd + xt*delta
            ypd = ybd + yt*delta
            zpd = zbd + zt*delta
            rbd2 = xbd*xbd + ybd*ybd + zbd*zbd
            rpd2 = xpd*xpd + ypd*ypd + zpd*zpd
            if (rbd2.ne.0.0d0 .and. rpd2.ne.0.0d0) then
               dot = xbd*xpd + ybd*ypd + zbd*zpd
               cosine = dot / sqrt(rbd2*rpd2)
               cosine = min (1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
c
c     find the out-of-plane angle bending energy
c
               dt = angle
               dt2 = dt * dt
               dt3 = dt2 * dt
               dt4 = dt2 * dt2
               e = opbunit * 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 out-of-plane bending energy
c
               eopb = eopb + e
            end if
         end if
      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 eopbend1  --  out-of-plane bend energy & derivs  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "eopbend1" computes the out-of-plane bend potential
c     energy and first derivatives at trigonal centers via
c     a Wilson-Decius-Cross angle bend
c
c
      subroutine eopbend1
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'math.i'
      include 'opbend.i'
      include 'usage.i'
      include 'virial.i'
      integer i,iopbend
      integer ia,ib,ic,id
      real*8 e,force,angle
      real*8 dot,cosine,fgrp
      real*8 dt,dt2,dt3,dt4
      real*8 deddt,term
      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 xpd,ypd,zpd
      real*8 rbd2,rpd2
      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
      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
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 = kopb(iopbend)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     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)
c
c     compute the out-of-plane bending angle
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,0)
               call image (xbd,ybd,zbd,0)
               call image (xcd,ycd,zcd,0)
            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
            xpd = xbd + xt*delta
            ypd = ybd + yt*delta
            zpd = zbd + zt*delta
            rbd2 = xbd*xbd + ybd*ybd + zbd*zbd
            rpd2 = xpd*xpd + ypd*ypd + zpd*zpd
            xm = ypd*zbd - zpd*ybd
            ym = zpd*xbd - xpd*zbd
            zm = xpd*ybd - ypd*xbd
            rm = sqrt(xm*xm + ym*ym + zm*zm)
            if (rm .ne. 0.0d0) then
               dot = xbd*xpd + ybd*ypd + zbd*zpd
               cosine = dot / sqrt(rbd2*rpd2)
               cosine = min (1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
c
c     find the out-of-plane energy and master chain rule terms
c
               dt = angle
               dt2 = dt * dt
               dt3 = dt2 * dt
               dt4 = dt2 * dt2
               e = opbunit * force * dt2
     &                * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4)
               deddt = opbunit * 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 central atom and its projection
c
               term = -deddt / (rbd2*rm)
               dedxib = term * (ybd*zm-zbd*ym)
               dedyib = term * (zbd*xm-xbd*zm)
               dedzib = term * (xbd*ym-ybd*xm)
               term = deddt / (rpd2*rm)
               dedxip = term * (ypd*zm-zpd*ym)
               dedyip = term * (zpd*xm-xpd*zm)
               dedzip = term * (xpd*ym-ypd*xm)
c
c     chain rule terms for peripheral plane-defining atoms
c
               delta2 = 2.0d0 * delta
               ptrt2 = (dedxip*xt + dedyip*yt + dedzip*zt) / rt2
               term = (zcd*ybd-ycd*zbd) + delta2*(yt*zcd-zt*ycd)
               dedxia = delta*(ycd*dedzip-zcd*dedyip) + term*ptrt2
               term = (xcd*zbd-zcd*xbd) + delta2*(zt*xcd-xt*zcd)
               dedyia = delta*(zcd*dedxip-xcd*dedzip) + term*ptrt2
               term = (ycd*xbd-xcd*ybd) + delta2*(xt*ycd-yt*xcd)
               dedzia = delta*(xcd*dedyip-ycd*dedxip) + term*ptrt2
               term = (yad*zbd-zad*ybd) + delta2*(zt*yad-yt*zad)
               dedxic = delta*(zad*dedyip-yad*dedzip) + term*ptrt2
               term = (zad*xbd-xad*zbd) + delta2*(xt*zad-zt*xad)
               dedyic = delta*(xad*dedzip-zad*dedxip) + term*ptrt2
               term = (xad*ybd-yad*xbd) + delta2*(yt*xad-xt*yad)
               dedzic = delta*(yad*dedxip-xad*dedyip) + term*ptrt2
c
c     get out-of-plane atom chain rule terms by difference
c
               dedxid = -dedxia - dedxib - dedxic
               dedyid = -dedyia - dedyib - dedyic
               dedzid = -dedzia - dedzib - dedzic
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 diagonal components
c
               virx = virx + xad*dedxia + xbd*dedxib + xcd*dedxic
               viry = viry + yad*dedyia + ybd*dedyib + ycd*dedyic
               virz = virz + zad*dedzia + zbd*dedzib + zcd*dedzic
            end if
         end if
      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 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 angle bend for a single
c     atom using finite difference methods
c
c
      subroutine eopbend2 (i)
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'group.i'
      include 'hessn.i'
      include 'opbend.i'
      integer i,j,k,iopbend
      integer ia,ib,ic,id
      real*8 eps,fgrp
      real*8 old,term
      real*8 d0(3,maxatm)
      logical proceed
c
c
c     set stepsize for derivatives and default group weight
c
      eps = 1.0d-7
      fgrp = 1.0d0
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 = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,4,ia,ib,ic,id,0)
c
c     find first derivatives for the base structure
c
         if (proceed) then
            term = fgrp / eps
            call eopbend2a (iopbend)
            do j = 1, 3
               d0(j,ia) = deopb(j,ia)
               d0(j,ib) = deopb(j,ib)
               d0(j,ic) = deopb(j,ic)
               d0(j,id) = deopb(j,id)
            end do
c
c     find numerical x-components via perturbed structures
c
            old = x(i)
            x(i) = x(i) + eps
            call eopbend2a (iopbend)
            x(i) = old
            do j = 1, 3
               hessx(j,ia) = hessx(j,ia) + term*(deopb(j,ia)-d0(j,ia))
               hessx(j,ib) = hessx(j,ib) + term*(deopb(j,ib)-d0(j,ib))
               hessx(j,ic) = hessx(j,ic) + term*(deopb(j,ic)-d0(j,ic))
               hessx(j,id) = hessx(j,id) + term*(deopb(j,id)-d0(j,id))
            end do
c
c     find numerical y-components via perturbed structures
c
            old = y(i)
            y(i) = y(i) + eps
            call eopbend2a (iopbend)
            y(i) = old
            do j = 1, 3
               hessy(j,ia) = hessy(j,ia) + term*(deopb(j,ia)-d0(j,ia))
               hessy(j,ib) = hessy(j,ib) + term*(deopb(j,ib)-d0(j,ib))
               hessy(j,ic) = hessy(j,ic) + term*(deopb(j,ic)-d0(j,ic))
               hessy(j,id) = hessy(j,id) + term*(deopb(j,id)-d0(j,id))
            end do
c
c     find numerical z-components via perturbed structures
c
            old = z(i)
            z(i) = z(i) + eps
            call eopbend2a (iopbend)
            z(i) = old
            do j = 1, 3
               hessz(j,ia) = hessz(j,ia) + term*(deopb(j,ia)-d0(j,ia))
               hessz(j,ib) = hessz(j,ib) + term*(deopb(j,ib)-d0(j,ib))
               hessz(j,ic) = hessz(j,ic) + term*(deopb(j,ic)-d0(j,ic))
               hessz(j,id) = hessz(j,id) + term*(deopb(j,id)-d0(j,id))
            end do
         end if
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eopbend2a  --  out-of-plane bend derivatives  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "eopbend2a" calculates out-of-plane bending first derivatives
c     at a trigonal center via a Wilson-Decius-Cross angle bend;
c     used in computation of finite difference second derivatives
c
c
      subroutine eopbend2a (i)
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'math.i'
      include 'opbend.i'
      integer i,k
      integer ia,ib,ic,id
      real*8 angle,force
      real*8 dot,cosine
      real*8 dt,dt2,dt3,dt4
      real*8 deddt,term
      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 xpd,ypd,zpd
      real*8 rbd2,rpd2
      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
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 = kopb(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
      deopb(1,ia) = 0.0d0
      deopb(2,ia) = 0.0d0
      deopb(3,ia) = 0.0d0
      deopb(1,ib) = 0.0d0
      deopb(2,ib) = 0.0d0
      deopb(3,ib) = 0.0d0
      deopb(1,ic) = 0.0d0
      deopb(2,ic) = 0.0d0
      deopb(3,ic) = 0.0d0
      deopb(1,id) = 0.0d0
      deopb(2,id) = 0.0d0
      deopb(3,id) = 0.0d0
c
c     compute the out-of-plane bending angle
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,0)
         call image (xbd,ybd,zbd,0)
         call image (xcd,ycd,zcd,0)
      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
      xpd = xbd + xt*delta
      ypd = ybd + yt*delta
      zpd = zbd + zt*delta
      rbd2 = xbd*xbd + ybd*ybd + zbd*zbd
      rpd2 = xpd*xpd + ypd*ypd + zpd*zpd
      xm = ypd*zbd - zpd*ybd
      ym = zpd*xbd - xpd*zbd
      zm = xpd*ybd - ypd*xbd
      rm = sqrt(xm*xm + ym*ym + zm*zm)
      if (rm .ne. 0.0d0) then
         dot = xbd*xpd + ybd*ypd + zbd*zpd
         cosine = dot / sqrt(rbd2*rpd2)
         cosine = min (1.0d0,max(-1.0d0,cosine))
         angle = radian * acos(cosine)
c
c     get the out-of-plane bending master chain rule terms
c
         dt = angle
         dt2 = dt * dt
         dt3 = dt2 * dt
         dt4 = dt2 * dt2
         deddt = opbunit * 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 central atom and its projection
c
         term = -deddt / (rbd2*rm)
         dedxib = term * (ybd*zm-zbd*ym)
         dedyib = term * (zbd*xm-xbd*zm)
         dedzib = term * (xbd*ym-ybd*xm)
         term = deddt / (rpd2*rm)
         dedxip = term * (ypd*zm-zpd*ym)
         dedyip = term * (zpd*xm-xpd*zm)
         dedzip = term * (xpd*ym-ypd*xm)
c
c     chain rule terms for peripheral plane-defining atoms
c
         delta2 = 2.0d0 * delta
         ptrt2 = (dedxip*xt + dedyip*yt + dedzip*zt) / rt2
         term = (zcd*ybd-ycd*zbd) + delta2*(yt*zcd-zt*ycd)
         dedxia = delta*(ycd*dedzip-zcd*dedyip) + term*ptrt2
         term = (xcd*zbd-zcd*xbd) + delta2*(zt*xcd-xt*zcd)
         dedyia = delta*(zcd*dedxip-xcd*dedzip) + term*ptrt2
         term = (ycd*xbd-xcd*ybd) + delta2*(xt*ycd-yt*xcd)
         dedzia = delta*(xcd*dedyip-ycd*dedxip) + term*ptrt2
         term = (yad*zbd-zad*ybd) + delta2*(zt*yad-yt*zad)
         dedxic = delta*(zad*dedyip-yad*dedzip) + term*ptrt2
         term = (zad*xbd-xad*zbd) + delta2*(xt*zad-zt*xad)
         dedyic = delta*(xad*dedzip-zad*dedxip) + term*ptrt2
         term = (xad*ybd-yad*xbd) + delta2*(yt*xad-xt*yad)
         dedzic = delta*(yad*dedxip-xad*dedyip) + term*ptrt2
c
c     get out-of-plane atom chain rule terms by difference
c
         dedxid = -dedxia - dedxib - dedxic
         dedyid = -dedyia - dedyib - dedyic
         dedzid = -dedzia - dedzib - dedzic
c
c     set the out-of-plane bending derivatives
c
         deopb(1,ia) = dedxia
         deopb(2,ia) = dedyia
         deopb(3,ia) = dedzia
         deopb(1,ib) = dedxib
         deopb(2,ib) = dedyib
         deopb(3,ib) = dedzib
         deopb(1,ic) = dedxic
         deopb(2,ic) = dedyic
         deopb(3,ic) = dedzic
         deopb(1,id) = dedxid
         deopb(2,id) = dedyid
         deopb(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 angle bend; also
c     partitions the energy among the atoms
c
c
      subroutine eopbend3
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'opbend.i'
      include 'usage.i'
      integer i,iopbend
      integer ia,ib,ic,id
      real*8 e,angle,force
      real*8 dot,cosine,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 xpd,ypd,zpd
      real*8 rbd2,rpd2
      real*8 xt,yt,zt
      real*8 rt2,delta
      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
      header = .true.
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 = kopb(iopbend)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     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)
c
c     compute the out-of-plane bending angle
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,0)
               call image (xbd,ybd,zbd,0)
               call image (xcd,ycd,zcd,0)
            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
            xpd = xbd + xt*delta
            ypd = ybd + yt*delta
            zpd = zbd + zt*delta
            rbd2 = xbd*xbd + ybd*ybd + zbd*zbd
            rpd2 = xpd*xpd + ypd*ypd + zpd*zpd
            if (rbd2.ne.0.0d0 .and. rpd2.ne.0.0d0) then
               dot = xbd*xpd + ybd*ypd + zbd*zpd
               cosine = dot / sqrt(rbd2*rpd2)
               cosine = min (1.0d0,max(-1.0d0,cosine))
               angle = radian * acos(cosine)
c
c     find the out-of-plane angle bending energy
c
               dt = angle
               dt2 = dt * dt
               dt3 = dt2 * dt
               dt4 = dt2 * dt2
               e = opbunit * 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 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. 2.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,10)
   10                format (/,' Individual Out-of-Plane Bending',
     &                          ' Interactions :',
     &                       //,' Type',13x,'Atom Names',30x,'Angle',
     &                          6x,'Energy',/)
                  end if
                  write (iout,20)  ib,name(ib),id,name(id),angle,e
   20             format (' O-P-Bend',3x,i5,'-',a3,1x,i5,'-',a3,
     &                       22x,f10.4,f12.4)
               end if
            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 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
      implicit none
      include 'sizes.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'opdist.i'
      include 'usage.i'
      integer i,ia,ib,ic,id
      real*8 e,force,fgrp
      real*8 dt2,rt2
      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
      logical proceed
c
c
c     zero out the out-of-plane distance energy component
c
      eopd = 0.0d0
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 = kopd(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     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,0)
               call image (xbd,ybd,zbd,0)
               call image (xcd,ycd,zcd,0)
            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
c
c     find the out-of-plane distance energy
c
            e = opdunit * force * dt2
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
      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
      implicit none
      include 'sizes.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'opdist.i'
      include 'usage.i'
      include 'virial.i'
      integer i,ia,ib,ic,id
      real*8 e,force,fgrp
      real*8 dot,drt2
      real*8 dt2,deddt
      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 dedxia,dedyia,dedzia
      real*8 dedxib,dedyib,dedzib
      real*8 dedxic,dedyic,dedzic
      real*8 dedxid,dedyid,dedzid
      logical proceed
c
c
c     zero out 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
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 = kopd(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     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,0)
               call image (xbd,ybd,zbd,0)
               call image (xcd,ycd,zcd,0)
            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
c
c     find the out-of-plane energy and master chain rule terms
c
            e = opdunit * force * dt2
            deddt = 2.0d0 * opdunit * force * drt2
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 diagonal components
c
            virx = virx + xad*dedxia + xbd*dedxib + xcd*dedxic
            viry = viry + yad*dedyia + ybd*dedyib + ycd*dedyic
            virz = virz + zad*dedzia + zbd*dedzib + zcd*dedzic
         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 eopdist2  --  atom-wise 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)
      implicit none
      include 'sizes.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bound.i'
      include 'group.i'
      include 'hessn.i'
      include 'opdist.i'
      include 'usage.i'
      integer i,kopdist
      integer ia,ib,ic,id
      real*8 e,force,fgrp
      real*8 deddt,dt2,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 Hessian elements for the out-of-plane distances
c
      do kopdist = 1, nopdist
         ia = iopd(1,kopdist)
         ib = iopd(2,kopdist)
         ic = iopd(3,kopdist)
         id = iopd(4,kopdist)
         force = kopd(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,4,ia,ib,ic,id,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,0)
               call image (xbd,ybd,zbd,0)
               call image (xcd,ycd,zcd,0)
            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
            deddt = opdunit * force
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     abbreviations for second derivative chain rule terms
c
            term = 2.0d0 * 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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'angpot.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'opdist.i'
      include 'usage.i'
      integer i,ia,ib,ic,id
      real*8 e,force,fgrp
      real*8 dt2,rt2
      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
      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
      header = .true.
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 = kopd(i)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     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,0)
               call image (xbd,ybd,zbd,0)
               call image (xcd,ycd,zcd,0)
            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
c
c     find the out-of-plane distance energy
c
            e = opdunit * force * dt2
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. 2.0d0)
            if (debug .or. (verbose.and.huge)) then
               if (header) then
                  header = .false.
                  write (iout,10)
   10             format (/,' Individual Out-of-Plane Distance',
     &                       ' Interactions :',
     &                    //,' Type',23x,'Atom Names',17x,'Distance',
     &                       6x,'Energy',/)
               end if
               write (iout,20)  ia,name(ia),ib,name(ib),ic,
     &                          name(ic),id,name(id),sqrt(dt2),e
   20          format (' O-P-Dist',3x,i5,'-',a3,3(1x,i5,'-',a3),
     &                    2x,f10.4,f12.4)
            end if
         end if
      end do
      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)
      integer mode
      real*8 erf,x,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)
      integer mode
      real*8 erfc,x,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     xsmall   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)
      implicit none
      integer i,mode
      real*8 arg,result
      real*8 x,y,ysq,del
      real*8 sqrpi,thresh
      real*8 xnum,xden,xsmall,xbig
      real*8 a(5),b(4),c(9),d(8),p(6),q(5)
c
c     mathematical and machine-dependent constants
c
      data sqrpi  / 5.6418958354775628695d-1 /
      data thresh / 0.46875d0 /
      data xsmall / 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. thresh) then
         ysq = 0.0d0
         if (y .gt. xsmall)  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)
         result = exp(-ysq*ysq) * exp(-del) * result
         if (mode .eq. 0) then
            result = (0.5d0 - result) + 0.5d0
            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 = (sqrpi -  result) / y
            ysq = aint(16.0d0*y) / 16.0d0
            del = (y-ysq) * (y+ysq)
            result = exp(-ysq*ysq) * exp(-del) * result
         end if
         if (mode .eq. 0) then
            result = (0.5d0 - result) + 0.5d0
            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 erf for
c     a real 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 (y)
      implicit none
      include 'iounit.i'
      include 'math.i'
      real*8 erfinv,erf,x,y,z
      real*8 a(4),b(4),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(y) .le. 0.7d0) then
         z = y * y
         x = y * (((a(4)*z+a(3))*z+a(2))*z+a(1))
     &              / ((((b(4)*z+b(3))*z+b(2))*z+b(1))*z+1.0d0)
      else if (y.gt.0.7d0 .and. y.lt.1.0d0) then
         z = sqrt(-log((1.0d0-y)/2.0d0))
         x = (((c(4)*z+c(3))*z+c(2))*z+c(1)) / ((d(2)*z+d(1))*z+1.0d0)
      else if (y.lt.-0.7d0 .and. y.gt.-1.0d0) then
         z = sqrt(-log((1.0d0+y)/2.0d0))
         x = -(((c(4)*z+c(3))*z+c(2))*z+c(1)) / ((d(2)*z+d(1))*z+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
      x = x - (erf(x) - y) / (2.0d0/sqrtpi * exp(-x**2))
      x = x - (erf(x) - y) / (2.0d0/sqrtpi * exp(-x**2))
      erfinv = x
      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
c
      subroutine erxnfld
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'chgpot.i'
      include 'energi.i'
      include 'mpole.i'
      include 'shunt.i'
      include 'usage.i'
      integer i,j,k
      integer ii,iz,ix
      integer kk,kz,kx
      real*8 eik,r2
      real*8 xr,yr,zr
      real*8 rpi(13),rpk(13)
      real*8 a(3,3)
      logical iuse,kuse
c
c
c     zero out the macroscopic reaction field energy
c
      er = 0.0d0
c
c     set the switching function coefficients
c
      call switch ('CHARGE')
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
c
c
      call ijk_pt
c
c     calculate the multipole interaction energy term
c
      do ii = 1, npole
         i = ipole(ii)
         iz = zaxis(ii)
         ix = xaxis(ii)
         iuse = (use(i) .or. use(iz) .or. use(ix))
         do j = 1, polsiz(ii)
            rpi(j) = rpole(j,ii)
         end do
         do kk = ii, npole
            k = ipole(kk)
            kz = zaxis(kk)
            kx = xaxis(kk)
            kuse = (use(k) .or. use(kz) .or. use(kx))
            if (iuse .or. kuse) 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(kk)
                     rpk(j) = rpole(j,kk)
                  end do
                  call erfik (ii,kk,i,k,rpi,rpk,eik)
                  er = er + 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
      subroutine erfik (ii,kk,i,k,rpi,rpk,eik)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'chgpot.i'
      include 'mpole.i'
      include 'rxnfld.i'
      include 'rxnpot.i'
      include 'units.i'
      integer i,k,ii,kk
      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),ind1_y(13),ind1_z(13)
      integer ind2_x(13),ind2_y(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     integer ind_x,ind_y,ind_z
c     real*8 d1d2_r1,d1d2_r2s,d1d2_r2t,d1d2_r2u,d1d2_r2i
c     real*8 d1d2_r2is,d1d2_r2it,d1d2_r2iu,d1d2_r2j
c     real*8 d1d2_r2js,d1d2_r2jt,d1d2_r2ju,d1d2_r2k,d1d2_r
c
c
c     get numbers of the atoms
c
      isiz = polsiz(ii)
      ksiz = polsiz(kk)
      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 areas
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.d0*xi*yi*d - 3.0d0*ri2*(xi*yk+xk*yi)
         b1(1,7) = 15.d0*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.d0*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.d0*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.d0*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.d0*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  ##
c     ##                      ##
c     ##########################
c
c
      subroutine rfindex (n,m,ind_x,ind_y,ind_z,p_s,p_e)
      implicit none
      integer i,j,k,n,m,p_s,p_e
      integer ind_x(m),ind_y(m),ind_z(m)
c
c
      p_s = 1
      p_e = 1
c
c
      do i = 1, m
         ind_x(i) = 0
         ind_y(i) = 0
         ind_z(i) = 0
      end do
c
c
      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 ijk_pt  ##
c     ##                     ##
c     #########################
c
c
      subroutine ijk_pt
      implicit none
      include 'rxnfld.i'
      integer i,j,k
c
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  ##
c     ##                 ##
c     #####################
c
c
      function d1d2 (n,x1,y1,z1,x2,y2,z2,d,r1sq,r2sq,i,j,k,s,t,u)
      implicit none
      include 'rxnfld.i'
      integer n,i,j,k,s,t,u
      integer is,it,iu,js,jt,ju,ks,kt,ku
      real*8 x1,y1,z1,x2,y2,z2
      real*8 d1d2,d,r1sq,r2sq,f,g
c
c
      if (n.lt.i+j+k  .or. n.lt.s+t+u) then
         d1d2 = 0.0d0
         return
      end if
c
c
      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
c
c
      f = d*b1(ijk(i,j,k),ijk(s,t,u))
      g = r1sq*r2sq*b2(ijk(i,j,k),ijk(s,t,u))
c
c
      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
c
c
      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
c
c
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'energi.i'
      integer i,j
c
c
c     zero out macroscopic reaction field energy and derivatives
c
      er = 0.0d0
      do i = 1, n
         do j = 1, 3
            der(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  --  atom-wise 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
      subroutine erxnfld3
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'chgpot.i'
      include 'energi.i'
      include 'inform.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'shunt.i'
      include 'usage.i'
      integer i,j,k
      integer ii,iz,ix
      integer kk,kz,kx
      real*8 eik,xr,yr,zr
      real*8 r2,r,di,dk
      real*8 rpi(13),rpk(13)
      real*8 a(3,3)
      logical iuse,kuse
      logical header,huge
c
c
c     zero out the reaction field energy and partitioning
c
      ner = 0
      er = 0.0d0
      do i = 1, n
         aer(i) = 0.0d0
      end do
      header = .true.
c
c     set the switching function coefficients
c
      call switch ('CHARGE')
c
c     rotate the multipole components into the global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
c
c
      call ijk_pt
c
c     calculate the reaction field interaction energy term
c
      do ii = 1, npole
         i = ipole(ii)
         iz = zaxis(ii)
         ix = xaxis(ii)
         iuse = (use(i) .or. use(iz) .or. use(ix))
         do j = 1, polsiz(ii)
            rpi(j) = rpole(j,ii)
         end do
         do kk = ii, npole
            k = ipole(kk)
            kz = zaxis(kk)
            kx = xaxis(kk)
            kuse = (use(k) .or. use(kz) .or. use(kx))
            if (iuse .or. kuse) 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(kk)
                     rpk(j) = rpole(j,kk)
                  end do
                  call erfik (ii,kk,i,k,rpi,rpk,eik)
                  ner = ner + 1
                  er = er + eik
                  aer(i) = aer(i) + 0.5d0*eik
                  aer(k) = aer(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,10)
   10                   format (/,' Individual Reaction Field',
     &                             ' Interactions :',
     &                          //,' Type',13x,'Atom Names',
     &                             9x,'Dist from Origin',4x,'R(1-2)',
     &                             6x,'Energy',/)
                     end if
                     r = sqrt(r2)
                     di = sqrt(x(i)**2 + y(i)**2 + z(i)**2)
                     dk = sqrt(x(k)**2 + y(k)**2 + z(k)**2)
                     write (iout,20)  i,name(i),k,name(k),di,dk,r,eik
   20                format (' RxnFld',5x,i5,'-',a3,1x,i5,'-',a3,
     &                          2x,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     ##              All Rights Reserved              ##
c     ###################################################
c
c     ########################################################
c     ##                                                    ##
c     ##  subroutine esolv  --  continuum solvation energy  ##
c     ##                                                    ##
c     ########################################################
c
c
c     "esolv" calculates the continuum solvation energy via
c     either the Eisenberg-McLachlan ASP model, Ooi-Scheraga
c     SASA model, various GB/SA methods or the ACE model
c
c
      subroutine esolv
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'energi.i'
      include 'math.i'
      include 'potent.i'
      include 'solute.i'
      include 'warp.i'
      integer i
      real*8 e,ai,ri,rb
      real*8 term,probe
      real*8 aes(maxatm)
      real*8 des(3,maxatm)
c
c
c     zero out the continuum solvation energy
c
      es = 0.0d0
c
c     set a value for the solvent molecule probe radius
c
      probe = 1.4d0
c
c     get the Born radius values for the GB/SA models
c
      if (use_gbsa)  call born
c
c     compute the nonpolar solvation via the ACE approximation
c
      if (use_gbsa .and. solvtyp.ne.'ONION') then
         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
               es = es + e
            end if
         end do
c
c     compute the nonpolar solvation via exact surface area
c
      else
         call surface (es,aes,des,rsolv,asolv,probe)
      end if
c
c     get the polarization energy term for GB/SA solvation
c
      if (use_gbsa) then
         if (use_deform) then
            call egbsa0b
         else
            call egbsa0a
         end if
      end if
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine egbsa0a  --  GB/SA polarization energy term  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "egbsa0a" calculates the generalized Born polarization energy
c     for the GB/SA and ACE solvation models
c
c
      subroutine egbsa0a
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'energi.i'
      include 'group.i'
      include 'shunt.i'
      include 'solute.i'
      include 'units.i'
      include 'usage.i'
      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,iuse
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
      call switch ('CHARGE')
c
c     calculate GB/SA electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do kk = ii, nion
            k = iion(kk)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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(kk)
                  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/SA solvation energy component
c
                  if (i .eq. k)  e = 0.5d0 * e
                  es = es + e
               end if
            end if
         end do
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine egbsa0b  --  GB/SA polarization for smoothing  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "egbsa0b" calculates the generalized Born polarization energy
c     for the GB/SA and ACE solvation models for use with potential
c     smoothing methods via analogy to the smoothing of Coulomb's law
c
c
      subroutine egbsa0b
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'energi.i'
      include 'group.i'
      include 'solute.i'
      include 'units.i'
      include 'usage.i'
      include 'warp.i'
      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,iuse
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     scale extent of smoothing by the diffusion coefficient
c
      sterm = 0.5d0 / sqrt(diffc)
c
c     calculate GB/SA electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do kk = ii, nion
            k = iion(kk)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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(kk)
               rb2 = rborn(i) * rborn(k)
               fgb = sqrt(r2 + rb2*exp(-0.25d0*r2/rb2))
               e = fik / fgb
c
c     use a smoothable GB/SA analogous to Coulomb's law solution
c
               if (deform .ne. 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/SA 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     ##  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 continuum solvation energy and
c     first derivatives with respect to Cartesian coordinates
c     using either the Eisenberg-McLachlan ASP, Ooi-Scheraga
c     SASA or various GB/SA solvation models
c
c
      subroutine esolv1
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'energi.i'
      include 'math.i'
      include 'potent.i'
      include 'solute.i'
      include 'warp.i'
      integer i
      real*8 e,ai,ri,rb
      real*8 term,probe
      real*8 aes(maxatm)
c
c
c     zero out the continuum solvation energy and derivatives
c
      es = 0.0d0
      do i = 1, n
         drb(i) = 0.0d0
         des(1,i) = 0.0d0
         des(2,i) = 0.0d0
         des(3,i) = 0.0d0
      end do
c
c     set a value for the solvent molecule probe radius
c
      probe = 1.4d0
c
c     get the atomic Born radii values for the GB/SA models
c
      if (use_gbsa)  call born
c
c     compute the nonpolar solvation via ACE approximation
c
      if (use_gbsa .and. solvtyp.ne.'ONION') then
         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
               es = es + e
               drb(i) = drb(i) - 6.0d0*e/rb
            end if
         end do
c
c     compute the nonpolar solvation via exact surface area
c
      else
         call surface (es,aes,des,rsolv,asolv,probe)
      end if
c
c     compute the generalized Born polarization solvation
c
      if (use_gbsa) then
         if (use_deform) then
            call egbsa1b
         else
            call egbsa1a
         end if
      end if
c
c     increment derivatives due to Born radii chain rule terms
c
      if (use_gbsa)  call born1
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine egbsa1a  --  GB/SA energy and derivatives  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "egbsa1a" calculates the generalized Born energy and first
c     derivatives with respect to Cartesian coordinates for the
c     GB/SA solvation models
c
c     note application of distance cutoff scaling directly to
c     the Born radii chain rule term "derb" is an approximation 
c
c
      subroutine egbsa1a
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'solute.i'
      include 'units.i'
      include 'usage.i'
      include 'virial.i'
      integer i,k,ii,kk
      real*8 e,de,fgrp
      real*8 f,fi,fik
      real*8 fgb,fgb2
      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
      logical proceed,iuse
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
      call switch ('CHARGE')
c
c     calculate GB/SA electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         rbi = rborn(i)
         do kk = ii, nion
            k = iion(kk)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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(kk)
                  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
                  shift = fik / sqrt(rm2 + rb2*exp(-0.25d0*rm2/rb2))
                  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 diagonal components
c
                     virx = virx + xr*dedx
                     viry = viry + yr*dedy
                     virz = virz + zr*dedz
                  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
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine egbsa1b  --  GB/SA energy/derivs for smoothing  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "egbsa1b" calculates the generalized Born energy and first
c     derivatives with respect to Cartesian coordinates for the
c     GB/SA solvation models
c
c
      subroutine egbsa1b
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'math.i'
      include 'molcul.i'
      include 'solute.i'
      include 'units.i'
      include 'usage.i'
      include 'virial.i'
      include 'warp.i'
      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
      logical proceed,iuse
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     scale extent of smoothing by the diffusion coefficient
c
      sterm = 0.5d0 / sqrt(diffc)
c
c     calculate GB/SA electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         rbi = rborn(i)
         do kk = ii, nion
            k = iion(kk)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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(kk)
               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/SA analogous to the Coulomb solution
c
               if (deform .ne. 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) / sqrtpi
                  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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
               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 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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'deriv.i'
      include 'math.i'
      include 'solute.i'
      include 'units.i'
      include 'virial.i'
      integer i,j,k,it,kt
      integer skip(maxatm)
      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,term,theta
      real*8 rb2,ri,rk,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 expterm,rusum
      real*8 dedx,dedy,dedz
c
c
c     get Born radius chain rule components for the Still method
c
      if (solvtyp .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
                  de = drb(i) * p4 * gpi * vk * (4.0d0*ccf-dccf) / r6
c
c     increment the overall continuum 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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
               end if
            end do
         end do
c
c     get Born radius chain rule components for the HCT method
c
      else if (solvtyp .eq. 'HCT') then
         do i = 1, n
            xi = x(i)
            yi = y(i)
            zi = z(i)
            ri = rsolv(i) + doffset
            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
                  rk = rsolv(k) + doffset
                  sk = rk * shct(k)
                  sk2 = sk * sk
                  r2 = xr**2 + yr**2 + zr**2
                  r = sqrt(r2)
                  if (ri .lt. r+sk) then
                     lik = 1.0d0 / max(ri,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
                     de = drb(i) * rb2 * (dlik*t1+duik*t2+t3) / r
c
c     increment the overall continuum 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 diagonal components
c
                     virx = virx + xr*dedx
                     viry = viry + yr*dedy
                     virz = virz + zr*dedz
                  end if
               end if
            end do
         end do
c
c     get Born radius chain rule components for the ACE method
c
      else if (solvtyp .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
                  de = drb(i) * rbi2 * (de1+vk*ratio**3*de2/pi) / r
c
c     increment the overall continuum 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 diagonal components
c
                  virx = virx + xr*dedx
                  viry = viry + yr*dedy
                  virz = virz + zr*dedz
               end if
            end do
         end do
      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 esolv2  --  atom-by-atom solvation Hessian  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "esolv2" calculates second derivatives of the continuum
c     solvation energy using either the Eisenberg-McLachlan ASP,
c     Ooi-Scheraga SASA or various GB/SA solvation models
c
c
      subroutine esolv2 (i)
      implicit none
      include 'sizes.i'
      include 'potent.i'
      include 'solute.i'
      include 'warp.i'
      integer i
      real*8 probe
c     real*8 aes(maxatm)
c     real*8 des(3,maxatm)
c
c
c     set a value for the solvent molecule probe radius
c
      probe = 1.4d0
c
c     compute the surface area-based solvation energy term
c
c     call surface (es,aes,des,rsolv,asolv,probe)
c
c     get the generalized Born term for GB/SA solvation
c
      if (use_gbsa) then
         if (use_deform) then
            call egbsa2b (i)
         else
            call egbsa2a (i)
         end if
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine egbsa2a  --  atom-wise GB/SA solvation Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "egbsa2a" calculates second derivatives of the generalized
c     Born energy term for the GB/SA solvation models
c
c
      subroutine egbsa2a (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'hessn.i'
      include 'shunt.i'
      include 'solute.i'
      include 'units.i'
      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)
c
c
c     first see if the atom of interest carries a charge
c
      do k = 1, nion
         if (iion(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
      call switch ('CHARGE')
c
c     calculate GB/SA 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(kk)
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 non-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 egbsa2b  --  GB/SA solvation Hessian; smoothing  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "egbsa2b" calculates second derivatives of the generalized
c     Born energy term for the GB/SA solvation models via analogy
c     to the smoothing of Coulomb's law
c
c
      subroutine egbsa2b (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'hessn.i'
      include 'math.i'
      include 'solute.i'
      include 'units.i'
      include 'warp.i'
      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)
c
c
c     first see if the atom of interest carries a charge
c
      do k = 1, nion
         if (iion(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     scale extent of smoothing by the diffusion coefficient
c
      sterm = 0.5d0 / sqrt(diffc)
c
c     calculate GB/SA 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(kk)
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/SA analogous to the Coulomb solution
c
            if (deform .ne. 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) / sqrtpi
               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 non-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 continuum solvation energy using
c     either the Eisenberg-McLachlan ASP model, Ooi-Scheraga
c     SASA model, various GB/SA methods or the ACE model; also
c     partitions the energy among the atoms
c
c
      subroutine esolv3
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'energi.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'potent.i'
      include 'solute.i'
      include 'warp.i'
      integer i
      real*8 e,ai,ri,rb
      real*8 term,probe
      real*8 aesa(maxatm)
      real*8 des(3,maxatm)
      logical header,huge
c
c
c     zero out the continuum solvation energy and partitioning
c
      nes = 0
      es = 0.0d0
      do i = 1, n
         aes(i) = 0.0d0
      end do
c
c     set a value for the solvent molecule probe radius
c
      probe = 1.4d0
c
c     get the Born radius values for the GB/SA models
c
      if (use_gbsa)  call born
c
c     compute the nonpolar solvation via the ACE approximation
c
      if (use_gbsa .and. solvtyp.ne.'ONION') then
         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
               es = es + e
               nes = nes + 1
               aes(i) = aes(i) + e
            end if
         end do
c
c     compute the nonpolar solvation via exact surface area
c
      else
         nes = n
         call surface (es,aes,des,rsolv,asolv,probe)
      end if
c
c     store the nonpolar or surface area energy for each atom
c
      do i = 1, n
         aesa(i) = aes(i)
      end do
c
c     get the generalized Born term for GB/SA solvation
c
      if (use_gbsa) then
         if (use_deform) then
            call egbsa3b
         else
            call egbsa3a
         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',11x,'Atom Name',19x,'Surface',
     &                    7x,'Polar',6x,'Energy',/)
            end if
            write (iout,20)  i,name(i),aesa(i),aes(i)-aesa(i),aes(i)
   20       format (' Solvate',7x,i5,'-',a3,15x,3f12.4)
         end if
      end do
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine egbsa3a  --  GB/SA polarization energy/analysis  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "egbsa3a" calculates the generalized Born energy term for
c     the GB/SA and ACE solvation models; also partitions the energy
c     among the atoms
c
c
      subroutine egbsa3a
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atoms.i'
      include 'charge.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'shunt.i'
      include 'solute.i'
      include 'units.i'
      include 'usage.i'
      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,iuse
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
      call switch ('CHARGE')
c
c     calculate GB/SA electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do kk = ii, nion
            k = iion(kk)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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(kk)
                  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/SA 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
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine egbsa3b  --  GB/SA polar analysis for smoothing  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "egbsa3b" calculates the generalized Born polarization energy
c     for the GB/SA and ACE solvation models for use with potential
c     smoothing methods via analogy to the smoothing of Coulomb's
c     law; also partitions the energy among the atoms
c
c
      subroutine egbsa3b
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atoms.i'
      include 'charge.i'
      include 'energi.i'
      include 'group.i'
      include 'inter.i'
      include 'molcul.i'
      include 'solute.i'
      include 'units.i'
      include 'usage.i'
      include 'warp.i'
      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,iuse
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     scale extent of smoothing by the diffusion coefficient
c
      sterm = 0.5d0 / sqrt(diffc)
c
c     calculate GB/SA electrostatic polarization energy term
c
      do ii = 1, nion
         i = iion(ii)
         iuse = use(i)
         xi = x(i)
         yi = y(i)
         zi = z(i)
         fi = f * pchg(ii)
         do kk = ii, nion
            k = iion(kk)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,2,i,k,0,0,0)
            if (proceed)  proceed = (iuse .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(kk)
               rb2 = rborn(i) * rborn(k)
               fgb = sqrt(r2 + rb2*exp(-0.25d0*r2/rb2))
               e = fik / fgb
c
c     use a smoothable GB/SA analogous to the Coulomb solution
c
               if (deform .ne. 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/SA 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     ##  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
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'math.i'
      include 'strbnd.i'
      include 'usage.i'
      integer i,j,k,istrbnd
      integer ia,ib,ic
      real*8 e,dr,dt,fgrp
      real*8 angle,force
      real*8 dot,cosine
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 rab,xab,yab,zab
      real*8 rcb,xcb,ycb,zcb
      logical proceed
c
c
c     zero out the stretch-bend cross term energy
c
      eba = 0.0d0
c
c     calculate the stretch-bend energy term
c
      do istrbnd = 1, nstrbnd
         i = isb(1,istrbnd)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         force = ksb(istrbnd)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,3,ia,ib,ic,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,0)
               call image (xcb,ycb,zcb,0)
            end if
            rab = sqrt(xab*xab + yab*yab + zab*zab)
            rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
            if (rab*rcb .ne. 0.0d0) then
               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
               dr = 0.0d0
               j = isb(2,istrbnd)
               k = isb(3,istrbnd)
               if (j .ne. 0)  dr = dr + rab - bl(j)
               if (k .ne. 0)  dr = dr + rcb - bl(k)
               e = stbnunit * force * dt * dr
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 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 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
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'math.i'
      include 'strbnd.i'
      include 'usage.i'
      include 'virial.i'
      integer i,j,k,istrbnd
      integer ia,ib,ic
      real*8 e,dt,dr,fgrp
      real*8 angle,force
      real*8 dot,cosine
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab,rab
      real*8 xcb,ycb,zcb,rcb
      real*8 xp,yp,zp,rp
      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 term,terma,termc
      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
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)
         force = ksb(istrbnd)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,3,ia,ib,ic,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,0)
               call image (xcb,ycb,zcb,0)
            end if
            rab = sqrt(xab*xab + yab*yab + zab*zab)
            rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
            xp = ycb*zab - zcb*yab
            yp = zcb*xab - xcb*zab
            zp = xcb*yab - ycb*xab
            rp = sqrt(xp*xp + yp*yp + zp*zp)
            if (rp .ne. 0.0d0) then
               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)
               terma = -radian / (rab*rab*rp)
               termc = radian / (rcb*rcb*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)
c
c     find chain rule terms for the bond length deviations
c
               dr = 0.0d0
               terma = 0.0d0
               termc = 0.0d0
               term = stbnunit * force
               j = isb(2,istrbnd)
               k = isb(3,istrbnd)
               if (j .ne. 0) then
                  dr = dr + rab - bl(j)
                  terma = 1.0d0 / rab
               end if
               if (k .ne. 0) then
                  dr = dr + rcb - bl(k)
                  termc = 1.0d0 / rcb
               end if
               ddrdxia = terma * xab
               ddrdyia = terma * yab
               ddrdzia = terma * zab
               ddrdxic = termc * xcb
               ddrdyic = termc * ycb
               ddrdzic = termc * zcb
c
c     scale the interaction based on its group membership
c
               if (use_group)  term = term * fgrp
c
c     get the energy and master chain rule terms for derivatives
c
               e = term * dt * dr
               dedxia = term * (dt*ddrdxia+ddtdxia*dr)
               dedyia = term * (dt*ddrdyia+ddtdyia*dr)
               dedzia = term * (dt*ddrdzia+ddtdzia*dr)
               dedxic = term * (dt*ddrdxic+ddtdxic*dr)
               dedyic = term * (dt*ddrdyic+ddtdyic*dr)
               dedzic = term * (dt*ddrdzic+ddtdzic*dr)
               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 diagonal components
c
               virx = virx + xab*dedxia + xcb*dedxic
               viry = viry + yab*dedyia + ycb*dedyic
               virz = virz + zab*dedzia + zcb*dedzic
            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 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)
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'group.i'
      include 'hessn.i'
      include 'math.i'
      include 'strbnd.i'
      integer i,j,k,iatom
      integer ia,ib,ic,istrbnd
      real*8 angle,force
      real*8 dot,cosine
      real*8 dt,dr,fgrp
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 xab,yab,zab,rab
      real*8 xcb,ycb,zcb,rcb
      real*8 xp,yp,zp,rp,rp2
      real*8 term,terma,termc
      real*8 xrab,yrab,zrab,rab2
      real*8 xrcb,yrcb,zrcb,rcb2
      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     compute the Hessian elements of the stretch-bends
c
      do istrbnd = 1, nstrbnd
         i = isb(1,istrbnd)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         force = ksb(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,3,ia,ib,ic,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,0)
               call image (xcb,ycb,zcb,0)
            end if
            rab = sqrt(xab*xab + yab*yab + zab*zab)
            rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
            xp = ycb*zab - zcb*yab
            yp = zcb*xab - xcb*zab
            zp = xcb*yab - ycb*xab
            rp = sqrt(xp*xp + yp*yp + zp*zp)
            if (rp .ne. 0.0d0) then
               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)
               terma = -radian / (rab*rab*rp)
               termc = radian / (rcb*rcb*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
               rab2 = 2.0d0 / (rab*rab)
               xrab = xab * rab2
               yrab = yab * rab2
               zrab = zab * rab2
               rcb2 = 2.0d0 / (rcb*rcb)
               xrcb = xcb * rcb2
               yrcb = ycb * rcb2
               zrcb = 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 = terma*(xab*xcb-dot) + ddtdxia*(xcbp-xrab)
               dtxiayia = terma*(zp+yab*xcb) + ddtdxia*(ycbp-yrab)
               dtxiazia = terma*(zab*xcb-yp) + ddtdxia*(zcbp-zrab)
               dtyiayia = terma*(yab*ycb-dot) + ddtdyia*(ycbp-yrab)
               dtyiazia = terma*(xp+zab*ycb) + ddtdyia*(zcbp-zrab)
               dtziazia = terma*(zab*zcb-dot) + ddtdzia*(zcbp-zrab)
               dtxicxic = termc*(dot-xab*xcb) - ddtdxic*(xabp+xrcb)
               dtxicyic = termc*(zp-ycb*xab) - ddtdxic*(yabp+yrcb)
               dtxiczic = -termc*(yp+zcb*xab) - ddtdxic*(zabp+zrcb)
               dtyicyic = termc*(dot-yab*ycb) - ddtdyic*(yabp+yrcb)
               dtyiczic = termc*(xp-zcb*yab) - ddtdyic*(zabp+zrcb)
               dtziczic = termc*(dot-zab*zcb) - ddtdzic*(zabp+zrcb)
               dtxiaxic = terma*(yab*yab+zab*zab) - ddtdxia*xabp
               dtxiayic = -terma*xab*yab - ddtdxia*yabp
               dtxiazic = -terma*xab*zab - ddtdxia*zabp
               dtyiaxic = -terma*xab*yab - ddtdyia*xabp
               dtyiayic = terma*(xab*xab+zab*zab) - ddtdyia*yabp
               dtyiazic = -terma*yab*zab - ddtdyia*zabp
               dtziaxic = -terma*xab*zab - ddtdzia*xabp
               dtziayic = -terma*yab*zab - ddtdzia*yabp
               dtziazic = terma*(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
               dr = 0.0d0
               terma = 0.0d0
               termc = 0.0d0
               term = stbnunit * force
               j = isb(2,istrbnd)
               k = isb(3,istrbnd)
               if (j .ne. 0) then
                  dr = dr + term*(rab-bl(j))
                  terma = term / rab
               end if
               if (k .ne. 0) then
                  dr = dr + term*(rcb-bl(k))
                  termc = term / rcb
               end if
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  dr = dr * fgrp
                  terma = terma * fgrp
                  termc = termc * fgrp
               end if
c
c     first derivatives of bond length with respect to coordinates
c
               ddrdxia = terma * xab
               ddrdyia = terma * yab
               ddrdzia = terma * zab
               ddrdxic = termc * xcb
               ddrdyic = termc * ycb
               ddrdzic = termc * 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 = terma * (1.0d0-xab**2)
               drxiayia = -terma * xab*yab
               drxiazia = -terma * xab*zab
               dryiayia = terma * (1.0d0-yab**2)
               dryiazia = -terma * yab*zab
               drziazia = terma * (1.0d0-zab**2)
               drxicxic = termc * (1.0d0-xcb**2)
               drxicyic = -termc * xcb*ycb
               drxiczic = -termc * xcb*zcb
               dryicyic = termc * (1.0d0-ycb**2)
               dryiczic = -termc * ycb*zcb
               drziczic = termc * (1.0d0-zcb**2)
               drxibxib = drxiaxia + drxicxic
               drxibyib = drxiayia + drxicyic
               drxibzib = drxiazia + drxiczic
               dryibyib = dryiayia + dryicyic
               dryibzib = dryiazia + dryiczic
               drzibzib = drziazia + drziczic
c
c     increment diagonal and non-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 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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'strbnd.i'
      include 'usage.i'
      integer i,j,k,istrbnd
      integer ia,ib,ic
      real*8 e,dr,dt,fgrp
      real*8 angle,force
      real*8 dot,cosine
      real*8 xia,yia,zia
      real*8 xib,yib,zib
      real*8 xic,yic,zic
      real*8 rab,xab,yab,zab
      real*8 rcb,xcb,ycb,zcb
      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
      header = .true.
c
c     calculate the stretch-bend energy term
c
      do istrbnd = 1, nstrbnd
         i = isb(1,istrbnd)
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         force = ksb(istrbnd)
c
c     decide whether to compute the current interaction
c
         proceed = .true.
         if (use_group)  call groups (proceed,fgrp,3,ia,ib,ic,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,0)
               call image (xcb,ycb,zcb,0)
            end if
            rab = sqrt(xab*xab + yab*yab + zab*zab)
            rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
            if (rab*rcb .ne. 0.0d0) then
               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
               dr = 0.0d0
               j = isb(2,istrbnd)
               k = isb(3,istrbnd)
               if (j .ne. 0)  dr = dr + rab - bl(j)
               if (k .ne. 0)  dr = dr + rcb - bl(k)
               e = stbnunit * force * dt * dr
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. 2.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,10)
   10                format (/,' Individual Stretch-Bend Cross Term',
     &                          ' Interactions :',
     &                       //,' Type',17x,'Atom Names',16x,'dBond',
     &                          4x,'dAngle',6x,'Energy',/)
                  end if
                  write (iout,20)  ia,name(ia),ib,name(ib),
     &                             ic,name(ic),dr,dt,e
   20             format (' StrBend',4x,i5,'-',a3,1x,i5,'-',a3,
     &                       1x,i5,'-',a3,2x,2f10.4,f12.4)
               end if
            end if
         end if
      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 estrtor  --  stretch-torsion cross term energy  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "estrtor" calculates the stretch-torsion potential energy
c
c
      subroutine estrtor
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'strtor.i'
      include 'torpot.i'
      include 'tors.i'
      include 'usage.i'
      integer i,k,istrtor
      integer ia,ib,ic,id
      real*8 e,rcb,dr,fgrp
      real*8 rt2,ru2,rtru
      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
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,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the torsional angle
c
         if (proceed) then
            xia = x(ia)
            yia = y(ia)
            zia = z(ia)
            xib = x(ib)
            yib = y(ib)
            zib = z(ib)
            xic = x(ic)
            yic = y(ic)
            zic = z(ic)
            xid = x(id)
            yid = y(id)
            zid = z(id)
            xba = xib - xia
            yba = yib - yia
            zba = zib - zia
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            if (use_polymer) then
               call image (xba,yba,zba,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the stretch-torsional parameters for this angle
c
               v1 = kst(1,istrtor)
               c1 = tors1(3,i)
               s1 = tors1(4,i)
               v2 = kst(2,istrtor)
               c2 = tors2(3,i)
               s2 = tors2(4,i)
               v3 = kst(3,istrtor)
               c3 = tors3(3,i)
               s3 = tors3(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 bond-stretch for the central bond
c
               k = ist(2,istrtor)
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               dr = rcb - bl(k)
c
c     compute the stretch-torsion energy for this angle
c
               e = storunit * dr * (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 stretch-torsion energy
c
               ebt = ebt + e
            end if
         end if
      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 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'strtor.i'
      include 'torpot.i'
      include 'tors.i'
      include 'usage.i'
      include 'virial.i'
      integer i,k,istrtor
      integer ia,ib,ic,id
      real*8 e,rcb,dr,fgrp
      real*8 ddr,dedphi
      real*8 rt2,ru2,rtru
      real*8 ddrdx,ddrdy,ddrdz
      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 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
      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
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,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the torsional angle
c
         if (proceed) then
            xia = x(ia)
            yia = y(ia)
            zia = z(ia)
            xib = x(ib)
            yib = y(ib)
            zib = z(ib)
            xic = x(ic)
            yic = y(ic)
            zic = z(ic)
            xid = x(id)
            yid = y(id)
            zid = z(id)
            xba = xib - xia
            yba = yib - yia
            zba = zib - zia
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            if (use_polymer) then
               call image (xba,yba,zba,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the stretch-torsional parameters for this angle
c
               v1 = kst(1,istrtor)
               c1 = tors1(3,i)
               s1 = tors1(4,i)
               v2 = kst(2,istrtor)
               c2 = tors2(3,i)
               s2 = tors2(4,i)
               v3 = kst(3,istrtor)
               c3 = tors3(3,i)
               s3 = tors3(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 the bond-stretch for the central bond
c
               k = ist(2,istrtor)
               dr = rcb - bl(k)
c
c     calculate stretch-torsion energy and chain rule terms
c
               e = storunit * dr * (v1*phi1 + v2*phi2 + v3*phi3)
               dedphi = storunit * dr * (v1*dphi1 + v2*dphi2 + v3*dphi3)
               ddr = e / (dr * rcb)
c
c     scale the interaction based on its group membership
c
               if (use_group) then
                  e = e * fgrp
                  dedphi = dedphi * fgrp
                  ddr = ddr * fgrp
               end if
c
c     first derivative components for the bond stretch
c
               ddrdx = xcb * ddr
               ddrdy = ycb * ddr
               ddrdz = zcb * ddr
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,0)
                  call image (xdb,ydb,zdb,0)
               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 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 - 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 + ddrdx
               dedyic = xba*dedzt - zba*dedxt + zdb*dedxu
     &                     - xdb*dedzu + ddrdy
               dedzic = yba*dedxt - xba*dedyt + xdb*dedyu
     &                     - ydb*dedxu + ddrdz
               dedxid = zcb*dedyu - ycb*dedzu
               dedyid = xcb*dedzu - zcb*dedxu
               dedzid = ycb*dedxu - xcb*dedyu
c
c     increment the stretch-torsion energy and gradient
c
               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 diagonal components
c
               virx = virx - xba*dedxia + xdc*dedxid
     &                     + xcb*(dedxic+dedxid)
               viry = viry - yba*dedyia + ydc*dedyid
     &                     + ycb*(dedyic+dedyid)
               virz = virz - zba*dedzia + zdc*dedzid
     &                     + zcb*(dedzic+dedzid)
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine estrtor2  --  atom-wise 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'group.i'
      include 'hessn.i'
      include 'strtor.i'
      include 'torpot.i'
      include 'tors.i'
      integer i,j,k,istrtor
      integer ia,ib,ic,id
      real*8 dedphi,d2edphi2,fgrp
      real*8 rt2,ru2,rtru,rcb
      real*8 xt,yt,zt,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     compute the Hessian elements of the stretch-torsions
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,4,ia,ib,ic,id,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,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the stretch-torsional parameters for this angle
c
               v1 = kst(1,istrtor)
               c1 = tors1(3,i)
               s1 = tors1(4,i)
               v2 = kst(2,istrtor)
               c2 = tors2(3,i)
               s2 = tors2(4,i)
               v3 = kst(3,istrtor)
               c3 = tors3(3,i)
               s3 = tors3(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)
               d2phi1 = -(cosine*c1 + sine*s1)
               d2phi2 = -4.0d0 * (cosine2*c2 + sine2*s2)
               d2phi3 = -9.0d0 * (cosine3*c3 + sine3*s3)
c
c     calculate the bond-stretch for the central bond
c
               k = ist(2,istrtor)
               dr = rcb - bl(k)
c
c     calculate the stretch-torsion master chain rule terms
c
               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     first and second derivative components for the bond stretch
c
               ddrdx = xcb * ddr
               ddrdy = ycb * ddr
               ddrdz = zcb * ddr
               d2drdxx = (xcb**2-rcb**2) * d2dr
               d2drdyy = (ycb**2-rcb**2) * d2dr
               d2drdzz = (zcb**2-rcb**2) * d2dr
               d2drdxy = xcb * ycb * d2dr
               d2drdxz = xcb * zcb * d2dr
               d2drdyz = ycb * zcb * d2dr
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,0)
                  call image (xdb,ydb,zdb,0)
               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     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 * dr
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
     &                             - 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
            end if
         end if
      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 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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'strtor.i'
      include 'torpot.i'
      include 'tors.i'
      include 'usage.i'
      integer i,k,istrtor
      integer ia,ib,ic,id
      real*8 e,rcb,dr
      real*8 angle,fgrp
      real*8 rt2,ru2,rtru
      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
      header = .true.
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,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the torsional angle
c
         if (proceed) then
            xia = x(ia)
            yia = y(ia)
            zia = z(ia)
            xib = x(ib)
            yib = y(ib)
            zib = z(ib)
            xic = x(ic)
            yic = y(ic)
            zic = z(ic)
            xid = x(id)
            yid = y(id)
            zid = z(id)
            xba = xib - xia
            yba = yib - yia
            zba = zib - zia
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            if (use_polymer) then
               call image (xba,yba,zba,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            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     set the stretch-torsional parameters for this angle
c
               v1 = kst(1,istrtor)
               c1 = tors1(3,i)
               s1 = tors1(4,i)
               v2 = kst(2,istrtor)
               c2 = tors2(3,i)
               s2 = tors2(4,i)
               v3 = kst(3,istrtor)
               c3 = tors3(3,i)
               s3 = tors3(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 bond-stretch for the central bond
c
               k = ist(2,istrtor)
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               dr = rcb - bl(k)
c
c     compute the stretch-torsion energy for this angle
c
               e = storunit * dr * (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 stretch-torsion energy
c
               nebt = nebt + 1
               ebt = ebt + e
               aebt(ib) = aebt(ib) + 0.5d0*e
               aebt(ic) = aebt(ic) + 0.5d0*e
c
c     print a message if the energy of this interaction is large
c
               huge = (abs(e) .gt. 1.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,10)
   10                format (/,' Individual Stretch-Torsion Cross',
     &                          ' Term Interactions :',
     &                       //,' Type',23x,'Atom Names',20x,'Angle',
     &                          6x,'Energy',/)
                  end if
                  write (iout,20)  ia,name(ia),ib,name(ib),ic,
     &                             name(ic),id,name(id),angle,e
   20             format (' StrTors',4x,i5,'-',a3,3(1x,i5,'-',a3),
     &                       2x,f10.4,f12.4)
               end if
            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 etors  --  torsional potential energy  ##
c     ##                                                    ##
c     ########################################################
c
c
c     "etors" calculates the torsional potential energy
c
c
      subroutine etors
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'torpot.i'
      include 'tors.i'
      include 'usage.i'
      include 'warp.i'
      integer i,ia,ib,ic,id
      real*8 e,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 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
c
c     scale extent of smoothing by the diffusion coefficient
c
      width = 0.0d0
      if (use_deform)  width = difft * deform
      if (use_gda)  wterm = difft / 12.0d0
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,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the torsional angle
c
         if (proceed) then
            xia = x(ia)
            yia = y(ia)
            zia = z(ia)
            xib = x(ib)
            yib = y(ib)
            zib = z(ib)
            xic = x(ic)
            yic = y(ic)
            zic = z(ic)
            xid = x(id)
            yid = y(id)
            zid = z(id)
            xba = xib - xia
            yba = yib - yia
            zba = zib - zia
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            if (use_polymer) then
               call image (xba,yba,zba,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the 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 via diffusional smoothing
c
               if (use_deform) then
                  if (use_gda)
     &               width = wterm * (m2(ia)+m2(ib)+m2(ic)+m2(id))
                  phi1 = phi1 * exp(-width)
                  phi2 = phi2 * exp(-4.0d0*width)
                  phi3 = phi3 * exp(-9.0d0*width)
                  phi4 = phi4 * exp(-16.0d0*width)
                  phi5 = phi5 * exp(-25.0d0*width)
                  phi6 = phi6 * exp(-36.0d0*width)
               end if
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 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 torsional potential energy and first
c     derivatives with respect to Cartesian coordinates
c
c
      subroutine etors1
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'torpot.i'
      include 'tors.i'
      include 'usage.i'
      include 'virial.i'
      include 'warp.i'
      integer i,ia,ib,ic,id
      real*8 e,dedphi,rcb
      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 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 deform1,deform2
      real*8 deform3,deform4
      real*8 deform5,deform6
      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
      logical proceed
c
c
c     zero out energy and first derivative components
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
c
c     scale extent of smoothing by the diffusion coefficient
c
      width = 0.0d0
      if (use_deform)  width = difft * deform
      if (use_gda)  wterm = difft / 12.0d0
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,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the torsional angle
c
         if (proceed) then
            xia = x(ia)
            yia = y(ia)
            zia = z(ia)
            xib = x(ib)
            yib = y(ib)
            zib = z(ib)
            xic = x(ic)
            yic = y(ic)
            zic = z(ic)
            xid = x(id)
            yid = y(id)
            zid = z(id)
            xba = xib - xia
            yba = yib - yia
            zba = zib - zia
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            if (use_polymer) then
               call image (xba,yba,zba,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the 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 via diffusional smoothing
c
               if (use_deform) then
                  if (use_gda)
     &               width = wterm * (m2(ia)+m2(ib)+m2(ic)+m2(id))
                  deform1 = exp(-width)
                  deform2 = exp(-4.0d0*width)
                  deform3 = exp(-9.0d0*width)
                  deform4 = exp(-16.0d0*width)
                  deform5 = exp(-25.0d0*width)
                  deform6 = exp(-36.0d0*width)
                  phi1 = phi1 * deform1
                  phi2 = phi2 * deform2
                  phi3 = phi3 * deform3
                  phi4 = phi4 * deform4
                  phi5 = phi5 * deform5
                  phi6 = phi6 * deform6
                  dphi1 = dphi1 * deform1
                  dphi2 = dphi2 * deform2
                  dphi3 = dphi3 * deform3
                  dphi4 = dphi4 * deform4
                  dphi5 = dphi5 * deform5
                  dphi6 = dphi6 * deform6
               end if
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,0)
                  call image (xdb,ydb,zdb,0)
               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 diagonal components
c
               virx = virx - xba*dedxia + xdc*dedxid
     &                     + xcb*(dedxic+dedxid)
               viry = viry - yba*dedyia + ydc*dedyid
     &                     + ycb*(dedyic+dedyid)
               virz = virz - zba*dedzia + zdc*dedzid
     &                     + zcb*(dedzic+dedzid)
            end if
         end if
      end 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 second derivatives of the torsional
c     energy for a single atom
c
c
      subroutine etors2 (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'group.i'
      include 'hessn.i'
      include 'torpot.i'
      include 'tors.i'
      include 'warp.i'
      integer i,ktors
      integer ia,ib,ic,id
      real*8 dedphi,d2edphi2
      real*8 fgrp,width,wterm
      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,cosine3
      real*8 cosine4,cosine5,cosine6
      real*8 sine,sine2,sine3
      real*8 sine4,sine5,sine6
      real*8 xia,yia,zia,xib,yib,zib
      real*8 xic,yic,zic,xid,yid,zid
      real*8 xba,yba,zba,xcb,ycb,zcb
      real*8 xdc,ydc,zdc
      real*8 xca,yca,zca,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 deform1,deform2,deform3
      real*8 deform4,deform5,deform6
      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     scale extent of smoothing by the diffusion coefficient
c
      width = 0.0d0
      if (use_deform)  width = difft * deform
      if (use_gda)  wterm = difft / 12.0d0
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,4,ia,ib,ic,id,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,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            xtu = yt*zu - yu*zt
            ytu = zt*xu - zu*xt
            ztu = xt*yu - xu*yt
            rt2 = xt*xt + yt*yt + zt*zt
            ru2 = xu*xu + yu*yu + zu*zu
            rtru = sqrt(rt2 * ru2)
            if (rtru .ne. 0.0d0) then
               rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb)
               cosine = (xt*xu + yt*yu + zt*zu) / rtru
               sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru)
c
c     set the 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 via diffusional smoothing
c
               if (use_deform) then
                  if (use_gda)
     &               width = wterm * (m2(ia)+m2(ib)+m2(ic)+m2(id))
                  deform1 = exp(-width)
                  deform2 = exp(-4.0d0*width)
                  deform3 = exp(-9.0d0*width)
                  deform4 = exp(-16.0d0*width)
                  deform5 = exp(-25.0d0*width)
                  deform6 = exp(-36.0d0*width)
                  dphi1 = dphi1 * deform1
                  dphi2 = dphi2 * deform2
                  dphi3 = dphi3 * deform3
                  dphi4 = dphi4 * deform4
                  dphi5 = dphi5 * deform5
                  dphi6 = dphi6 * deform6
                  d2phi1 = d2phi1 * deform1
                  d2phi2 = d2phi2 * deform2
                  d2phi3 = d2phi3 * deform3
                  d2phi4 = d2phi4 * deform4
                  d2phi5 = d2phi5 * deform5
                  d2phi6 = d2phi6 * deform6
               end if
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,0)
                  call image (xdb,ydb,zdb,0)
               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 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 energy & analysis  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "etors3" calculates the torsional potential energy;
c     also partitions the energy terms among the atoms
c
c
      subroutine etors3
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'torpot.i'
      include 'tors.i'
      include 'usage.i'
      include 'warp.i'
      integer i,ia,ib,ic,id
      real*8 e,rcb,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 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
      header = .true.
c
c     scale extent of smoothing by the diffusion coefficient
c
      width = 0.0d0
      if (use_deform)  width = difft * deform
      if (use_gda)  wterm = difft / 12.0d0
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,4,ia,ib,ic,id,0)
         if (proceed)  proceed = (use(ia) .or. use(ib) .or.
     &                              use(ic) .or. use(id))
c
c     compute the value of the torsional angle
c
         if (proceed) then
            xia = x(ia)
            yia = y(ia)
            zia = z(ia)
            xib = x(ib)
            yib = y(ib)
            zib = z(ib)
            xic = x(ic)
            yic = y(ic)
            zic = z(ic)
            xid = x(id)
            yid = y(id)
            zid = z(id)
            xba = xib - xia
            yba = yib - yia
            zba = zib - zia
            xcb = xic - xib
            ycb = yic - yib
            zcb = zic - zib
            xdc = xid - xic
            ydc = yid - yic
            zdc = zid - zic
            if (use_polymer) then
               call image (xba,yba,zba,0)
               call image (xcb,ycb,zcb,0)
               call image (xdc,ydc,zdc,0)
            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
            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     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 via diffusional smoothing
c
               if (use_deform) then
                  if (use_gda)
     &               width = wterm * (m2(ia)+m2(ib)+m2(ic)+m2(id))
                  phi1 = phi1 * exp(-width)
                  phi2 = phi2 * exp(-4.0d0*width)
                  phi3 = phi3 * exp(-9.0d0*width)
                  phi4 = phi4 * exp(-16.0d0*width)
                  phi5 = phi5 * exp(-25.0d0*width)
                  phi6 = phi6 * exp(-36.0d0*width)
               end if
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. 3.0d0)
               if (debug .or. (verbose.and.huge)) then
                  if (header) then
                     header = .false.
                     write (iout,10)
   10                format (/,' Individual Torsional Angle',
     &                          ' Interactions :',
     &                       //,' Type',23x,'Atom Names',20x,'Angle',
     &                          6x,'Energy',/)
                  end if
                  write (iout,20)  ia,name(ia),ib,name(ib),ic,
     &                             name(ic),id,name(id),angle,e
   20             format (' Torsion',4x,i5,'-',a3,3(1x,i5,'-',a3),
     &                       2x,f10.4,f12.4)
               end if
            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 eurey  --  Urey-Bradley potential energy  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "eurey" calculates the Urey-Bradley 1-3 interaction energy
c
c
      subroutine eurey
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'urey.i'
      include 'urypot.i'
      include 'usage.i'
      integer i,ia,ib
      real*8 e,ideal,force
      real*8 dt,dt2,fgrp
      real*8 xab,yab,zab,rab
      logical proceed
c
c
c     zero out the Urey-Bradley interaction energy
c
      eub = 0.0d0
c
c     calculate the Urey-Bradley 1-3 energy term
c
      do i = 1, nurey
         ia = iury(1,i)
         ib = iury(2,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,2,ia,ib,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib))
c
c     compute the value of the 1-3 distance 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,0)
            rab = sqrt(xab*xab + yab*yab + zab*zab)
            dt = rab - 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
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'group.i'
      include 'urey.i'
      include 'urypot.i'
      include 'usage.i'
      include 'virial.i'
      integer i,ia,ib
      real*8 e,ideal,force
      real*8 dt,dt2,deddt,fgrp
      real*8 de,dedx,dedy,dedz
      real*8 xab,yab,zab,rab
      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
c
c     calculate the Urey-Bradley 1-3 energy and first derivatives
c
      do i = 1, nurey
         ia = iury(1,i)
         ib = iury(2,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,2,ia,ib,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib))
c
c     compute the value of the 1-3 distance 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,0)
            rab = sqrt(xab*xab + yab*yab + zab*zab)
            dt = rab - 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 / rab
            dedx = de * xab
            dedy = de * yab
            dedz = de * zab
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,ib) = deub(1,ib) - dedx
            deub(2,ib) = deub(2,ib) - dedy
            deub(3,ib) = deub(3,ib) - dedz
c
c     increment the internal virial diagonal components
c
            virx = virx + xab*dedx
            viry = viry + yab*dedy
            virz = virz + zab*dedz
         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 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'couple.i'
      include 'group.i'
      include 'hessn.i'
      include 'urey.i'
      include 'urypot.i'
      integer i,j,ia,ib,iurey
      real*8 ideal,force,fgrp
      real*8 xab,yab,zab
      real*8 rab,rab2
      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     compute the Hessian elements of the Urey-Bradley energy
c
      do iurey = 1, nurey
         ia = iury(1,iurey)
         ib = iury(2,iurey)
         ideal = ul(iurey)
         force = uk(iurey)
c
c     decide whether to compute the current interaction
c
         proceed = (i.eq.ia .or. i.eq.ib)
         if (proceed .and. use_group)
     &      call groups (proceed,fgrp,2,ia,ib,0,0,0)
c
c     compute the value of the 1-3 distance deviation
c
         if (proceed) then
            if (i .eq. ib) then
               ib = ia
               ia = i
            end if
            xab = x(ia) - x(ib)
            yab = y(ia) - y(ib)
            zab = z(ia) - z(ib)
            if (use_polymer)  call image (xab,yab,zab,0)
            rab2 = xab*xab + yab*yab + zab*zab
            rab = sqrt(rab2)
            dt = rab - 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 / rab
            term = (d2eddt2-de) / rab2
            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 non-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)  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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'energi.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'urey.i'
      include 'urypot.i'
      include 'usage.i'
      integer i,ia,ib
      real*8 e,ideal,force
      real*8 dt,dt2,fgrp
      real*8 xab,yab,zab,rab
      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
      header = .true.
c
c     calculate the Urey-Bradley 1-3 energy term
c
      do i = 1, nurey
         ia = iury(1,i)
         ib = iury(2,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,2,ia,ib,0,0,0)
         if (proceed)  proceed = (use(ia) .or. use(ib))
c
c     compute the value of the 1-3 distance 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,0)
            rab = sqrt(xab*xab + yab*yab + zab*zab)
            dt = rab - 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(ib) = aeub(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,10)
   10             format (/,' Individual Urey-Bradley Interactions :',
     &                    //,' Type',13x,'Atom Names',20x,'Ideal',
     &                       4x,'Actual',6x,'Energy',/)
               end if
               write (iout,20)  ia,name(ia),ib,name(ib),ideal,rab,e
   20          format (' UreyBrad',3x,i5,'-',a3,1x,i5,'-',a3,
     &                    12x,2f10.4,f12.4)
            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 extra  --  user defined extra potentials  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "extra" calculates any additional user defined potential
c     energy contribution
c
c
      subroutine extra
      implicit none
      include 'energi.i'
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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'energi.i'
      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  --  atom-wise 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'hessn.i'
      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
      implicit none
      include 'sizes.i'
      include 'action.i'
      include 'analyz.i'
      include 'atoms.i'
      include 'energi.i'
      integer i
c
c
c     zero out the energy 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)  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
      implicit none
      include 'iounit.i'
c
c
c     print a final warning message, then quit
c
      write (iout,10)
   10 format (/,' TINKER is Unable to Continue; Terminating the',
     &           ' Current Calculation',/)
      stop
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #######################################################
c     ##                                                   ##
c     ##  subroutine fftsetup  --  3-D FFT initialization  ##
c     ##                                                   ##
c     #######################################################
c
c
      subroutine fftsetup (n1,n2,n3,ntable,table)
      implicit none
      integer n1,n2,n3,ntable
      real*8 table(ntable,3)
c
c
      call cffti (n1,table(1,1))
      call cffti (n2,table(1,2))
      call cffti (n3,table(1,3))
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine fftfront  --  3-D FFT forward transform  ##
c     ##                                                      ##
c     ##########################################################
c
c
      subroutine fftfront (n1,n2,n3,ndim1,ndim2,ndim3,
     &                     ntable,nwork,table,work,w)
      implicit none
      integer i,j,k
      integer n1,n2,n3
      integer ndim1,ndim2,ndim3
      integer ntable,nwork
      real*8 table(ntable,3)
      double complex work(nwork)
      double complex w(ndim1,ndim2,ndim3)
c
c
c     forward transform along X, Y and then Z
c
      do k = 1, n3
         do j = 1, n2
            do i = 1, n1
               work(i) = w(i,j,k)
            end do
            call cfftf (n1,work,table(1,1))
            do i = 1, n1
               w(i,j,k) = work(i)
            end do
         end do
      end do
      do k = 1, n3
         do i = 1, n1
            do j = 1, n2
               work(j) = w(i,j,k)
            end do
            call cfftf (n2,work,table(1,2))
            do j = 1, n2
               w(i,j,k) = work(j)
            end do
         end do
      end do
      do i = 1, n1
         do j = 1, n2
            do k = 1, n3
               work(k) = w(i,j,k)
            end do
            call cfftf (n3,work,table(1,3))
            do k = 1, n3
               w(i,j,k) = work(k)
            end do
         end do
      end do
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine fftback  --  3-D FFT backward transform  ##
c     ##                                                      ##
c     ##########################################################
c
c
      subroutine fftback (n1,n2,n3,ndim1,ndim2,ndim3,
     &                    ntable,nwork,table,work,w)
      implicit none
      integer i,j,k
      integer n1,n2,n3
      integer ndim1,ndim2,ndim3
      integer ntable,nwork
      real*8 table(ntable,3)
      double complex work(nwork)
      double complex w(ndim1,ndim2,ndim3)
c
c
c     backward transform along X, Y and then Z
c
      do k = 1, n3
         do j = 1, n2
            do i = 1, n1
               work(i) = w(i,j,k)
            end do
            call cfftb (n1,work,table(1,1))
            do i = 1, n1
               w(i,j,k) = work(i)
            end do
         end do
      end do
      do k = 1, n3
         do i = 1, n1
            do j = 1, n2
               work(j) = w(i,j,k)
            end do
            call cfftb (n2,work,table(1,2))
            do j = 1, n2
               w(i,j,k) = work(j)
            end do
         end do
      end do
      do i = 1, n1
         do j = 1, n2
            do k = 1, n3
               work(k) = w(i,j,k)
            end do
            call cfftb (n3,work,table(1,3))
            do k = 1, n3
               w(i,j,k) = work(k)
            end do
         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     ##  routines below implement a 1-D Fast Fourier Transform   ##
c     ##  code is derived 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 the array "wsave" which is used in both
c     forward and backward transforms; the prime factorization of
c     "n" together with a tabulation of the trigonometric functions
c     are computed and stored in "wsave"
c
c
      subroutine cffti (n,wsave)
      implicit none
      integer n,iw1,iw2
      real*8 wsave(*)
c
c
      if (n .eq. 1)  return
      iw1 = n + n + 1
      iw2 = iw1 + n + n
      call cffti1 (n,wsave(iw1),wsave(iw2))
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine cffti1  ##
c     ##                     ##
c     #########################
c
c
      subroutine cffti1 (n,wa,ifac)
      implicit none
      include 'math.i'
      integer i,j,ii,n,ifac(*)
      integer ib,ido,idot,ip,ipm
      integer i1,k1,l1,l2,ld
      integer nl,nf,nq,nr
      integer ntry,ntryh(4)
      real*8 arg,argh,argld
      real*8 fi,wa(*)
      data ntryh / 3, 4, 2, 5 /
c
c
      nl = n
      nf = 0
      j = 0
   10 continue
      j = j + 1
      if (j .le. 4) then
         ntry = ntryh(j)
      else
         ntry = ntry + 2
      end if
   20 continue
      nq = nl / ntry
      nr = nl - ntry*nq
      if (nr .ne. 0)  goto 10
      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
      if (nl .ne. 1)  goto 20
      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)
      implicit none
      integer n,iw1,iw2
      real*8 c(*),wsave(*)
c
c
      if (n .eq. 1)  return
      iw1 = n + n + 1
      iw2 = iw1 + n + n
      call cfftf1 (n,c,wsave,wsave(iw1),wsave(iw2))
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine cfftf1  ##
c     ##                     ##
c     #########################
c
c
      subroutine cfftf1 (n,c,ch,wa,ifac)
      implicit none
      integer i,k1,l1,l2
      integer na,nac,nf,n2
      integer ido,idot,idl1,ip
      integer iw,ix2,ix3,ix4
      integer n,ifac(*)
      real*8 ch(*),c(*),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)
      implicit none
      integer n,iw1,iw2
      real*8 c(*),wsave(*)
c
c
      if (n .eq. 1)  return
      iw1 = n + n + 1
      iw2 = iw1 + n + n
      call cfftb1 (n,c,wsave,wsave(iw1),wsave(iw2))
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine cfftb1  ##
c     ##                     ##
c     #########################
c
c
      subroutine cfftb1 (n,c,ch,wa,ifac)
      implicit none
      integer i,k1,l1,l2
      integer na,nac,nf,n2
      integer ido,idot,idl1,ip
      integer iw,ix2,ix3,ix4
      integer n,ifac(*)
      real*8 ch(*),c(*),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,wa(*)
      real*8 cc(ido,ip,l1)
      real*8 c1(ido,l1,ip)
      real*8 ch(ido,l1,ip)
      real*8 ch2(idl1,ip)
      real*8 c2(idl1,ip)
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(*),wa2(*)
      data taur  / -0.5d0 /
      data taui  / -0.866025403784439d0 /
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,tr12,ti12
      real*8 cc(ido,5,l1)
      real*8 ch(ido,l1,5)
      real*8 wa1(*),wa2(*)
      real*8 wa3(*),wa4(*)
      data tr11  /  0.309016994374947d0 /
      data ti11  / -0.951056516295154d0 /
      data tr12  / -0.809016994374947d0 /
      data ti12  / -0.587785252292473d0 /
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,wa(*)
      real*8 cc(ido,ip,l1)
      real*8 c1(ido,l1,ip)
      real*8 ch(ido,l1,ip)
      real*8 ch2(idl1,ip)
      real*8 c2(idl1,ip)
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(*),wa2(*)
      data taur  / -0.5d0 /
      data taui  / 0.866025403784439d0 /
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,tr12,ti12
      real*8 cc(ido,5,l1)
      real*8 ch(ido,l1,5)
      real*8 wa1(*),wa2(*)
      real*8 wa3(*),wa4(*)
      data tr11  /  0.309016994374947d0 /
      data ti11  /  0.951056516295154d0 /
      data tr12  / -0.809016994374947d0 /
      data ti12  /  0.587785252292473d0 /
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
      implicit none
      include 'sizes.i'
      include 'keys.i'
      include 'potent.i'
      integer i
      character*80 record
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_strtor = .true.
      use_tortor = .false.
      use_vdw = .true.
      use_charge = .true.
      use_chgdpl = .true.
      use_dipole = .true.
      use_mpole = .true.
      use_polar = .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 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)  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, prints a status
c     message, and then pauses if necessary to avoid closing the
c     execution window
c
c
      subroutine final
      implicit none
      include 'inform.i'
      include 'iounit.i'
c
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',
     &              ' of the Program',/)
      end if
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)  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 ()
      implicit none
      include 'iounit.i'
      integer freeunit
      logical used
c
c
c     try each logical unit until an unopened one is found
c
      freeunit = 0
      used = .true.
      dowhile (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)  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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'iounit.i'
      include 'minima.i'
      include 'potent.i'
      include 'vdwpot.i'
      include 'warp.i'
      integer maxgda
      parameter (maxgda=4*maxatm)
      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
      real*8 minimum,grdmin
      real*8 xcm,ycm,zcm
      real*8 gda1,gda2
      real*8 m2init(maxatm)
      real*8 xx(maxgda)
      logical exist,randomize
      character*1 answer
      character*6 mode,method
      character*7 ext,status
      character*60 gdafile
      character*80 record
      character*80 string
      external gda1,gda2,gda3
      external writeout
c
c
c     initialize and get the structure to be optimized
c
      call initial
      call getxyz
c
c     set flag for GDA method, then set up molecular mechanics
c
      use_gda = .true.
      call mechanic
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     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 (a80)
            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 (a80)
         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     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     translate 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_deform = .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_deform = .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,writeout)
c        call lbfgs (nvar,xx,minimum,grdmin,gda2,writeout)
         write (iout,110)  itrial,minimum
  110    format (/,' Global Energy Minimum for Trial',i4,' :',f15.4)
c
c     translate 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 any final tasks before program exit
c
      call final
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  function gda1  --  gradient for gaussian density annealing  ##
c     ##                                                              ##
c     ##################################################################
c
c
      function gda1 (beta,xx,g)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'warp.i'
      integer maxgda
      parameter (maxgda=4*maxatm)
      integer i,nvar
      integer hinit(maxvar)
      integer hstop(maxvar)
      integer hindex(maxhess)
      real*8 gda1,beta,e,sum
      real*8 hdiag(maxvar)
      real*8 h(maxhess)
      real*8 xx(maxgda)
      real*8 g(maxgda)
      real*8 derivs(3,maxatm)
c
c
c     translate 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',f14.4)
            m2(i) = -m2(i)
         end if
      end do
c
c     compute and store the energy and gradient
c
      call gradient (e,derivs)
      gda1 = e
c
c     translate the energy gradient into a dr/dbeta vector
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         xx(nvar) = x(i)
         g(nvar) = -(m2(i)/3.0d0) * derivs(1,i)
         nvar = nvar + 1
         xx(nvar) = y(i)
         g(nvar) = -(m2(i)/3.0d0) * derivs(2,i)
         nvar = nvar + 1
         xx(nvar) = z(i)
         g(nvar) = -(m2(i)/3.0d0) * derivs(3,i)
      end do
c
c     compute and store the Hessian elements
c
      call hessian (h,hinit,hstop,hindex,hdiag)
c
c     translate 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
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  function gda2  --  energy/gradient for TNCG optimization  ##
c     ##                                                            ##
c     ################################################################
c
c
      function gda2 (xx,g)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,nvar
      real*8 gda2,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(3,maxatm)
c
c
c     translate 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     compute and store the energy and gradient
c
      call gradient (e,derivs)
      gda2 = e
c
c     store atom gradients as optimization gradient, also
c     translate the coordinates of each active atom; the
c     latter may be needed when using periodic boundaries
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         xx(nvar) = x(i)
         g(nvar) = derivs(1,i)
         nvar = nvar + 1
         xx(nvar) = y(i)
         g(nvar) = derivs(2,i)
         nvar = nvar + 1
         xx(nvar) = z(i)
         g(nvar) = derivs(3,i)
      end do
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,nvar
      integer hinit(maxvar)
      integer hstop(maxvar)
      integer hindex(maxhess)
      real*8 xx(maxvar)
      real*8 hdiag(maxvar)
      real*8 h(maxhess)
      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)
c
c     translate the coordinates of each active atom;
c     this may be needed when using periodic boundaries
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
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine gdastat  --  compute GDA trajectory averages  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine gdastat (nstep,beta,xx,status)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'math.i'
      include 'warp.i'
      integer maxgda
      parameter (maxgda=4*maxatm)
      integer i,nvar
      integer nstep
      real*8 beta
      real*8 e,energy
      real*8 rg,m2ave
      real*8 xx(maxgda)
      character*7 status
c
c
c     translate 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 a disk file
c
      call writeout (xx,nstep)
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'math.i'
      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 = xab*xab + yab*yab + zab*zab
         rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
         rabc = sqrt(rab2 * rcb2)
         if (rabc .ne. 0.0d0) then
            cosine = (xab*xcb + yab*ycb + zab*zcb) / rabc
            cosine = min(1.0d0,max(-1.0d0,cosine))
            geometry = radian * acos(cosine)
         end if
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 = xt*xt + yt*yt + zt*zt
         ru2 = xu*xu + yu*yu + zu*zu
         rtru = sqrt(rt2 * ru2)
         if (rtru .ne. 0.0d0) then
            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
      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 getime  --  get elapsed CPU time in seconds  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "getime" gets elapsed CPU time in seconds for an interval
c
c
      subroutine getime (elapsed)
      implicit none
      include 'chrono.i'
      real*8 elapsed
c
c
c     elapsed time for the interval is the current total CPU
c     time minus the total time at the start of the interval
c
      call clock (elapsed)
      elapsed = elapsed - cputim
      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
      implicit none
      include 'inform.i'
      include 'iounit.i'
      include 'output.i'
      integer izmt
      integer freeunit
      character*60 intfile
      logical exist
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')
         call version (intfile,'old')
         inquire (file=intfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      dowhile (.not. exist)
         write (iout,10)
   10    format (/,' Enter Internal Coordinate File Name :  ',$)
         read (input,20)  intfile
   20    format (a60)
         call basefile (intfile)
         call suffix (intfile,'int')
         call version (intfile,'old')
         inquire (file=intfile,exist=exist)
      end do
c
c     first open and then read the internal coordinates file
c
      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',
     &              ' does not Contain Any Atoms')
         call fatal
      end if
c
c     convert internal to Cartesian coordinates
c
      call connect
      call makexyz
      call chkxyz
      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
      implicit none
      include 'sizes.i'
      include 'argue.i'
      include 'files.i'
      include 'iounit.i'
      include 'keys.i'
      integer i,ikey,next,length
      integer freeunit,trimtext
      logical exist,header
      character*20 keyword
      character*60 keyfile,string
      character*80 record,comment
c
c
c     check for a keyfile specified on the command line
c
      exist = .false.
      do i = 0, narg-1
         string = arg(i)
         call upcase (string)
         if (string(1:2) .eq. '-K') then
            keyfile = arg(i+1)
            call suffix (keyfile,'key')
            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     try to get keyfile from base name of current system
c
      if (.not. exist) then
         keyfile = filename(1:leng)//'.key'
         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
         inquire (file=keyfile,exist=exist)
      end if
c
c     read the keyfile and store it for latter use
c
      nkey = 0
      if (exist) then
         ikey = freeunit ()
         open (unit=ikey,file=keyfile,status='old')
         rewind (unit=ikey)
         dowhile (.true.)
            read (ikey,20,err=40,end=40)  record
   20       format (a80)
            length = trimtext (record)
            if (length .ne. 0) then
               nkey = nkey + 1
               keyline(nkey) = record
            end if
            if (nkey .ge. maxkey) then
               write (iout,30)
   30          format (/,' GETKEY  --  Keyfile Too Large;',
     &                    ' Increase MAXKEY')
               call fatal
            end if
         end do
   40    continue
         close (unit=ikey)
      end if
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:80)
            length = trimtext (comment)
            if (header) then
               header = .false.
               write (iout,50)
   50          format ()
            end if
            if (length .eq. 0) then
               write (iout,60)
   60          format ()
            else
               write (iout,70)  comment(1:length)
   70          format (a)
            end if
         end if
      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 getmol2  --  get a Sybyl MOL2 format file  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "getmol2" asks for a Sybyl MOL2 molecule file name,
c     then reads the coordinates from the file
c
c
      subroutine getmol2
      implicit none
      include 'files.i'
      include 'iounit.i'
      integer isyb
      integer freeunit
      logical exist
      character*60 sybylfile
c
c
c     try to get a filename from the command line arguments
c
      call nextarg (sybylfile,exist)
      if (exist) then
         call basefile (sybylfile)
         call suffix (sybylfile,'mol2')
         call version (sybylfile,'old')
         inquire (file=sybylfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      dowhile (.not. exist)
         write (iout,10)
   10    format (/,' Enter a Sybyl MOL2 File Name :  ',$)
         read (input,20)  sybylfile
   20    format (a60)
         call basefile (sybylfile)
         call suffix (sybylfile,'mol2')
         call version (sybylfile,'old')
         inquire (file=sybylfile,exist=exist)
      end do
c
c     first open and then read the Sybyl MOL2 coordinates file
c
      isyb = freeunit ()
      open (unit=isyb,file=sybylfile,status='old')
      rewind (unit=isyb)
      call readmol2 (isyb)
      close (unit=isyb)
      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" searchs 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)
      implicit none
      integer i,j,length
      integer next,trimtext
      integer first,last
      integer initial,final
      integer number,digit
      integer place(10)
      logical negate,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
      negate = .false.
      numeral = .false.
      length = trimtext(string(next:))
c
c     move through the string one character at a time,
c     searching 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)
         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 (letter.eq.'-' .and. .not.negate) then
            negate = .true.
         else if (numeral) then
            if (letter.eq.' ' .or. letter.eq.',' .or. 
     &          letter.eq.';' .or. letter.eq.'_') then
               last = i - 1
               next = i
               goto 10
            end if
         else if (letter.ne.' ' .or. negate) then
            goto 10
         end if
      end do
   10 continue
c
c     trim the actual number if it is too big to return
c
      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 (negate)  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,
c     then reads in the coordinates file
c
c
      subroutine getpdb
      implicit none
      include 'iounit.i'
      integer ipdb
      integer freeunit
      logical exist
      character*60 pdbfile
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')
         call version (pdbfile,'old')
         inquire (file=pdbfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      dowhile (.not. exist)
         write (iout,10)
   10    format (/,' Enter Protein Data Bank File Name :  ',$)
         read (input,20)  pdbfile
   20    format (a60)
         call basefile (pdbfile)
         call suffix (pdbfile,'pdb')
         call version (pdbfile,'old')
         inquire (file=pdbfile,exist=exist)
      end do
c
c     first open and then read the PDB coordinates file
c
      ipdb = freeunit ()
      open (unit=ipdb,file=pdbfile,status='old')
      rewind (unit=ipdb)
      call readpdb (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 file  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "getprm" finds the potential energy parameter file
c     and then opens and reads the parameters
c
c
      subroutine getprm
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'iounit.i'
      include 'keys.i'
      integer i,iprm
      integer next,freeunit
      logical exist,useprm
      character*4 none
      character*20 keyword
      character*60 prmfile
      character*80 record
c
c
c     set the default name for the parameter file
c
      useprm = .true.
      prmfile = filename(1:leng)//'.prm'
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 ') then
            call gettext (record,prmfile,next)
         end if
      end do
c
c     check existence of default or specified parameter file
c
      call suffix (prmfile,'prm')
      call version (prmfile,'old')
      inquire (file=prmfile,exist=exist)
c
c     test for user specified absence of a parameter file
c
      if (.not. exist) then
         none = prmfile(1:4)
         call upcase (none)
         if (none .eq. 'NONE') then
            exist = .true.
            useprm = .false.
         end if
      end if
c
c     try to get a parameter filename from the command line
c
      if (.not. exist) then
         call nextarg (prmfile,exist)
         if (exist) then
            call suffix (prmfile,'prm')
            call version (prmfile,'old')
            inquire (file=prmfile,exist=exist)
         end if
      end if
c
c     if necessary, ask for the parameter filename
c
      dowhile (.not. exist)
         write (iout,10)
   10    format (/,' Enter Potential Parameter File Name :  ',$)
         read (input,20)  prmfile
   20    format (a60)
         call suffix (prmfile,'prm')
         call version (prmfile,'old')
         inquire (file=prmfile,exist=exist)
      end do
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) then
         iprm = freeunit ()
         open (unit=iprm,file=prmfile,status='old')
         rewind (unit=iprm)
         call readprm (iprm)
         close (unit=iprm)
      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 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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'files.i'
      include 'refer.i'
      include 'titles.i'
      integer i,j
c
c
c     retrieve the filename and title line for the structure
c
      filename = reffile
      leng = refleng
      title = reftitle
      ltitle = refltitle
c
c     retrieve the coordinates, type and connectivity of each atom
c
      n = nref
      do i = 1, n
         name(i) = refnam(i)
         x(i) = xref(i)
         y(i) = yref(i)
         z(i) = zref(i)
         type(i) = reftyp(i)
         n12(i) = n12ref(i)
         do j = 1, n12(i)
            i12(j,i) = i12ref(j,i)
         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 getstring  --  extract single quoted string  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "getstring" searchs for a quoted text string within an input
c     character string; the region between the first and second
c     quotes is returned as the "text"; if the actual text is too
c     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)
      implicit none
      integer i,j
      integer len,length
      integer size,next
      integer extent
      integer first,last
      integer initial,final
      character*1 letter
      character*(*) string,text
c
c
c     get the length of input string and output text
c
      length = len(string(next:))
      size = len(text)
c
c     move through the string one character at a time,
c     searching for the quoted text string characters
c
      first = next
      last = 0
      initial = next
      final = next + length - 1
      do i = initial, final
         letter = string(i:i)
         if (letter .eq. '"') then
            first = i + 1
            do j = first, final
               letter = string(j:j)
               if (letter .eq. '"') then
                  last = j - 1
                  next = j + 1
                  goto 10
               end if
            end do
         end if
      end do
   10 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" searchs an input string for the first string of
c     non-blank characters; the region from a non-blank character
c     to the first blank space 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)
      implicit none
      integer i,j
      integer len,length
      integer size,next
      integer first,last
      integer extent
      integer initial,final
      character*(*) string,text
c
c
c     get the length of input string and output text
c
      length = len(string(next:))
      size = len(text)
c
c     move through the string one character at a time,
c     searching for the first non-blank character
c
      first = next
      last = 0
      initial = next
      final = next + length - 1
      do i = initial, final
         if (string(i:i) .gt. ' ') then
            first = i
            do j = i+1, final
               if (string(j:j) .le. ' ') then
                  last = j - 1
                  next = j
                  goto 10
               end if
            end do
         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" searchs 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 comma is returned as a "word"; if
c     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)
      implicit none
      integer i,j
      integer len,length
      integer size,next
      integer first,last
      integer extent
      integer initial,final
      character*1 letter
      character*(*) string,word
c
c
c     get the length of input string and output word
c
      length = len(string(next:))
      size = len(word)
c
c     move through the string one character at a time,
c     searching 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
               if (string(j:j).le.' ' .or. string(j:j).eq.',') then
                  last = j - 1
                  next = j
                  goto 10
               end if
            end do
         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 comma
c
      if (string(next:next) .eq. ',')  next = next + 1
      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 Cartesian coordinate structure  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "getxyz" asks for a Cartesian coordinate file name,
c     then reads in the coordinates file
c
c
      subroutine getxyz
      implicit none
      include 'inform.i'
      include 'iounit.i'
      include 'output.i'
      integer ixyz
      integer freeunit
      logical exist
      character*60 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')
         call version (xyzfile,'old')
         inquire (file=xyzfile,exist=exist)
      end if
c
c     ask for the user specified input structure filename
c
      dowhile (.not. exist)
         write (iout,10)
   10    format (/,' Enter Cartesian Coordinate File Name :  ',$)
         read (input,20)  xyzfile
   20    format (a60)
         call basefile (xyzfile)
         call suffix (xyzfile,'xyz')
         call version (xyzfile,'old')
         inquire (file=xyzfile,exist=exist)
      end do
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     quit if the Cartesian coordinates file contains no atoms
c
      if (abort) then
         write (iout,30)
   30    format (/,' GETXYZ  --  Cartesian Coordinates File',
     &              ' does not Contain Any Atoms')
         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 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'deriv.i'
      include 'energi.i'
      include 'inter.i'
      include 'potent.i'
      include 'vdwpot.i'
      include 'virial.i'
      integer i,j
      real*8 energy,cutoff
      real*8 derivs(3,maxatm)
c
c
c     zero out each of the potential energy components
c
      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
      ebt = 0.0d0
      ett = 0.0d0
      ev = 0.0d0
      ec = 0.0d0
      ecd = 0.0d0
      ed = 0.0d0
      em = 0.0d0
      ep = 0.0d0
      er = 0.0d0
      es = 0.0d0
      elf = 0.0d0
      eg = 0.0d0
      ex = 0.0d0
c
c     zero out each of the first derivative components
c
      do i = 1, n
         do j = 1, 3
            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
            debt(j,i) = 0.0d0
            dett(j,i) = 0.0d0
            dev(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
            der(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
      virx = 0.0d0
      viry = 0.0d0
      virz = 0.0d0
      einter = 0.0d0
c
c     maintain any periodic boundary conditions
c
      if (use_bounds)  call bounds
c
c     remove any previous use of the replicates method
c
      cutoff = 0.0d0
      if (use_image)  call replica (cutoff)
c
c     alter bond and torsion constants for pisystem
c
      if (use_orbit)  call piscf
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_strtor)  call estrtor1
c     if (use_tortor)  call etortor1
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
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 .or. use_polar)  call empole1
      if (use_rxnfld)  call erxnfld1
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
      energy = eb + ea + eba + eub + eaa + eopb + eopd + eid + eit
     &            + et + ebt + ett + ev + ec + ecd + ed + em + ep
     &            + er + es + elf + eg + ex
      do i = 1, n
         do j = 1, 3
            derivs(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) + debt(j,i) + dett(j,i)
     &                       + dev(j,i) + dec(j,i) + decd(j,i)
     &                       + ded(j,i) + dem(j,i) + dep(j,i)
     &                       + der(j,i) + des(j,i) + delf(j,i)
     &                       + deg(j,i) + dex(j,i)
         end do
      end do
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'group.i'
      include 'rigid.i'
      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 g(3,maxatm)
      real*8 derivs(6,maxgrp)
c
c
c     zero out the total of rigid body derivative components
c
      do i = 1, maxgrp
         do j = 1, 6
            derivs(j,i) = 0.0d0
         end do
      end do
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     first, get 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     now, set 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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'domega.i'
      include 'omega.i'
      include 'potent.i'
      include 'rotate.i'
      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 g(3,maxatm)
      real*8 derivs(maxrot)
c
c
c     zero out individual components of torsional derivatives
c
      do i = 1, nomega
         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
         tebt(i) = 0.0d0
         tett(i) = 0.0d0
         tev(i) = 0.0d0
         tec(i) = 0.0d0
         tecd(i) = 0.0d0
         ted(i) = 0.0d0
         tem(i) = 0.0d0
         tep(i) = 0.0d0
         ter(i) = 0.0d0
         tes(i) = 0.0d0
         telf(i) = 0.0d0
         teg(i) = 0.0d0
         tex(i) = 0.0d0
      end do
c
c     calculate the energy and Cartesian first derivatives
c
      call gradient (energy,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
            tebt(i) = tebt(i) + debt(1,k)*xterm + debt(2,k)*yterm
     &                              + debt(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
            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
            ter(i) = ter(i) + der(1,k)*xterm + der(2,k)*yterm
     &                              + der(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
         derivs(i) = teb(i) + tea(i) + teba(i) + teub(i) + teaa(i)
     &                  + teopb(i) + teopd(i) + teid(i) + teit(i)
     &                  + tet(i) + tebt(i) + tett(i) + tev(i) + tec(i)
     &                  + tecd(i) + ted(i) + tem(i) + tep(i) + ter(i)
     &                  + tes(i) + telf(i) + teg(i) + tex(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     ##  subroutine groups  --  group membership of atom set  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "groups" tests a set of atoms to see if all are members
c     of a single atom group or a pair of atom groups; if so,
c     then the correct intra- or intergroup weight is assigned
c
c
      subroutine groups (proceed,weight,nset,ia,ib,ic,id,ie)
      implicit none
      include 'sizes.i'
      include 'group.i'
      integer ia,ib,ic
      integer id,ie
      integer iga,igb,igc
      integer igd,ige
      integer nset
      integer gmax,gmin
      real*8 weight
      logical proceed
c
c
c     check group membership for a set containing one atom
c
      if (nset .eq. 1) then
         iga = grplist(ia)
         weight = 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)
         weight = 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
            weight = wgrp(iga,igc)
         else if (iga .eq. igc) then
            weight = wgrp(iga,igb)
         else
            weight = 0.0d0
         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.ne.gmin .and. iga.ne.gmax) .or.
     &       (igb.ne.gmin .and. igb.ne.gmax) .or.
     &       (igc.ne.gmin .and. igc.ne.gmax) .or.
     &       (igd.ne.gmin .and. igd.ne.gmax)) then
            weight = 0.0d0
         else
            weight = wgrp(gmin,gmax)
         end if
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.ne.gmin .and. iga.ne.gmax) .or.
     &       (igb.ne.gmin .and. igb.ne.gmax) .or.
     &       (igc.ne.gmin .and. igc.ne.gmax) .or.
     &       (igd.ne.gmin .and. igd.ne.gmax) .or.
     &       (ige.ne.gmin .and. ige.ne.gmax)) then
            weight = 0.0d0
         else
            weight = wgrp(gmin,gmax)
         end if
      end if
c
c     interaction will be used if its group has nonzero weight
c
      if (weight .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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'group.i'
      include 'rgddyn.i'
      integer i,j,k,size
      integer start,stop
      real*8 xx,yy,zz
      real*8 x2,y2,z2
      real*8 eps,det
      real*8 weight
      real*8 rc(3)
      real*8 inert(6)
      real*8 xm(maxatm)
      real*8 ym(maxatm)
      real*8 zm(maxatm)
c
c
c     compute the center of mass coordinates of each group
c
      do i = 1, ngrp
         start = igrp(1,i)
         stop = igrp(2,i)
         do j = 1, 3
            rc(j) = 0.0d0
         end do
         do j = start, stop
            k = kgrp(j)
            weight = mass(k)
            rc(1) = rc(1) + x(k)*weight
            rc(2) = rc(2) + y(k)*weight
            rc(3) = rc(3) + z(k)*weight
         end do
         do j = 1, 3
            rc(j) = rc(j) / grpmass(i)
         end do
         do j = start, stop
            k = kgrp(j)
            xm(k) = x(k) - rc(1)
            ym(k) = y(k) - rc(2)
            zm(k) = z(k) - rc(3)
         end do
      end do
c
c     use the moments of inertia to 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 = xm(k)
               yy = ym(k)
               zz = zm(k)
               x2 = xx * xx
               y2 = yy * yy
               z2 = zz * zz
               weight = mass(k)
               inert(1) = inert(1) + weight*(y2+z2)
               inert(2) = inert(2) - weight*xx*yy
               inert(3) = inert(3) + weight*(x2+z2)
               inert(4) = inert(4) - weight*xx*zz
               inert(5) = inert(5) - weight*yy*zz
               inert(6) = inert(6) + weight*(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
      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
c     system from its atomic coordinates
c
c
      subroutine gyrate (rg)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i
      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, n
         xc = xc + x(i)
         yc = yc + y(i)
         zc = zc + z(i)
      end do
      xc = xc / dble(n)
      yc = yc / dble(n)
      zc = zc / dble(n)
c
c     compute and print out the radius of gyration
c
      rg = 0.0d0
      do i = 1, n
         rg = rg + (x(i)-xc)**2 + (y(i)-yc)**2 + (z(i)-zc)**2
      end do
      rg = sqrt(rg/dble(n))
      return
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'couple.i'
      include 'hescut.i'
      include 'hessn.i'
      include 'inform.i'
      include 'iounit.i'
      include 'potent.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k
      integer ii,nhess
      integer hinit(3,maxatm)
      integer hstop(3,maxatm)
      integer hindex(maxhess)
      real*8 percent,filled
      real*8 cutoff,rdn,hmax
      real*8 xred(maxatm)
      real*8 yred(maxatm)
      real*8 zred(maxatm)
      real*8 hdiag(3,maxatm)
      real*8 h(maxhess)
      logical keep(maxatm)
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     maintain any periodic boundary conditions
c
      if (use_bounds)  call bounds
c
c     alter bond and torsion constants for pisystem
c
      if (use_orbit)  call piscf
c
c     set the Born radii for use with GB/SA solvation
c
      if (use_gbsa)  call born
c
c     compute the induced dipoles at polarizable atoms
c
      if (use_polar)  call induce
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     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
            if (use_image)  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_strtor)  call estrtor2 (i)
c           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') then
                  call elj2 (i,xred,yred,zred)
               else if (vdwtyp .eq. 'BUCKINGHAM') then
                  call ebuck2 (i,xred,yred,zred)
               else if (vdwtyp .eq. 'MM3-HBOND') then
                  call emm3hb2 (i,xred,yred,zred)
               else if (vdwtyp .eq. 'BUFFERED-14-7') then
                  call ehal2 (i,xred,yred,zred)
               else if (vdwtyp .eq. 'GAUSSIAN') then
                  call egauss2 (i,xred,yred,zred)
               end if
            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 .or. use_polar)   call empole2 (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     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
c
c     check for storage of too many Hessian elements
c
            if (nhess .gt. maxhess) then
               write (iout,10)  i,n,nhess,maxhess,hesscut
   10          format (/,' Current Atom :',i7,6x,'Total Atoms :',i7,
     &                 /,' Current Required Hessian Storage : ',i12,
     &                 /,' Maximum Allowed Hessian Storage :  ',i12,
     &                 /,' Minimum Significant Hessian Value :',f12.5)
               write (iout,20)
   20          format (/,' HESSIAN  --  Increase MAXHESS',
     &                    ' and/or HESSCUT')
               call fatal
            end if
         end if
      end do
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)
         filled = 100.0d0 * dble(nhess)/dble(maxhess)
         write (iout,30)  nhess,percent,filled
   30    format (' HESSIAN  --',i11,' Elements',f9.2,
     &              ' % Off-diag H',f8.2,' % Storage')
      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 hessrgd  --  rigid body Hessian elements  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "hessrgd" computes the numerical Hessian elements with
c     respect to rigid body coordinates; either the full matrix
c     or just the diagonal can be calculated; the full matrix
c     needs 6*ngroup+1 gradient evaluations while the diagonal
c     requires just two gradient calls
c
c
      subroutine hessrgd (mode,hrigid)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'group.i'
      include 'rigid.i'
      integer maxrgd
      parameter (maxrgd=6*maxgrp)
      integer i,j,k,m,nvar
      real*8 e,eps
      real*8 g(6,maxgrp)
      real*8 g0(6,maxgrp)
      real*8 old(6,maxgrp)
      real*8 hrigid(maxrgd,maxrgd)
      character*4 mode
c
c
c     calculate base values for the rigid body gradient
c
      eps = 0.0001d0
      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
      if (mode .eq. 'full') then
         nvar = 6 * ngrp
         do i = 1, nvar
            j = (i-1)/6 + 1
            k = mod(i-1,6) + 1
            old(k,j) = rbc(k,j)
            rbc(k,j) = rbc(k,j) + eps
            call rigidxyz
            call gradrgd (e,g)
            do m = 1, nvar
               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
            rbc(k,j) = old(k,j)
         end do
c
c     compute numerical Hessian diagonal from gradient values
c
      else if (mode .eq. 'diag') then
         do i = 1, ngrp
            do j = 1, 6
               old(j,i) = rbc(j,i)
               rbc(j,i) = rbc(j,i) + eps
            end do
         end do
         call rigidxyz
         call gradrgd (e,g)
         nvar = 0
         do i = 1, ngrp
            do j = 1, 6
               nvar = nvar + 1
               hrigid(nvar,nvar) = (g(j,i)-g0(j,i)) / eps
               rbc(j,i) = old(j,i)
            end do
         end do
      end if
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 the numerical Hessian elements with
c     respect to torsional angles; either the full matrix or
c     just the diagonal can be calculated; the full matrix
c     needs nomega+1 gradient evaluations while the diagonal
c     requires just two gradient calls
c
c
      subroutine hessrot (mode,hrot)
      implicit none
      include 'sizes.i'
      include 'omega.i'
      include 'math.i'
      include 'zcoord.i'
      integer i,j,line
      real*8 e,eps
      real*8 g(maxrot)
      real*8 g0(maxrot)
      real*8 old(maxrot)
      real*8 hrot(maxrot,maxrot)
      character*4 mode
c
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     restore the Cartesian coordinates to original values
c
      call makexyz
      return
      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
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'mutant.i'
c
c
c     set the potential energy parameters for hybrid atoms
c
      if (nhybrid .ne. 0) then
         write (iout,10)  lambda
   10    format (/,' Lambda Coupling Parameter for FEP :',f12.3)
         call hatom
         call hbond
         call hangle
         call hstrbnd
         call himptor
         call htors
         call hstrtor
         call hvdw
         call hcharge
         call hdipole
      end if
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine hatom  --  assign hybrid atom parameters  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "hatom" assigns a new atom type to each hybrid site
c
c
      subroutine hatom
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'katoms.i'
      include 'mutant.i'
      integer i,k,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+nhybrid) then
         abort = .true.
         write (iout,20)
   20    format (' HATOM  --  Too many Sites to be Altered;',
     &              ' Increase MAXTYP')
      end if
c
c     create a new atom type for each of the hybrid atoms
c
      do i = 1, nhybrid
         k = ihybrid(i)
         it = ntype + i
         it0 = type0(i)
         it1 = type1(i)
         symbol(it) = 'HYB'
         atmnum(it) = 0
         weight(it) = lambda*weight(it1) + (1.0d0-lambda)*weight(it0)
         ligand(it) = 0
         describe(it) = 'Hybrid Atom Type    '
         type(k) = it
         name(k) = symbol(it)
         atomic(k) = atmnum(it)
         mass(k) = weight(it)
         valence(k) = ligand(it)
         story(k) = describe(it)
      end do
      return
      end
c
c
c     #########################################################
c     ##                                                     ##
c     ##  subroutine hbond  --  find hybrid bond parameters  ##
c     ##                                                     ##
c     #########################################################
c
c
c     "hbond" constructs hybrid bond stretch parameters given
c     an initial state, final state and "lambda" value
c
c
      subroutine hbond
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'iounit.i'
      include 'inform.i'
      include 'kbonds.i'
      include 'mutant.i'
      integer i,j,k,ia,ib
      integer ita,itb,size
      real*8 bk0,bk1,bl0,bl1
      logical header
      character*3 pa,pb
      character*6 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 (alter(ia) .or. alter(ib)) then
            ita = class(ia)
            itb = class(ib)
c
c     find the bond parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class0(j)
               if (k .eq. ib)  itb = class0(j)
            end do
            size = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            if (ita .le. itb) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            bk0 = 0.0d0
            bl0 = 0.0d0
            do j = 1, maxnb
               if (kb(j) .eq. pt) then
                  bk0 = 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, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class1(j)
               if (k .eq. ib)  itb = class1(j)
            end do
            size = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            if (ita .le. itb) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            bk1 = 0.0d0
            bl1 = 0.0d0
            do j = 1, maxnb
               if (kb(j) .eq. pt) then
                  bk1 = 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
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'inform.i'
      include 'kangs.i'
      include 'mutant.i'
      integer i,j,k,ia,ib,ic
      integer ita,itb,itc,size
      real*8 ak0,ak1,anat0,anat1
      logical header
      character*3 pa,pb,pc
      character*9 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 (alter(ia) .or. alter(ib) .or. alter(ic)) then
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
c
c     find the angle parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class0(j)
               if (k .eq. ib)  itb = class0(j)
               if (k .eq. ic)  itc = class0(j)
            end do
            size = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            if (ita .le. itc) then
               pt = pa//pb//pc
            else
               pt = pc//pb//pa
            end if
            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, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class1(j)
               if (k .eq. ib)  itb = class1(j)
               if (k .eq. ic)  itc = class1(j)
            end do
            size = 3
            call numeral (ita,pa,3)
            call numeral (itb,pb,3)
            call numeral (itc,pc,3)
            if (ita .le. itc) then
               pt = pa//pb//pc
            else
               pt = pc//pb//pa
            end if
            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
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      include 'inform.i'
      include 'katoms.i'
      include 'kstbnd.i'
      include 'mutant.i'
      include 'strbnd.i'
      integer i,j,k,ia,ib,ic
      integer ita,itb,itc,nsb
      integer nba,nba0,nba1
      integer nbc,nbc0,nbc1
      real*8 ksb0,ksb1
      logical header
c
c
c     assign hybrid parameters for the stretch-bend sites
c
      header = .true.
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         if (alter(ia) .or. alter(ib) .or. alter(ic)) then
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            do j = 1, n12(ib)
               if (i12(j,ib) .eq. ia)  nba = bndlist(j,ib)
               if (i12(j,ib) .eq. ic)  nbc = bndlist(j,ib)
            end do
c
c     find the stretch-bend parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class0(j)
               if (k .eq. ib)  itb = class0(j)
               if (k .eq. ic)  itc = class0(j)
            end do
            nsb = 1
            nba0 = nba
            nbc0 = nbc
            if (atmnum(ita) .le. 1) then
               nsb = nsb + 1
               if (stbn(3,itb) .eq. 0.0d0)  nba0 = 0
            end if
            if (atmnum(itc) .le. 1) then
               nsb = nsb + 1
               if (stbn(3,itb) .eq. 0.0d0)  nbc0 = 0
            end if
            ksb0 = stbn(nsb,itb)
c
c     find the stretch-bend parameters for the final state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class1(j)
               if (k .eq. ib)  itb = class1(j)
               if (k .eq. ic)  itc = class1(j)
            end do
            nsb = 1
            nba1 = nba
            nbc1 = nbc
            if (atmnum(ita) .le. 1) then
               nsb = nsb + 1
               if (stbn(3,itb) .eq. 0.0d0)  nba1 = 0
            end if
            if (atmnum(itc) .le. 1) then
               nsb = nsb + 1
               if (stbn(3,itb) .eq. 0.0d0)  nbc1 = 0
            end if
            ksb1 = stbn(nsb,itb)
c
c     form hybrid parameters for the current stretch-bend
c
            ksb(i) = lambda*ksb1 + (1.0d0-lambda)*ksb0
            if (ksb(i) .eq. 0.0d0) then
               if (isb(1,i) .ne. 0) then
                  nstrbnd = nstrbnd - 1
                  isb(1,i) = 0
               end if
            else
               if (isb(1,i) .ne. i) then
                  nstrbnd = nstrbnd + 1
                  isb(1,i) = i
               end if
               isb(2,i) = max(nba0,nba1)
               isb(3,i) = max(nbc0,nbc1)
               if (verbose) then
                  if (header) then
                     header = .false.
                     write (iout,10)
   10                format (/,' Hybrid Stretch-Bend Parameters :',
     &                       //,6x,'Atom Numbers',9x,'KSB',/)
                  end if
                  write (iout,20)  ia,ib,ic,ksb(i)
   20             format (3x,3i5,f12.3)
               end if
            end if
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine himptor  --  find hybrid improper torsions  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "himptor" constructs 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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      include 'inform.i'
      include 'imptor.i'
      include 'kitors.i'
      include 'math.i'
      include 'mutant.i'
      integer i,j,k,ia,ib,ic,id
      integer ita,itb,itc,itd
      integer it1,it2,it3,size
      real*8 angle
      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*3 pb,p1,p2,p3
      character*12 pt
c
c
c     construct hybrid improper torsion parameters
c
      header = .true.
      do i = 1, n
         if (n12(i) .eq. 3) then
            used = .false.
            ia = i12(1,i)
            ib = i12(2,i)
            ic = i
            id = i12(3,i)
            if (alter(ia) .or. alter(ib) .or.
     &          alter(ic) .or. alter(id)) then
               ita = class(ia)
               itb = class(ib)
               itc = class(ic)
               itd = class(id)
c
c     find improper torsion parameters for the initial state
c
               do j = 1, nhybrid
                  k = ihybrid(j)
                  if (k .eq. ia)  ita = class0(j)
                  if (k .eq. ib)  itb = class0(j)
                  if (k .eq. ic)  itc = class0(j)
                  if (k .eq. id)  itd = class0(j)
               end do
               it1 = min(ita,itc,itd)
               it2 = max(min(ita,itc),min(ita,itd),min(itc,itd))
               it3 = max(ita,itc,itd)
               size = 3
               call numeral (itb,pb,size)
               call numeral (it1,p1,size)
               call numeral (it2,p2,size)
               call numeral (it3,p3,size)
               pt = pb//p1//p2//p3
               v1_0 = 0.0d0
               s1_0 = 0.0d0
               v2_0 = 0.0d0
               s2_0 = 0.0d0
               v3_0 = 0.0d0
               s3_0 = 0.0d0
               do j = 1, maxnti
                  if (kti(j) .eq. pt) then
                     used = .true.
                     v1_0 = ti1(1,j)
                     s1_0 = ti1(2,j)
                     v2_0 = ti2(1,j)
                     s2_0 = ti2(2,j)
                     v3_0 = ti3(1,j)
                     s3_0 = ti3(2,j)
                     goto 10
                  end if
               end do
   10          continue
c
c     find improper torsion parameters for the final state
c
               do j = 1, nhybrid
                  k = ihybrid(j)
                  if (k .eq. ia)  ita = class1(j)
                  if (k .eq. ib)  itb = class1(j)
                  if (k .eq. ic)  itc = class1(j)
                  if (k .eq. id)  itd = class1(j)
               end do
               it1 = min(ita,itc,itd)
               it2 = max(min(ita,itc),min(ita,itd),min(itc,itd))
               it3 = max(ita,itc,itd)
               size = 3
               call numeral (itb,pb,size)
               call numeral (it1,p1,size)
               call numeral (it2,p2,size)
               call numeral (it3,p3,size)
               pt = pb//p1//p2//p3
               v1_1 = 0.0d0
               s1_1 = 0.0d0
               v2_1 = 0.0d0
               s2_1 = 0.0d0
               v3_1 = 0.0d0
               s3_1 = 0.0d0
               do j = 1, maxnti
                  if (kti(j) .eq. pt) then
                     used = .true.
                     v1_1 = ti1(1,j)
                     s1_1 = ti1(2,j)
                     v2_1 = ti2(1,j)
                     s2_1 = ti2(2,j)
                     v3_1 = ti3(1,j)
                     s3_1 = ti3(2,j)
                     goto 20
                  end if
               end do
   20          continue
            end if
c
c     form hybrid parameters for the current improper torsion
c
            if (used) then
               do j = 1, nitors
                  if (iitors(3,j) .eq. ic) then
                     k = j
                     goto 30
                  end if
               end do
               nitors = nitors + 1
               k = nitors
   30          continue
               iitors(1,k) = ia
               iitors(2,k) = ib
               iitors(3,k) = ic
               iitors(4,k) = id
               if (s1_0 .eq. 0.0d0)  s1_0 = s1_1
               if (s2_0 .eq. 0.0d0)  s2_0 = s2_1
               if (s3_0 .eq. 0.0d0)  s3_0 = s3_1
               if (s1_1 .eq. 0.0d0)  s1_1 = s1_0
               if (s2_1 .eq. 0.0d0)  s2_1 = s2_0
               if (s3_1 .eq. 0.0d0)  s3_1 = s3_0
               itors1(1,k) = lambda*v1_1 + (1.0d0-lambda)*v1_0
               itors1(2,k) = lambda*s1_1 + (1.0d0-lambda)*s1_0
               angle = itors1(2,i) / radian
               itors1(3,i) = cos(angle)
               itors1(4,i) = 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,i) / radian
               itors2(3,i) = cos(angle)
               itors2(4,i) = 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,i) / radian
               itors3(3,i) = cos(angle)
               itors3(4,i) = sin(angle)
            end if
            if (verbose .and. used) then
               if (header) then
                  header = .false.
                  write (iout,40)
   40             format (/,' Hybrid Improper Torsional Parameters :',
     &                    //,6x,'Atom Numbers',16x,'KIT1',13x,'KIT2',
     &                       13x,'KIT3',/)
               end if
               write (iout,50)  ia,ib,ic,id,itors1(1,i),itors1(2,i),
     &                          itors2(1,i),itors2(2,i),
     &                          itors3(1,i),itors3(2,i)
   50          format (1x,4i5,4x,3(f10.4,f7.1))
            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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'ktorsn.i'
      include 'math.i'
      include 'mutant.i'
      include 'tors.i'
      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*3 pa,pb,pc,pd
      character*12 pt
c
c
c     construct hybrid torsional parameters
c
      header = .true.
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         if (alter(ia) .or. alter(ib) .or.
     &       alter(ic) .or. alter(id)) then
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            itd = class(id)
c
c     find the torsion parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class0(j)
               if (k .eq. ib)  itb = class0(j)
               if (k .eq. ic)  itc = class0(j)
               if (k .eq. id)  itd = class0(j)
            end do
            size = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            call numeral (itd,pd,size)
            if (itb .lt. itc) then
               pt = pa//pb//pc//pd
            else if (itc .lt. itb) then
               pt = pd//pc//pb//pa
            else if (ita .le. itd) then
               pt = pa//pb//pc//pd
            else if (itd .lt. ita) then
               pt = pd//pc//pb//pa
            end if
            v1_0 = 0.0d0
            s1_0 = 0.0d0
            v2_0 = 0.0d0
            s2_0 = 0.0d0
            v3_0 = 0.0d0
            s3_0 = 0.0d0
            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
   10       continue
c
c     find the torsion parameters for the final state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = class1(j)
               if (k .eq. ib)  itb = class1(j)
               if (k .eq. ic)  itc = class1(j)
               if (k .eq. id)  itd = class1(j)
            end do
            size = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            call numeral (itd,pd,size)
            if (itb .lt. itc) then
               pt = pa//pb//pc//pd
            else if (itc .lt. itb) then
               pt = pd//pc//pb//pa
            else if (ita .le. itd) then
               pt = pa//pb//pc//pd
            else if (itd .lt. ita) then
               pt = pd//pc//pb//pa
            end if
            v1_1 = 0.0d0
            s1_1 = 0.0d0
            v2_1 = 0.0d0
            s2_1 = 0.0d0
            v3_1 = 0.0d0
            s3_1 = 0.0d0
            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
   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
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'ksttor.i'
      include 'mutant.i'
      include 'strtor.i'
      include 'tors.i'
      integer i,j,k,size
      integer itb,itc
      integer ia,ib,ic,id
      real*8 kst0(3),kst1(3)
      logical header
      character*3 pb,pc
      character*6 pt
c
c
c     assign hybrid parameters for the stretch-torsion sites
c
      header = .true.
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         if (alter(ib) .or. alter(ic)) then
            itb = class(ib)
            itc = class(ic)
c
c     find the stretch-torsion parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ib)  itb = class0(j)
               if (k .eq. ic)  itc = class0(j)
            end do
            size = 3
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            if (itb .le. itc) then
               pt = pb//pc
            else
               pt = pc//pb
            end if
            do k = 1, 3
               kst0(k) = 0.0d0
            end do
            do j = 1, maxnbt
               if (kbt(j) .eq. pt) then
                  do k = 1, 3
                     kst0(k) = btcon(k,j)
                  end do
                  goto 10
               end if
            end do
   10       continue
c
c     find the stretch-torsion parameters for the final state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ib)  itb = class1(j)
               if (k .eq. ic)  itc = class1(j)
            end do
            size = 3
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            if (itb .le. itc) then
               pt = pb//pc
            else
               pt = pc//pb
            end if
            do k = 1, 3
               kst1(k) = 0.0d0
            end do
            do j = 1, maxnbt
               if (kbt(j) .eq. pt) then
                  do k = 1, 3
                     kst1(k) = btcon(k,j)
                  end do
                  goto 20
               end if
            end do
   20       continue
c
c     form hybrid parameters for the current stretch-torsion
c
            do j = 1, 3
               kst(j,i) = lambda*kst1(j) + (1.0d0-lambda)*kst0(j)
            end do
            if (kst(1,i).eq.0.0d0 .and. kst(2,i).eq.0.0d0
     &                  .and. kst(3,i).eq.0.0d0) then
               if (ist(1,i) .ne. 0) then
                  nstrtor = nstrtor - 1
                  ist(1,i) = 0
               end if
            else
               if (ist(1,i) .ne. i) then
                  nstrtor = nstrtor + 1
                  ist(1,i) = i
                  do j = 1, n12(ib)
                     if (i12(j,ib) .eq. ic) then
                        ist(2,i) = bndlist(j,ib)
                        goto 30
                     end if
                  end do
   30             continue
               end if
               if (verbose) then
                  if (header) then
                     header = .false.
                     write (iout,40)
   40                format (/,' Hybrid Stretch-Torsion Parameters :',
     &                       //,6x,'Atom Numbers',13x,'KST1',8x,'KST2',
     &                          8x,'KST3',/)
                  end if
                  write (iout,50)  ia,ib,ic,id,(kst(j,i),j=1,3)
   50             format (3x,4i5,3f12.3)
               end if
            end if
         end if
      end do
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine hvdw  --  hybrid van der Waals parameters  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "hvdw" constructs hybrid van der Waals  parameters given
c     an initial state, final state and "lambda" value
c
c
      subroutine hvdw
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kvdws.i'
      include 'math.i'
      include 'mutant.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k,it,it0,it1
      real*8 radius,rd,ep
      real*8 srad(maxclass)
      real*8 seps(maxclass)
      logical header
c
c
c     assign the hybrid van der Waals parameters
c
      do j = 1, nhybrid
         i = ihybrid(j)
         it = class(i)
         it0 = class0(j)
         it1 = class1(j)
         rad(it) = lambda*rad(it1) + (1.0d0-lambda)*rad(it0)
         eps(it) = lambda*eps(it1) + (1.0d0-lambda)*eps(it0)
      end do
c
c     get the square roots of the vdw radii and well depths
c
      do i = 1, maxclass
         srad(i) = sqrt(rad(i))
         seps(i) = sqrt(eps(i))
      end do
c
c     use combination rules to set pairwise vdw radii sums
c
      do j = 1, nhybrid
         i = ihybrid(j)
         it = class(i)
         do k = 1, maxclass
            if (rad(it).eq.0.0d0 .and. rad(k).eq.0.0d0) then
               rd = 0.0d0
            else if (radrule(1:10) .eq. 'ARITHMETIC') then
               rd = rad(it) + rad(k)
            else if (radrule(1:9) .eq. 'GEOMETRIC') then
               rd = 2.0d0*(srad(it)*srad(k))
            else if (radrule(1:10) .eq. 'CUBIC-MEAN') then
               rd = 2.0d0*(rad(it)**3+rad(k)**3)/(rad(it)**2+rad(k)**2)
            else
               rd = rad(it) + rad(k)
            end if
            radmin(it,k) = rd
            radmin(k,it) = rd
         end do
      end do
c
c     use combination rules to set pairwise well depths
c
      do j = 1, nhybrid
         i = ihybrid(j)
         it = class(i)
         do k = 1, maxclass
            if (eps(it).eq.0.0d0 .and. eps(k).eq.0.0d0) then
               ep = 0.0d0
            else if (epsrule(1:10) .eq. 'ARITHMETIC') then
               ep = 0.5d0 * (eps(it) + eps(k))
            else if (epsrule(1:9) .eq. 'GEOMETRIC') then
               ep = seps(it) * seps(k)
            else if (epsrule(1:8) .eq. 'HARMONIC') then
               ep = 2.0d0 * (eps(it)*eps(k)) / (eps(it)+eps(k))
            else if (epsrule(1:3) .eq. 'HHG') then
               ep = 4.0d0 * (eps(it)*eps(k)) / (seps(it)+seps(k))**2
            else
               ep = seps(it) * seps(k)
            end if
            epsilon(it,k) = ep
            epsilon(k,it) = ep
         end do
      end do
c
c     print the van der Waals parameters for hybrid atoms
c
      header = .true.
      do j = 1, nhybrid
         if (verbose) then
            if (header) then
               header = .false.
               write (iout,10)
   10          format (/,' Hybrid van der Waals Parameters :',
     &                 //,7x,'Atom Number    Radius     Epsilon')
            end if
            radius = rad(it)
            if (radsiz .eq. 'DIAMETER')  radius = 2.0d0 * radius
            if (radtyp .eq. 'SIGMA')  radius = radius / twosix
            write (iout,20)  i,radius,eps(it)
   20       format (6x,i8,f14.4,f12.4)
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine hcharge  --  find hybrid charge parameters  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "hcharge" constructs hybrid charge interaction parameters
c     given an initial state, final state and "lambda" value
c
c
      subroutine hcharge
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'charge.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kchrge.i'
      include 'mutant.i'
      integer i,j,k,it,it0,it1
      real*8 chg0,chg1,hybchg
      logical header,used
c
c
c     assign the hybrid parameters for atomic charges
c
      header = .true.
      do j = 1, nhybrid
         used = .false.
         i = ihybrid(j)
         it = type(i)
         it0 = type0(j)
         it1 = type1(j)
         chg0 = chg(it0)
         chg1 = chg(it1)
         hybchg = lambda*chg1 + (1.0d0-lambda)*chg0
         do k = 1, nion
            if (iion(k) .eq. i) then
               used = .true.
               pchg(k) = hybchg
               goto 10
            end if
         end do
         if (chg0.ne.0.0d0 .or. chg1.ne.0.0d0) then
            used = .true.
            nion = nion + 1
            iion(nion) = i
            kion(nion) = i
            pchg(nion) = hybchg
         end if
   10    continue
         if (verbose .and. used) then
            if (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Hybrid Atomic Partial Charge Parameters :',
     &                 //,7x,'Atom Number',7x,'Charge',/)
            end if
            write (iout,30)  i,hybchg
   30       format (6x,i8,5x,f12.3)
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine hdipole  --  find hybrid dipole parameters  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "hdipole" constructs hybrid dipole interaction parameters
c     given an initial state, final state and "lambda" value
c
c
      subroutine hdipole
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bond.i'
      include 'dipole.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kdipol.i'
      include 'mutant.i'
      integer i,j,k,ia,ib
      integer ita,itb,size
      character*3 pa,pb
      character*6 blank,pt
      real*8 dpl0,dpl1,hybdpl
      real*8 pos0,pos1,hybpos
      logical header,used
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 (alter(ia) .or. alter(ib)) then
            ita = type(ia)
            itb = type(ib)
c
c     find the dipole parameters for the initial state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = type0(j)
               if (k .eq. ib)  itb = type0(j)
            end do
            size = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            if (ita .le. itb) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            dpl0 = 0.0d0
            pos0 = 0.5d0
            do j = 1, maxnd
               if (kd(j) .eq. blank)  goto 10
               if (kd(j) .eq. pt) then
                  if (ita .le. itb) then
                     dpl0 = bdpl(j)
                     pos0 = sdpl(j)
                  else
                     dpl0 = -bdpl(j)
                     pos0 = 1.0d0 - sdpl(j)
                  end if
               end if
            end do
   10       continue
c
c     find the dipole parameters for the final state
c
            do j = 1, nhybrid
               k = ihybrid(j)
               if (k .eq. ia)  ita = type1(j)
               if (k .eq. ib)  itb = type1(j)
            end do
            size = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            if (ita .le. itb) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            dpl1 = 0.0d0
            pos1 = 0.5d0
            do j = 1, maxnd
               if (kd(j) .eq. blank)  goto 20
               if (kd(j) .eq. pt) then
                  if (ita .le. itb) then
                     dpl1 = bdpl(j)
                     pos1 = sdpl(j)
                  else
                     dpl1 = -bdpl(j)
                     pos1 = 1.0d0 - sdpl(j)
                  end if
               end if
            end do
   20       continue
c
c     form the hybrid parameters for the current dipole
c
            hybdpl = lambda*dpl1 + (1.0d0-lambda)*dpl0
            hybpos = lambda*pos1 + (1.0d0-lambda)*pos0
            used = .false.
            do j = 1, ndipole
               if ((idpl(1,j).eq.ia .and. idpl(2,j).eq.ib) .or.
     &             (idpl(1,j).eq.ib .and. idpl(2,j).eq.ia)) then
                  idpl(1,j) = ia
                  idpl(2,j) = ib
                  bdpl(j) = hybdpl
                  sdpl(j) = hybpos
                  used = .true.
                  goto 30
               end if
            end do
            if (hybdpl .ne. 0.0d0) then
               ndipole = ndipole + 1
               idpl(1,ndipole) = ia
               idpl(2,ndipole) = ib
               bdpl(ndipole) = hybdpl
               sdpl(ndipole) = hybpos
               used = .true.
            end if
   30       continue
            if (verbose .and. used) then
               if (header) then
                  header = .false.
                  write (iout,40)
   40             format (/,' Hybrid Bond Dipole Moment Parameters :',
     &                    //,6x,'Atom Numbers',7x,'Moment',
     &                       7x,'Position',/)
               end if
               write (iout,50)  ia,ib,hybdpl,hybpos
   50          format (6x,2i5,2f15.3)
            end if
         end if
      end do
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine image  --  pairwise distance of minimum image  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "image" 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 image (xr,yr,zr,i)
      implicit none
      include 'sizes.i'
      include 'boxes.i'
      include 'cell.i'
      integer i
      real*8 xr,yr,zr
      real*8 xmove,ymove,zmove
      real*8 xfrac,yfrac,zfrac
c
c
c     compute the distance to translate along each cell axis
c
      if (i .eq. 0) then
         xmove = 0.0d0
         ymove = 0.0d0
         zmove = 0.0d0
      else
         xmove = icell(1,i) * xbox
         ymove = icell(2,i) * ybox
         zmove = icell(3,i) * zbox
      end if
c
c     for orthogonal lattice, find the desired image directly
c
      if (orthogonal) then
         xr = xr + xmove
         dowhile (xr .gt. xcell2)
            xr = xr - xcell
         end do
         dowhile (xr .lt. -xcell2)
            xr = xr + xcell
         end do
         yr = yr + ymove
         dowhile (yr .gt. ycell2)
            yr = yr - ycell
         end do
         dowhile (yr .lt. -ycell2)
            yr = yr + ycell
         end do
         zr = zr + zmove
         dowhile (zr .gt. zcell2)
            zr = zr - zcell
         end do
         dowhile (zr .lt. -zcell2)
            zr = zr + zcell
         end do
c
c     for monoclinic lattice, convert "xr" and "zr" to
c     fractional coordinates, find desired image and then
c     translate fractional coordinates back to Cartesian
c
      else if (monoclinic) then
         zfrac = zr / beta_sin
         xfrac = xr - zfrac*beta_cos
         xfrac = xfrac + xmove
         dowhile (xfrac .gt. xcell2)
            xfrac = xfrac - xcell
         end do
         dowhile (xfrac .lt. -xcell2)
            xfrac = xfrac + xcell
         end do
         yr = yr + ymove
         dowhile (yr .gt. ycell2)
            yr = yr - ycell
         end do
         dowhile (yr .lt. -ycell2)
            yr = yr + ycell
         end do
         zfrac = zfrac + zmove
         dowhile (zfrac .gt. zcell2)
            zfrac = zfrac - zcell
         end do
         dowhile (zfrac .lt. -zcell2)
            zfrac = zfrac + zcell
         end do
         xr = xfrac + zfrac*beta_cos
         zr = zfrac * beta_sin
c
c     for triclinic lattice, convert pairwise components to
c     fractional coordinates, find desired image and then
c     translate fractional coordinates back to Cartesian
c
      else if (triclinic) then
         zfrac = zr / gamma_term
         yfrac = (yr - zfrac*beta_term) / gamma_sin
         xfrac = xr - yfrac*gamma_cos - zfrac*beta_cos
         xfrac = xfrac + xmove
         dowhile (xfrac .gt. xcell2)
            xfrac = xfrac - xcell
         end do
         dowhile (xfrac .lt. -xcell2)
            xfrac = xfrac + xcell
         end do
         yfrac = yfrac + ymove
         dowhile (yfrac .gt. ycell2)
            yfrac = yfrac - ycell
         end do
         dowhile (yfrac .lt. -ycell2)
            yfrac = yfrac + ycell
         end do
         zfrac = zfrac + zmove
         dowhile (zfrac .gt. zcell2)
            zfrac = zfrac - zcell
         end do
         dowhile (zfrac .lt. -zcell2)
            zfrac = zfrac + zcell
         end do
         xr = xfrac + yfrac*gamma_cos + zfrac*beta_cos
         yr = yfrac*gamma_sin + zfrac*beta_term
         zr = zfrac * gamma_term
c
c     for truncated octahedron, use orthogonal box equations,
c     then perform extra tests to remove corner pieces
c
      else if (octahedron) then
         dowhile (xr .gt. xbox2)
            xr = xr - xbox
         end do
         dowhile (xr .lt. -xbox2)
            xr = xr + xbox
         end do
         dowhile (yr .gt. ybox2)
            yr = yr - ybox
         end do
         dowhile (yr .lt. -ybox2)
            yr = yr + ybox
         end do
         dowhile (zr .gt. zbox2)
            zr = zr - zbox
         end do
         dowhile (zr .lt. -zbox2)
            zr = zr + zbox
         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
      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)
      implicit none
      include 'sizes.i'
      include 'align.i'
      include 'inform.i'
      include 'iounit.i'
      integer i,n1,n2
      real*8 x1(maxatm),x2(maxatm)
      real*8 y1(maxatm),y2(maxatm)
      real*8 z1(maxatm),z2(maxatm)
      real*8 xmid,ymid,zmid
      real*8 rmsvalue,rmsfit
c
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) 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 moment at each
c     polarizable site due to direct or mutual polarization
c
c
      subroutine induce
      implicit none
      include 'sizes.i'
      include 'cutoff.i'
      include 'inform.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'polar.i'
      include 'units.i'
      integer i,j,k
      real*8 norm
      logical header
c
c
c     choose pairwise double loop or Ewald summation version
c
      if (use_ewald) then
         call induce0b
      else
         call induce0a
      end if
c
c     print out a list of the final induced dipole moments
c
      header = .true.
      if (debug) then
         do i = 1, npole
            if (polarity(i) .ne. 0.0d0) then
               if (header) then
                  header = .false.
                  write (iout,10)
   10             format (/,' Induced Dipole Moments (Debyes) :')
                  if (digits .ge. 8) then
                     write (iout,20)
   20                format (/,4x,'Atom',14x,'X',15x,'Y',15x,'Z',
     &                          15x,'Total'/)
                  else if (digits .ge. 6) then
                     write (iout,30)
   30                format (/,4x,'Atom',14x,'X',13x,'Y',13x,'Z',
     &                          12x,'Total'/)
                  else
                     write (iout,40)
   40                format (/,4x,'Atom',14x,'X',11x,'Y',11x,'Z',
     &                          9x,'Total'/)
                  end if
               end if
               k = ipole(i)
               norm = sqrt(uind(1,i)**2+uind(2,i)**2+uind(3,i)**2)
               if (digits .ge. 8) then
                  write (iout,50)  k,(debye*uind(j,i),j=1,3),debye*norm
   50             format (i8,3x,7f10.4)
               else if (digits .ge. 6) then
                  write (iout,60)  k,(debye*uind(j,i),j=1,3),debye*norm
   60             format (i8,4x,7f10.4)
               else
                  write (iout,70)  k,(debye*uind(j,i),j=1,3),debye*norm
   70             format (i8,5x,7f10.4)
               end if
            end if
         end do
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine induce0a  --  induced dipoles via double loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "induce0a" computes the induced dipole moment at each
c     polarizable site using a pairwise double loop
c
c
      subroutine induce0a
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'potent.i'
      include 'shunt.i'
      include 'units.i'
      integer i,j,k,m
      integer iter,maxiter
      integer ii,ix,iz
      integer kk,kx,kz
      real*8 xr,yr,zr
      real*8 fgrp,r,r2
      real*8 rr3,rr5,rr7
      real*8 ci,dix,diy,diz
      real*8 duix,duiy,duiz
      real*8 puix,puiy,puiz
      real*8 qixx,qixy,qixz
      real*8 qiyy,qiyz,qizz
      real*8 ck,dkx,dky,dkz
      real*8 dukx,duky,dukz
      real*8 pukx,puky,pukz
      real*8 qkxx,qkxy,qkxz
      real*8 qkyy,qkyz,qkzz
      real*8 dir,duir,puir
      real*8 dkr,dukr,pukr
      real*8 qix,qiy,qiz,qir
      real*8 qkx,qky,qkz,qkr
      real*8 eps,epsold
      real*8 epsd,epsp
      real*8 scale3,scale5
      real*8 scale7,damp
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 field(3,maxatm)
      real*8 fieldp(3,maxatm)
      real*8 udir(3,maxatm)
      real*8 udirp(3,maxatm)
      real*8 uold(3,maxatm)
      real*8 uoldp(3,maxatm)
      real*8 dscale(maxatm)
      real*8 pscale(maxatm)
      logical proceed,done
c
c
c     zero out the induced dipole and the field at each site
c
      do i = 1, npole
         do j = 1, 3
            uind(j,i) = 0.0d0
            uinp(j,i) = 0.0d0
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
         end do
      end do
      if (.not. use_polar)  return
c
c     set the switching function coefficients
c
      call switch ('MPOLE')
c
c     compute the direct induced dipole moment at each atom
c
      do i = 1, npole-1
         ii = ipole(i)
         iz = zaxis(ii)
         ix = xaxis(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)
         do j = i+1, npole
            dscale(ipole(j)) = 1.0d0
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, n12(ii)
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            pscale(i15(j,ii)) = p5scale
         end do
         do j = 1, np11(ii)
            dscale(ip11(j,ii)) = d1scale
         end do
         do j = 1, np12(ii)
            dscale(ip12(j,ii)) = d2scale
         end do
         do j = 1, np13(ii)
            dscale(ip13(j,ii)) = d3scale
         end do
         do j = 1, np14(ii)
            dscale(ip14(j,ii)) = d4scale
         end do
         do k = i+1, npole
            kk = ipole(k)
            kz = zaxis(kk)
            kx = xaxis(kk)
            proceed = .true.
            if (use_intra)  call groups (proceed,fgrp,2,ii,kk,0,0,0)
            if (proceed) then
               xr = x(kk) - x(ii)
               yr = y(kk) - y(ii)
               zr = z(kk) - z(ii)
               call image (xr,yr,zr,0)
               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)
                  scale3 = 1.0d0 
                  scale5 = 1.0d0
                  scale7 = 1.0d0 
                  damp = pdamp(i) * pdamp(k)
                  if (damp .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)
                     end if
                  end if
                  rr3 = scale3 / (r*r2)
                  rr5 = 3.0d0 * scale5 / (r*r2*r2)
                  rr7 = 15.0d0 * scale7 / (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(kk)
                     field(j,k) = field(j,k) + fkd(j)*dscale(kk)
                     fieldp(j,i) = fieldp(j,i) + fid(j)*pscale(kk)
                     fieldp(j,k) = fieldp(j,k) + fkd(j)*pscale(kk)
                  end do
               end if
            end if
         end do
      end do
c
c     periodic boundary for large cutoffs via replicates method
c
      if (use_replica) then
         do i = 1, npole
            ii = ipole(i)
            iz = zaxis(ii)
            ix = xaxis(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)
            do j = i, npole
               dscale(ipole(j)) = 1.0d0
               pscale(ipole(j)) = 1.0d0
            end do
            do j = 1, n12(ii)
               pscale(i12(j,ii)) = p2scale
            end do
            do j = 1, n13(ii)
               pscale(i13(j,ii)) = p3scale
            end do
            do j = 1, n14(ii)
               pscale(i14(j,ii)) = p4scale
            end do
            do j = 1, n15(ii)
               pscale(i15(j,ii)) = p5scale
            end do
            do j = 1, np11(ii)
               dscale(ip11(j,ii)) = d1scale
            end do
            do j = 1, np12(ii)
               dscale(ip12(j,ii)) = d2scale
            end do
            do j = 1, np13(ii)
               dscale(ip13(j,ii)) = d3scale
            end do
            do j = 1, np14(ii)
               dscale(ip14(j,ii)) = d4scale
            end do
            do k = i, npole
               kk = ipole(k)
               kz = zaxis(kk)
               kx = xaxis(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 = 1, ncell
                  xr = x(kk) - x(ii)
                  yr = y(kk) - y(ii)
                  zr = z(kk) - z(ii)
                  call image (xr,yr,zr,m)
                  r2 = xr*xr + yr* yr + zr*zr
                  if (r2 .le. off2) then
                     r = sqrt(r2)
                     scale3 = 1.0d0 
                     scale5 = 1.0d0
                     scale7 = 1.0d0
                     damp = pdamp(i) * pdamp(k)
                     if (damp .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)
                        end if
                     end if
                     rr3 = scale3 / (r*r2)
                     rr5 = 3.0d0 * scale5 / (r*r2*r2)
                     rr7 = 15.0d0 * scale7 / (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
                       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(kk)
                           fip(j) = fip(j) * pscale(kk)
                           fkd(j) = fkd(j) * dscale(kk)
                           fkp(j) = fkp(j) * pscale(kk)
                        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 (ii .ne. kk) 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
         end do
      end if
c
c     compute induced dipoles as polarizability times field
c
      do i = 1, npole
         do j = 1, 3
            uind(j,i) = polarity(i) * field(j,i)
            uinp(j,i) = polarity(i) * fieldp(j,i)
         end do
      end do
c
c     set tolerances for computation of mutual induced dipoles
c
      if (poltyp .eq. 'MUTUAL') then
         done = .false.
         maxiter = 500
         iter = 0
         eps = 1.0d0
         do i = 1, npole
            do j = 1, 3
               udir(j,i) = uind(j,i)
               udirp(j,i) = uinp(j,i)
            end do
         end do
c
c     compute mutual induced dipole moments by an iterative method
c
         dowhile (.not. done)
            do i = 1, npole
               do j = 1, 3
                  field(j,i) = 0.0d0
                  fieldp(j,i) = 0.0d0
               end do
            end do
            do i = 1, npole-1
               ii = ipole(i)
               iz = zaxis(ii)
               ix = xaxis(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)
               do j = i+1, npole
                  dscale(ipole(j)) = 1.0d0
               end do
               do j = 1, np11(ii)
                  dscale(ip11(j,ii)) = u1scale
               end do
               do j = 1, np12(ii)
                  dscale(ip12(j,ii)) = u2scale
               end do
               do j = 1, np13(ii)
                  dscale(ip13(j,ii)) = u3scale
               end do
               do j = 1, np14(ii)
                  dscale(ip14(j,ii)) = u4scale
               end do
               do k = i+1, npole
                  kk = ipole(k)
                  kz = zaxis(kk)
                  kx = xaxis(kk)
                  proceed = .true.
                  if (use_intra)
     &               call groups (proceed,fgrp,2,ii,kk,0,0,0)
                  if (proceed) then
                     xr = x(kk) - x(ii)
                     yr = y(kk) - y(ii)
                     zr = z(kk) - z(ii)
                     call image (xr,yr,zr,0)
                     r2 = xr*xr + yr* yr + zr*zr
                     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)
                        scale3 = dscale(kk) 
                        scale5 = dscale(kk)
                        damp = pdamp(i) * pdamp(k)
                        if (damp .ne. 0.0d0) then
                           damp = -pgamma * (r/damp)**3
                           if (damp .gt. -50.0d0) then
                              scale3 = scale3 * (1.0d0-exp(damp))
                              scale5 = scale5 * (1.0d0-(1.0d0-damp)
     &                                                     *exp(damp))
                           end if
                        end if
                        rr3 = scale3 / (r*r2)
                        rr5 = 3.0d0 * scale5 / (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
                        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
                        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 if
               end do
            end do
c
c     periodic boundary for large cutoffs via replicates method
c
            if (use_replica) then
               do i = 1, npole
                  ii = ipole(i)
                  iz = zaxis(ii)
                  ix = xaxis(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)
                  do j = i, npole
                     dscale(ipole(j)) = 1.0d0
                  end do
                  do j = 1, np11(ii)
                     dscale(ip11(j,ii)) = u1scale
                  end do
                  do j = 1, np12(ii)
                     dscale(ip12(j,ii)) = u2scale
                  end do
                  do j = 1, np13(ii)
                     dscale(ip13(j,ii)) = u3scale
                  end do
                  do j = 1, np14(ii)
                     dscale(ip14(j,ii)) = u4scale
                  end do
                  do k = i, npole
                     kk = ipole(k)
                     kz = zaxis(kk)
                     kx = xaxis(kk)
                     dukx = uind(1,k)
                     duky = uind(2,k)
                     dukz = uind(3,k)
                     pukx = uinp(1,k)
                     puky = uinp(2,k)
                     pukz = uinp(3,k)
                     do m = 1, ncell
                        xr = x(kk) - x(ii)
                        yr = y(kk) - y(ii)
                        zr = z(kk) - z(ii)
                        call image (xr,yr,zr,m)
                        r2 = xr*xr + yr* yr + zr*zr
                        if (r2 .le. off2) then
                           r = sqrt(r2)
                           scale3 = 1.0d0
                           scale5 = 1.0d0
                           damp = pdamp(i) * pdamp(k)
                           if (damp .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)
                              end if
                           end if
                           rr3 = scale3 / (r*r2)
                           rr5 = 3.0d0 * scale5 / (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
                           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
                           if (use_polymer) then
                              if (r2 .le. polycut2) then
                                 do j = 1, 3
                                    fid(j) = fid(j) * dscale(kk)
                                    fkd(j) = fkd(j) * dscale(kk)
                                    fip(j) = fip(j) * dscale(kk)
                                    fkp(j) = fkp(j) * dscale(kk)
                                 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 (ii .ne. kk) 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
               end do
            end if
c
c     check to see if the mutual induced dipoles have converged
c
            iter = iter + 1
            epsold = eps
            eps = 0.0d0
            epsd = 0.0d0
            epsp = 0.0d0
            do i = 1, npole
               do j = 1, 3
                  uold(j,i) = uind(j,i)
                  uoldp(j,i) = uinp(j,i)
                  uind(j,i) = udir(j,i) + polarity(i)*field(j,i)
                  uinp(j,i) = udirp(j,i) + polarity(i)*fieldp(j,i)
                  uind(j,i) = uold(j,i) + polsor*(uind(j,i)-uold(j,i))
                  uinp(j,i) = uoldp(j,i) + polsor*(uinp(j,i)-uoldp(j,i))
                  epsd = epsd + (uind(j,i)-uold(j,i))**2
                  epsp = epsp + (uinp(j,i)-uoldp(j,i))**2
               end do
            end do
            eps = max(epsd,epsp)
            eps = debye * sqrt(eps/dble(npolar))
            if (debug) then
               if (iter .eq. 1) then
                  write (iout,10)
   10             format (/,' Determination of Induced Dipole',
     &                       ' Moments :',
     &                    //,4x,'Iter',8x,'RMS Change (Debyes)',/)
               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. maxiter)  done = .true.
         end do
c
c     terminate the calculation if dipoles failed to converge
c
         if (eps .gt. poleps) then
            write (iout,30)
   30       format (/,' INDUCE  --  Warning, Induced Dipoles',
     &                 ' are not Converged')
            call prterr
            call fatal
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine induce0b  --  Ewald summation induced dipoles  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "induce0b" computes the induced dipole moment at each
c     polarizable site using a regular Ewald summation
c
c
      subroutine induce0b
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'ewald.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polpot.i'
      include 'potent.i'
      include 'units.i'
      integer i,j,ii
      integer iter,maxiter
      real*8 eps,term
      real*8 epsd,epsp
      real*8 epsold
      real*8 ucell(3)
      real*8 ucellp(3)
      real*8 udir(3,maxatm)
      real*8 udirp(3,maxatm)
      real*8 uold(3,maxatm)
      real*8 uoldp(3,maxatm)
      real*8 field(3,maxatm)
      real*8 fieldp(3,maxatm)
      logical done
c
c
c     zero out the induced dipole and the field at each site
c
      do i = 1, npole
         do j = 1, 3
            uind(j,i) = 0.0d0
            uinp(j,i) = 0.0d0
            field(j,i) = 0.0d0
            fieldp(j,i) = 0.0d0
         end do
      end do
      if (.not. use_polar)  return
c
c     get the reciprical space part of the electrostatic field
c
      call udirect1 (field)
c
c     get the real space portion of the electrostatic field
c
      do i = 1, npole
         do j = 1, 3
            fieldp(j,i) = field(j,i)
         end do
      end do
      call udirect2 (field,fieldp)
c
c     get the self-energy portion of the electrostatic field
c
      term = (4.0d0/3.0d0) * aewald**3 / sqrtpi
      do i = 1, npole
         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 (.not. tinfoil) then
         do i = 1, 3
            ucell(i) = 0.0d0
         end do
         do i = 1, npole
            ii = ipole(i)
            ucell(1) = ucell(1) + rpole(2,i) + rpole(1,i)*x(ii)
            ucell(2) = ucell(2) + rpole(3,i) + rpole(1,i)*y(ii)
            ucell(3) = ucell(3) + rpole(4,i) + rpole(1,i)*z(ii)
         end do
         term = (4.0d0/3.0d0) * pi/volbox
         do i = 1, npole
            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
c
c     compute induced dipoles as polarizability times field
c
      do i = 1, npole
         do j = 1, 3
            uind(j,i) = polarity(i) * field(j,i)
            uinp(j,i) = polarity(i) * fieldp(j,i)
         end do
      end do
c
c     set tolerances for computation of mutual induced dipoles
c
      if (poltyp .eq. 'MUTUAL') then
         done = .false.
         maxiter = 500
         iter = 0
         eps = 1.0d0
         do i = 1, npole
            do j = 1, 3
               udir(j,i) = uind(j,i)
               udirp(j,i) = uinp(j,i)
            end do
         end do
c
c     compute mutual induced dipole moments by an iterative method
c
         dowhile (.not. done)
            do i = 1, npole
               do j = 1, 3
                  field(j,i) = 0.0d0
                  fieldp(j,i) = 0.0d0
               end do
            end do
            call umutual1 (field,fieldp)
            call umutual2 (field,fieldp)
            term = (4.0d0/3.0d0) * aewald**3 / sqrtpi
            do i = 1, npole
               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
            if (.not. tinfoil) then
               do i = 1, 3
                  ucell(i) = 0.0d0
                  ucellp(i) = 0.0d0
               end do
               do i = 1, npole
                  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 i = 1, npole
                  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
c
c     check to see if the mutual induced dipoles have converged
c
            iter = iter + 1
            epsold = eps
            eps = 0.0d0
            epsd = 0.0d0
            epsp = 0.0d0
            do i = 1, npole
               do j = 1, 3
                  uold(j,i) = uind(j,i)
                  uoldp(j,i) = uinp(j,i)
                  uind(j,i) = udir(j,i) + polarity(i)*field(j,i)
                  uinp(j,i) = udirp(j,i) + polarity(i)*fieldp(j,i)
                  uind(j,i) = uold(j,i) + polsor*(uind(j,i)-uold(j,i))
                  uinp(j,i) = uoldp(j,i) + polsor*(uinp(j,i)-uoldp(j,i))
                  epsd = epsd + (uind(j,i)-uold(j,i))**2
                  epsp = epsp + (uinp(j,i)-uoldp(j,i))**2
               end do
            end do
            eps = max(epsd,epsp)
            eps = debye * sqrt(eps/dble(npolar))
            if (debug) then
               if (iter .eq. 1) then
                  write (iout,10)
   10             format (/,' Determination of Induced Dipole',
     &                       ' Moments :',
     &                    //,4x,'Iter',8x,'RMS Change (Debyes)',/)
               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. maxiter)  done = .true.
         end do
c
c     terminate the calculation if dipoles failed to converge
c
         if (eps .gt. poleps) then
            write (iout,30)
   30       format (/,' INDUCE  --  Warning, Induced Dipoles',
     &                 ' are not Converged')
            call prterr
            call fatal
         end if
      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 electrostatic field
c     for use in finding the direct induced dipole moments via a
c     regular Ewald summation
c
c
      subroutine udirect1 (field)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'ewald.i'
      include 'ewreg.i'
      include 'math.i'
      include 'mpole.i'
      include 'units.i'
      integer i,j,k,l,ii
      integer jmin,jmax
      integer kmin,kmax
      integer lmin,lmax
      real*8 expterm,cut
      real*8 term,fterm
      real*8 xfr,yfr,zfr
      real*8 rj,rk,rl
      real*8 h1,h2,h3,hsq
      real*8 qf,t1,t2
      real*8 ck,dk,qk
      real*8 q1,q2,q3
      real*8 ckr(maxatm)
      real*8 skr(maxatm)
      real*8 cjk(maxatm)
      real*8 sjk(maxatm)
      real*8 cm(maxatm)
      real*8 dm(3,maxatm)
      real*8 qm(9,maxatm)
      real*8 field(3,maxatm)
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      term = -0.25d0 / aewald**2
      fterm = 8.0d0 * pi / volbox
c
c     set the number of vectors based on box dimensions
c
      cut = 4.0d0 * pi * pi * frecip
      jmin = 0
      kmin = 0
      lmin = 1
      jmax = min(maxvec,int(frecip/recip(1,1)))
      kmax = min(maxvec,int(frecip/recip(2,2)))
      lmax = min(maxvec,int(frecip/recip(3,3)))
c
c     copy the multipole moments into local storage areas
c
      do i = 1, npole
         cm(i) = rpole(1,i)
         dm(1,i) = rpole(2,i)
         dm(2,i) = rpole(3,i)
         dm(3,i) = rpole(4,i)
         qm(1,i) = rpole(5,i)
         qm(2,i) = rpole(6,i)
         qm(3,i) = rpole(7,i)
         qm(4,i) = rpole(8,i)
         qm(5,i) = rpole(9,i)
         qm(6,i) = rpole(10,i)
         qm(7,i) = rpole(11,i)
         qm(8,i) = rpole(12,i)
         qm(9,i) = rpole(13,i)
      end do
c
c     calculate and store the exponential factors
c
      do i = 1, npole
         ii = ipole(i)
         zfr = (z(ii)/gamma_term) / zbox
         yfr = ((y(ii)-zfr*zbox*beta_term)/gamma_sin) / ybox
         xfr = (x(ii)-yfr*ybox*gamma_cos-zfr*zbox*beta_cos) / xbox
         xfr = 2.0d0 * pi * xfr
         yfr = 2.0d0 * pi * yfr
         zfr = 2.0d0 * pi * zfr
         ejc(i,0) = 1.0d0
         ejs(i,0) = 0.0d0
         ekc(i,0) = 1.0d0
         eks(i,0) = 0.0d0
         elc(i,0) = 1.0d0
         els(i,0) = 0.0d0
         ejc(i,1) = cos(xfr)
         ejs(i,1) = sin(xfr)
         ekc(i,1) = cos(yfr)
         eks(i,1) = sin(yfr)
         elc(i,1) = cos(zfr)
         els(i,1) = sin(zfr)
         ekc(i,-1) = ekc(i,1)
         eks(i,-1) = -eks(i,1)
         elc(i,-1) = elc(i,1)
         els(i,-1) = -els(i,1)
         do j = 2, jmax
            ejc(i,j) = ejc(i,j-1)*ejc(i,1) - ejs(i,j-1)*ejs(i,1)
            ejs(i,j) = ejs(i,j-1)*ejc(i,1) + ejc(i,j-1)*ejs(i,1)
         end do
         do j = 2, kmax
            ekc(i,j) = ekc(i,j-1)*ekc(i,1) - eks(i,j-1)*eks(i,1)
            eks(i,j) = eks(i,j-1)*ekc(i,1) + ekc(i,j-1)*eks(i,1)
            ekc(i,-j) = ekc(i,j)
            eks(i,-j) = -eks(i,j)
         end do
         do j = 2, lmax
            elc(i,j) = elc(i,j-1)*elc(i,1) - els(i,j-1)*els(i,1)
            els(i,j) = els(i,j-1)*elc(i,1) + elc(i,j-1)*els(i,1)
            elc(i,-j) = elc(i,j)
            els(i,-j) = -els(i,j)
         end do
      end do
c
c     loop over all k vectors from the reciprocal lattice
c
      do j = jmin, jmax
         rj = 2.0d0 * pi * dble(j)
         do k = kmin, kmax
            rk = 2.0d0 * pi * dble(k)
            do i = 1, npole
               cjk(i) = ejc(i,j)*ekc(i,k) - ejs(i,j)*eks(i,k)
               sjk(i) = ejs(i,j)*ekc(i,k) + ejc(i,j)*eks(i,k)
            end do
            do l = lmin, lmax
               rl = 2.0d0 * pi * dble(l)
               h1 = recip(1,1)*rj
               h2 = recip(2,1)*rj + recip(2,2)*rk
               h3 = recip(3,1)*rj + recip(3,2)*rk + recip(3,3)*rl
               hsq = h1*h1 + h2*h2 + h3*h3
               if (hsq .le. cut) then
                  t1 = 0.0d0
                  t2 = 0.0d0
                  do i = 1, npole
                     ckr(i) = cjk(i)*elc(i,l) - sjk(i)*els(i,l)
                     skr(i) = sjk(i)*elc(i,l) + cjk(i)*els(i,l)
                     ck = cm(i)
                     dk = h1*dm(1,i) + h2*dm(2,i) + h3*dm(3,i)
                     q1 = h1*qm(1,i) + h2*qm(4,i) + h3*qm(7,i)
                     q2 = h1*qm(2,i) + h2*qm(5,i) + h3*qm(8,i)
                     q3 = h1*qm(3,i) + h2*qm(6,i) + h3*qm(9,i)
                     qk = h1*q1 + h2*q2 + h3*q3
                     t1 = t1 + (ck-qk)*skr(i) + dk*ckr(i)
                     t2 = t2 + (ck-qk)*ckr(i) - dk*skr(i)
                  end do
                  expterm = fterm * exp(term*hsq) / hsq
                  do i = 1, npole
                     qf = expterm * (skr(i)*t2-ckr(i)*t1)
                     field(1,i) = field(1,i) + h1*qf
                     field(2,i) = field(2,i) + h2*qf
                     field(3,i) = field(3,i) + h3*qf
                  end do
               end if
            end do
            lmin = -lmax
         end do
         kmin = -kmax
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine udirect2  --  Ewald real direct induced field  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "udirect2" computes the real space contribution of the permanent
c     atomic multipole moments to the electrostatic field for use in
c     finding the direct induced dipole moments via a regular Ewald
c     summation
c
c
      subroutine udirect2 (field,fieldp)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'ewald.i'
      include 'math.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'shunt.i'
      include 'units.i'
      integer i,j,k,m
      integer ii,kk
      real*8 xr,yr,zr,r,r2
      real*8 erfc,bfac,exp2a
      real*8 drr3,drr5,drr7
      real*8 prr3,prr5,prr7
      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 ralpha,damp
      real*8 alsq2,alsq2n
      real*8 scale3,scale5
      real*8 scale7
      real*8 dsc3,dsc5,dsc7
      real*8 psc3,psc5,psc7
      real*8 bn(0:3)
      real*8 fim(3),fkm(3)
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 field(3,maxatm)
      real*8 fieldp(3,maxatm)
      real*8 dscale(maxatm)
      real*8 pscale(maxatm)
c
c
c     check for multipoles and set cutoff coefficients
c
      if (npole .eq. 0)  return
      call switch ('EWALD')
c
c     compute the real space portion of the Ewald summation
c
      do i = 1, npole-1
         ii = ipole(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)
         do j = i+1, npole
            dscale(ipole(j)) = 1.0d0
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, n12(ii)
            pscale(i12(j,ii)) = p2scale
         end do
         do j = 1, n13(ii)
            pscale(i13(j,ii)) = p3scale
         end do
         do j = 1, n14(ii)
            pscale(i14(j,ii)) = p4scale
         end do
         do j = 1, n15(ii)
            pscale(i15(j,ii)) = p5scale
         end do
         do j = 1, np11(ii)
            dscale(ip11(j,ii)) = d1scale
         end do
         do j = 1, np12(ii)
            dscale(ip12(j,ii)) = d2scale
         end do
         do j = 1, np13(ii)
            dscale(ip13(j,ii)) = d3scale
         end do
         do j = 1, np14(ii)
            dscale(ip14(j,ii)) = d4scale
         end do
         do k = i+1, npole
            kk = ipole(k)
            xr = x(kk) - x(ii)
            yr = y(kk) - y(ii)
            zr = z(kk) - z(ii)
            call image (xr,yr,zr,0)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. cut2) 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     calculate the error function damping terms
c
               ralpha = aewald * r
               bn(0) = erfc(ralpha) / r
               alsq2 = 2.0d0 * aewald**2
               alsq2n = 0.0d0
               if (aewald .gt. 0.0d0)
     &            alsq2n = 1.0d0 / (sqrtpi*aewald)
               exp2a = exp(-ralpha**2)
               do j = 1, 3
                  bfac = dble(j+j-1)
                  alsq2n = alsq2 * alsq2n
                  bn(j) = (bfac*bn(j-1)+alsq2n*exp2a) / r2
               end do
c
c     compute the error function scaled and unscaled terms
c
               scale3 = 1.0d0 
               scale5 = 1.0d0 
               scale7 = 1.0d0 
               damp = pdamp(i) * pdamp(k)
               if (damp .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)
                  end if
               end if
               dsc3=scale3*dscale(kk)
               dsc5=scale5*dscale(kk)
               dsc7=scale7*dscale(kk)
               psc3=scale3*pscale(kk)
               psc5=scale5*pscale(kk)
               psc7=scale7*pscale(kk)
               drr3 = (1.0d0-dsc3) / (r*r2)
               drr5 = 3.0d0 * (1.0d0-dsc5) / (r*r2*r2)
               drr7 = 15.0d0 * (1.0d0-dsc7) / (r*r2*r2*r2)
               prr3 = (1.0d0-psc3) / (r*r2)
               prr5 = 3.0d0 * (1.0d0-psc5) / (r*r2*r2)
               prr7 = 15.0d0 * (1.0d0-psc7) / (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
               fim(1) = -xr*(bn(1)*ck-bn(2)*dkr+bn(3)*qkr)
     &                     - bn(1)*dkx + 2.0d0*bn(2)*qkx
               fim(2) = -yr*(bn(1)*ck-bn(2)*dkr+bn(3)*qkr)
     &                     - bn(1)*dky + 2.0d0*bn(2)*qky
               fim(3) = -zr*(bn(1)*ck-bn(2)*dkr+bn(3)*qkr)
     &                     - bn(1)*dkz + 2.0d0*bn(2)*qkz
               fkm(1) = xr*(bn(1)*ci+bn(2)*dir+bn(3)*qir)
     &                     - bn(1)*dix - 2.0d0*bn(2)*qix
               fkm(2) = yr*(bn(1)*ci+bn(2)*dir+bn(3)*qir)
     &                     - bn(1)*diy - 2.0d0*bn(2)*qiy
               fkm(3) = zr*(bn(1)*ci+bn(2)*dir+bn(3)*qir)
     &                     - bn(1)*diz - 2.0d0*bn(2)*qiz
               fid(1) = -xr*(drr3*ck-drr5*dkr+drr7*qkr)
     &                     - drr3*dkx + 2.0d0*drr5*qkx
               fid(2) = -yr*(drr3*ck-drr5*dkr+drr7*qkr)
     &                     - drr3*dky + 2.0d0*drr5*qky
               fid(3) = -zr*(drr3*ck-drr5*dkr+drr7*qkr)
     &                     - drr3*dkz + 2.0d0*drr5*qkz
               fkd(1) = xr*(drr3*ci+drr5*dir+drr7*qir)
     &                     - drr3*dix - 2.0d0*drr5*qix
               fkd(2) = yr*(drr3*ci+drr5*dir+drr7*qir)
     &                     - drr3*diy - 2.0d0*drr5*qiy
               fkd(3) = zr*(drr3*ci+drr5*dir+drr7*qir)
     &                     - drr3*diz - 2.0d0*drr5*qiz
               fip(1) = -xr*(prr3*ck-prr5*dkr+prr7*qkr)
     &                     - prr3*dkx + 2.0d0*prr5*qkx
               fip(2) = -yr*(prr3*ck-prr5*dkr+prr7*qkr)
     &                     - prr3*dky + 2.0d0*prr5*qky
               fip(3) = -zr*(prr3*ck-prr5*dkr+prr7*qkr)
     &                     - prr3*dkz + 2.0d0*prr5*qkz
               fkp(1) = xr*(prr3*ci+prr5*dir+prr7*qir)
     &                     - prr3*dix - 2.0d0*prr5*qix
               fkp(2) = yr*(prr3*ci+prr5*dir+prr7*qir)
     &                     - prr3*diy - 2.0d0*prr5*qiy
               fkp(3) = zr*(prr3*ci+prr5*dir+prr7*qir)
     &                     - prr3*diz - 2.0d0*prr5*qiz
c
c     increment the field at each site due to this interaction
c
               do j = 1, 3
                  field(j,i) = field(j,i) + fim(j) - fid(j)
                  field(j,k) = field(j,k) + fkm(j) - fkd(j)
                  fieldp(j,i) = fieldp(j,i) + fim(j) - fip(j)
                  fieldp(j,k) = fieldp(j,k) + fkm(j) - fkp(j)
               end do
            end if
         end do
      end do
c
c     periodic boundary for large cutoffs via replicates method
c
      if (use_replica) then
         do i = 1, npole
            ii = ipole(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)
            do j = i, npole
               dscale(ipole(j)) = 1.0d0
               pscale(ipole(j)) = 1.0d0
            end do
            do j = 1, n12(ii)
               pscale(i12(j,ii)) = p2scale
            end do
            do j = 1, n13(ii)
               pscale(i13(j,ii)) = p3scale
            end do
            do j = 1, n14(ii)
               pscale(i14(j,ii)) = p4scale
            end do
            do j = 1, n15(ii)
               pscale(i15(j,ii)) = p5scale
            end do
            do j = 1, np11(ii)
               dscale(ip11(j,ii)) = d1scale
            end do
            do j = 1, np12(ii)
               dscale(ip12(j,ii)) = d2scale
            end do
            do j = 1, np13(ii)
               dscale(ip13(j,ii)) = d3scale
            end do
            do j = 1, np14(ii)
               dscale(ip14(j,ii)) = d4scale
            end do
            do k = i, npole
               kk = ipole(k)
               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 = 1, ncell
                  xr = x(kk) - x(ii)
                  yr = y(kk) - y(ii)
                  zr = z(kk) - z(ii)
                  call image (xr,yr,zr,m)
                  r2 = xr*xr + yr* yr + zr*zr
c
c     calculate the error function damping terms
c
                  if (r2 .le. cut2) then
                     r = sqrt(r2)
                     ralpha = aewald * r
                     bn(0) = erfc(ralpha) / r
                     alsq2 = 2.0d0 * aewald**2
                     alsq2n = 0.0d0
                     if (aewald .gt. 0.0d0)
     &                  alsq2n = 1.0d0 / (sqrtpi*aewald)
                     exp2a = exp(-ralpha**2)
                     do j = 1, 3
                        bfac = dble(j+j-1)
                        alsq2n = alsq2 * alsq2n
                        bn(j) = (bfac*bn(j-1)+alsq2n*exp2a) / r2
                     end do
c
c     compute the error function scaled and unscaled terms
c
                     scale3 = 1.0d0 
                     scale5 = 1.0d0
                     scale7 = 1.0d0
                     damp = pdamp(i) * pdamp(k)
                     if (damp .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)
                        end if
                     end if
                     dsc3 = scale3
                     dsc5 = scale5
                     dsc7 = scale7
                     psc3 = scale3
                     psc5 = scale5
                     psc7 = scale7
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           dsc3 = scale3 * dscale(kk)
                           dsc5 = scale5 * dscale(kk)
                           dsc7 = scale7 * dscale(kk)
                           psc3 = scale3 * pscale(kk)
                           psc5 = scale5 * pscale(kk)
                           psc7 = scale7 * pscale(kk)
                        end if
                     end if
                     drr3 = (1.0d0-dsc3) / (r*r2)
                     drr5 = 3.0d0 * (1.0d0-dsc5) / (r*r2*r2)
                     drr7 = 15.0d0 * (1.0d0-dsc7) / (r*r2*r2*r2)
                     prr3 = (1.0d0-psc3) / (r*r2)
                     prr5 = 3.0d0 * (1.0d0-psc5) / (r*r2*r2)
                     prr7 = 15.0d0 * (1.0d0-psc7) / (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
                     fim(1) = -xr*(bn(1)*ck-bn(2)*dkr+bn(3)*qkr)
     &                           - bn(1)*dkx + 2.0d0*bn(2)*qkx
                     fim(2) = -yr*(bn(1)*ck-bn(2)*dkr+bn(3)*qkr)
     &                           - bn(1)*dky + 2.0d0*bn(2)*qky
                     fim(3) = -zr*(bn(1)*ck-bn(2)*dkr+bn(3)*qkr)
     &                           - bn(1)*dkz + 2.0d0*bn(2)*qkz
                     fkm(1) = xr*(bn(1)*ci+bn(2)*dir+bn(3)*qir)
     &                           - bn(1)*dix - 2.0d0*bn(2)*qix
                     fkm(2) = yr*(bn(1)*ci+bn(2)*dir+bn(3)*qir)
     &                           - bn(1)*diy - 2.0d0*bn(2)*qiy
                     fkm(3) = zr*(bn(1)*ci+bn(2)*dir+bn(3)*qir)
     &                           - bn(1)*diz - 2.0d0*bn(2)*qiz
                     fid(1) = -xr*(drr3*ck-drr5*dkr+drr7*qkr)
     &                           - drr3*dkx + 2.0d0*drr5*qkx
                     fid(2) = -yr*(drr3*ck-drr5*dkr+drr7*qkr)
     &                           - drr3*dky + 2.0d0*drr5*qky
                     fid(3) = -zr*(drr3*ck-drr5*dkr+drr7*qkr)
     &                           - drr3*dkz + 2.0d0*drr5*qkz
                     fkd(1) = xr*(drr3*ci+drr5*dir+drr7*qir)
     &                           - drr3*dix - 2.0d0*drr5*qix
                     fkd(2) = yr*(drr3*ci+drr5*dir+drr7*qir)
     &                           - drr3*diy - 2.0d0*drr5*qiy
                     fkd(3) = zr*(drr3*ci+drr5*dir+drr7*qir)
     &                           - drr3*diz - 2.0d0*drr5*qiz
                     fip(1) = -xr*(prr3*ck-prr5*dkr+prr7*qkr)
     &                           - prr3*dkx + 2.0d0*prr5*qkx
                     fip(2) = -yr*(prr3*ck-prr5*dkr+prr7*qkr)
     &                           - prr3*dky + 2.0d0*prr5*qky
                     fip(3) = -zr*(prr3*ck-prr5*dkr+prr7*qkr)
     &                           - prr3*dkz + 2.0d0*prr5*qkz
                     fkp(1) = xr*(prr3*ci+prr5*dir+prr7*qir)
     &                           - prr3*dix - 2.0d0*prr5*qix
                     fkp(2) = yr*(prr3*ci+prr5*dir+prr7*qir)
     &                           - prr3*diy - 2.0d0*prr5*qiy
                     fkp(3) = zr*(prr3*ci+prr5*dir+prr7*qir)
     &                           - prr3*diz - 2.0d0*prr5*qiz
c
c     increment the field at each site due to this interaction
c
                     do j = 1, 3
                        field(j,i) = field(j,i) + fim(j) - fid(j)
                        fieldp(j,i) = fieldp(j,i) + fim(j) - fip(j)
                        if (ii .ne. kk) then
                           field(j,k) = field(j,k) + fkm(j) - fkd(j)
                           fieldp(j,k) = fieldp(j,k) + fkm(j) - fkp(j)
                        end if
                     end do
                  end if
               end do
            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 electrostatic field for
c     use in iterative calculation of induced dipole moments via a
c     regular Ewald summation
c
c
      subroutine umutual1 (field,fieldp)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'ewald.i'
      include 'ewreg.i'
      include 'math.i'
      include 'mpole.i'
      include 'polar.i'
      include 'units.i'
      integer i,j,k,l,ii
      integer jmin,jmax
      integer kmin,kmax
      integer lmin,lmax
      real*8 expterm,cut
      real*8 term,fterm
      real*8 xfr,yfr,zfr
      real*8 rj,rk,rl
      real*8 h1,h2,h3,hsq
      real*8 duk,puk
      real*8 dqf,pqf
      real*8 t1,t2,t3,t4
      real*8 ckr(maxatm)
      real*8 skr(maxatm)
      real*8 cjk(maxatm)
      real*8 sjk(maxatm)
      real*8 field(3,maxatm)
      real*8 fieldp(3,maxatm)
c
c
c     return if the Ewald coefficient is zero
c
      if (aewald .lt. 1.0d-6)  return
      term = -0.25d0 / aewald**2
      fterm = 8.0d0 * pi / volbox
c
c     set the number of vectors based on box dimensions
c
      cut = 4.0d0 * pi * pi * frecip
      jmin = 0
      kmin = 0
      lmin = 1
      jmax = min(maxvec,int(frecip/recip(1,1)))
      kmax = min(maxvec,int(frecip/recip(2,2)))
      lmax = min(maxvec,int(frecip/recip(3,3)))
c
c     calculate and store the exponential factors
c
      do i = 1, npole
         ii = ipole(i)
         zfr = (z(ii)/gamma_term) / zbox
         yfr = ((y(ii)-zfr*zbox*beta_term)/gamma_sin) / ybox
         xfr = (x(ii)-yfr*ybox*gamma_cos-zfr*zbox*beta_cos) / xbox
         xfr = 2.0d0 * pi * xfr
         yfr = 2.0d0 * pi * yfr
         zfr = 2.0d0 * pi * zfr
         ejc(i,0) = 1.0d0
         ejs(i,0) = 0.0d0
         ekc(i,0) = 1.0d0
         eks(i,0) = 0.0d0
         elc(i,0) = 1.0d0
         els(i,0) = 0.0d0
         ejc(i,1) = cos(xfr)
         ejs(i,1) = sin(xfr)
         ekc(i,1) = cos(yfr)
         eks(i,1) = sin(yfr)
         elc(i,1) = cos(zfr)
         els(i,1) = sin(zfr)
         ekc(i,-1) = ekc(i,1)
         eks(i,-1) = -eks(i,1)
         elc(i,-1) = elc(i,1)
         els(i,-1) = -els(i,1)
         do j = 2, jmax
            ejc(i,j) = ejc(i,j-1)*ejc(i,1) - ejs(i,j-1)*ejs(i,1)
            ejs(i,j) = ejs(i,j-1)*ejc(i,1) + ejc(i,j-1)*ejs(i,1)
         end do
         do j = 2, kmax
            ekc(i,j) = ekc(i,j-1)*ekc(i,1) - eks(i,j-1)*eks(i,1)
            eks(i,j) = eks(i,j-1)*ekc(i,1) + ekc(i,j-1)*eks(i,1)
            ekc(i,-j) = ekc(i,j)
            eks(i,-j) = -eks(i,j)
         end do
         do j = 2, lmax
            elc(i,j) = elc(i,j-1)*elc(i,1) - els(i,j-1)*els(i,1)
            els(i,j) = els(i,j-1)*elc(i,1) + elc(i,j-1)*els(i,1)
            elc(i,-j) = elc(i,j)
            els(i,-j) = -els(i,j)
         end do
      end do
c
c     loop over all k vectors from the reciprocal lattice
c
      do j = jmin, jmax
         rj = 2.0d0 * pi * dble(j)
         do k = kmin, kmax
            rk = 2.0d0 * pi * dble(k)
            do i = 1, npole
               cjk(i) = ejc(i,j)*ekc(i,k) - ejs(i,j)*eks(i,k)
               sjk(i) = ejs(i,j)*ekc(i,k) + ejc(i,j)*eks(i,k)
            end do
            do l = lmin, lmax
               rl = 2.0d0 * pi * dble(l)
               h1 = recip(1,1)*rj
               h2 = recip(2,1)*rj + recip(2,2)*rk
               h3 = recip(3,1)*rj + recip(3,2)*rk + recip(3,3)*rl
               hsq = h1*h1 + h2*h2 + h3*h3
               if (hsq .le. cut) then
                  t1 = 0.0d0
                  t2 = 0.0d0
                  t3 = 0.0d0
                  t4 = 0.0d0
                  do i = 1, npole
                     ckr(i) = cjk(i)*elc(i,l) - sjk(i)*els(i,l)
                     skr(i) = sjk(i)*elc(i,l) + cjk(i)*els(i,l)
                     duk = h1*uind(1,i) + h2*uind(2,i) + h3*uind(3,i)
                     puk = h1*uinp(1,i) + h2*uinp(2,i) + h3*uinp(3,i)
                     t1 = t1 + duk*ckr(i)
                     t2 = t2 - duk*skr(i)
                     t3 = t3 + puk*ckr(i)
                     t4 = t4 - puk*skr(i)
                  end do
                  expterm = fterm * exp(term*hsq) / hsq
                  do i = 1, npole
                     dqf = expterm * (skr(i)*t2-ckr(i)*t1)
                     pqf = expterm * (skr(i)*t4-ckr(i)*t3)
                     field(1,i) = field(1,i) + h1*dqf
                     field(2,i) = field(2,i) + h2*dqf
                     field(3,i) = field(3,i) + h3*dqf
                     fieldp(1,i) = fieldp(1,i) + h1*pqf
                     fieldp(2,i) = fieldp(2,i) + h2*pqf
                     fieldp(3,i) = fieldp(3,i) + h3*pqf
                  end do
               end if
            end do
            lmin = -lmax
         end do
         kmin = -kmax
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine umutual2  --  Ewald real mutual induced field  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "umutual2" computes the real space contribution of the induced
c     atomic dipole moments to the electrostatic field for use in
c     iterative calculation of induced dipole moments via a regular
c     Ewald summation
c
c
      subroutine umutual2 (field,fieldp)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'ewald.i'
      include 'math.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      include 'shunt.i'
      include 'units.i'
      integer i,j,k,m
      integer ii,kk
      real*8 xr,yr,zr
      real*8 r,r2,rr3,rr5
      real*8 erfc,bfac,exp2a
      real*8 duir,dukr
      real*8 puir,pukr
      real*8 duix,duiy,duiz
      real*8 puix,puiy,puiz
      real*8 dukx,duky,dukz
      real*8 pukx,puky,pukz
      real*8 ralpha,damp
      real*8 alsq2,alsq2n
      real*8 scale3,scale5
      real*8 bn(0:2)
      real*8 fimd(3),fkmd(3)
      real*8 fimp(3),fkmp(3)
      real*8 fid(3),fkd(3)
      real*8 fip(3),fkp(3)
      real*8 field(3,maxatm)
      real*8 fieldp(3,maxatm)
      real*8 dscale(maxatm)
c
c
c     check for multipoles and set cutoff coefficients
c
      if (npole .eq. 0)  return
      call switch ('EWALD')
c
c     compute the real space portion of the Ewald summation
c
      do i = 1, npole-1
         ii = ipole(i)
         duix = uind(1,i)
         duiy = uind(2,i)
         duiz = uind(3,i)
         puix = uinp(1,i)
         puiy = uinp(2,i)
         puiz = uinp(3,i)
         do j = i+1, npole
            dscale(ipole(j)) = 1.0d0
         end do
         do j = 1, np11(ii)
            dscale(ip11(j,ii)) = u1scale
         end do
         do j = 1, np12(ii)
            dscale(ip12(j,ii)) = u2scale
         end do
         do j = 1, np13(ii)
            dscale(ip13(j,ii)) = u3scale
         end do
         do j = 1, np14(ii)
            dscale(ip14(j,ii)) = u4scale
         end do
         do k = i+1, npole
            kk = ipole(k)
            xr = x(kk) - x(ii)
            yr = y(kk) - y(ii)
            zr = z(kk) - z(ii)
            call image (xr,yr,zr,0)
            r2 = xr*xr + yr* yr + zr*zr
            if (r2 .le. cut2) 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)
c
c     calculate the error function damping terms
c
               ralpha = aewald * r
               bn(0) = erfc(ralpha) / r
               alsq2 = 2.0d0 * aewald**2
               alsq2n = 0.0d0
               if (aewald .gt. 0.0d0)
     &            alsq2n = 1.0d0 / (sqrtpi*aewald)
               exp2a = exp(-ralpha**2)
               do j = 1, 2
                  bfac = dble(j+j-1)
                  alsq2n = alsq2 * alsq2n
                  bn(j) = (bfac*bn(j-1)+alsq2n*exp2a) / r2
               end do
c
c     compute the error function scaled and unscaled terms
c
               scale3 = dscale(kk) 
               scale5 = dscale(kk)
               damp = pdamp(i) * pdamp(k)
               if (damp .ne. 0.0d0) then
                  damp = -pgamma * (r/damp)**3
                  if (damp .gt. -50.0d0) then
                     scale3 = scale3 * (1.0d0-exp(damp))
                     scale5 = scale5 * (1.0d0-(1.0d0-damp)*exp(damp))
                  end if
               end if
               rr3 = (1.0d0-scale3) / (r*r2)
               rr5 = 3.0d0 * (1.0d0-scale5) / (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
               fimd(1) = -bn(1)*dukx + bn(2)*dukr*xr 
               fimd(2) = -bn(1)*duky + bn(2)*dukr*yr
               fimd(3) = -bn(1)*dukz + bn(2)*dukr*zr
               fkmd(1) = -bn(1)*duix + bn(2)*duir*xr 
               fkmd(2) = -bn(1)*duiy + bn(2)*duir*yr
               fkmd(3) = -bn(1)*duiz + bn(2)*duir*zr
               fimp(1) = -bn(1)*pukx + bn(2)*pukr*xr 
               fimp(2) = -bn(1)*puky + bn(2)*pukr*yr
               fimp(3) = -bn(1)*pukz + bn(2)*pukr*zr
               fkmp(1) = -bn(1)*puix + bn(2)*puir*xr 
               fkmp(2) = -bn(1)*puiy + bn(2)*puir*yr
               fkmp(3) = -bn(1)*puiz + bn(2)*puir*zr
               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
c
c     increment the field at each site due to this interaction
c
               do j = 1, 3
                  field(j,i) = field(j,i) + fimd(j) - fid(j)
                  field(j,k) = field(j,k) + fkmd(j) - fkd(j)
                  fieldp(j,i) = fieldp(j,i) + fimp(j) - fip(j)
                  fieldp(j,k) = fieldp(j,k) + fkmp(j) - fkp(j)
               end do
            end if
         end do
      end do
c
c     periodic boundary for large cutoffs via replicates method
c
      if (use_replica) then
         do i = 1, npole
            ii = ipole(i)
            duix = uind(1,i)
            duiy = uind(2,i)
            duiz = uind(3,i)
            puix = uinp(1,i)
            puiy = uinp(2,i)
            puiz = uinp(3,i)
            do j = i, npole
               dscale(ipole(j)) = 1.0d0
            end do
            do j = 1, np11(ii)
               dscale(ip11(j,ii)) = u1scale
            end do
            do j = 1, np12(ii)
               dscale(ip12(j,ii)) = u2scale
            end do
            do j = 1, np13(ii)
               dscale(ip13(j,ii)) = u3scale
            end do
            do j = 1, np14(ii)
               dscale(ip14(j,ii)) = u4scale
            end do
            do k = i, npole
               kk = ipole(k)
               dukx = uind(1,k)
               duky = uind(2,k)
               dukz = uind(3,k)
               pukx = uinp(1,k)
               puky = uinp(2,k)
               pukz = uinp(3,k)
               do m = 1, ncell
                  xr = x(kk) - x(ii)
                  yr = y(kk) - y(ii)
                  zr = z(kk) - z(ii)
                  call image (xr,yr,zr,m)
                  r2 = xr*xr + yr* yr + zr*zr
c
c     calculate the error function damping terms
c
                  if (r2 .le. cut2) then
                     r = sqrt(r2)
                     ralpha = aewald * r
                     bn(0) = erfc(ralpha) / r
                     alsq2 = 2.0d0 * aewald**2
                     alsq2n = 0.0d0
                     if (aewald .gt. 0.0d0)
     &                  alsq2n = 1.0d0 / (sqrtpi*aewald)
                     exp2a = exp(-ralpha**2)
                     do j = 1, 2
                        bfac = dble(j+j-1)
                        alsq2n = alsq2 * alsq2n
                        bn(j) = (bfac*bn(j-1)+alsq2n*exp2a) / r2
                     end do
c
c     compute the error function scaled and unscaled terms
c
                     scale3 = 1.0d0 
                     scale5 = 1.0d0
                     damp = pdamp(i) * pdamp(k)
                     if (damp .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)
                        end if
                     end if
                     if (use_polymer) then
                        if (r2 .le. polycut2) then
                           scale3 = scale3 * dscale(kk)
                           scale5 = scale5 * dscale(kk)
                        end if
                     end if
                     rr3 = (1.0d0-scale3) / (r*r2)
                     rr5 = 3.0d0 * (1.0d0-scale5) / (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
                     fimd(1) = -bn(1)*dukx + bn(2)*dukr*xr 
                     fimd(2) = -bn(1)*duky + bn(2)*dukr*yr
                     fimd(3) = -bn(1)*dukz + bn(2)*dukr*zr
                     fkmd(1) = -bn(1)*duix + bn(2)*duir*xr 
                     fkmd(2) = -bn(1)*duiy + bn(2)*duir*yr
                     fkmd(3) = -bn(1)*duiz + bn(2)*duir*zr
                     fimp(1) = -bn(1)*pukx + bn(2)*pukr*xr 
                     fimp(2) = -bn(1)*puky + bn(2)*pukr*yr
                     fimp(3) = -bn(1)*pukz + bn(2)*pukr*zr
                     fkmp(1) = -bn(1)*puix + bn(2)*puir*xr 
                     fkmp(2) = -bn(1)*puiy + bn(2)*puir*yr
                     fkmp(3) = -bn(1)*puiz + bn(2)*puir*zr
                     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
c
c     increment the field at each site due to this interaction
c
                     do j = 1, 3
                        field(j,i) = field(j,i) + fimd(j) - fid(j)
                        fieldp(j,i) = fieldp(j,i) + fimp(j) - fip(j)
                        if (ii .ne. kk) then
                           field(j,k) = field(j,k) + fkmd(j) -fkd(j)
                           fieldp(j,k) = fieldp(j,k) + fkmp(j) -fkd(j)
                        end if
                     end do
                  end if
               end do
            end do
         end do
      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     Herbert Goldstein, "Classical Mechanics, 2nd Edition",
c     Addison-Wesley, Reading, MA, 1980; see the Euler angle
c     xyz convention in Appendix B
c
c
      subroutine inertia (mode)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'atmtyp.i'
      include 'iounit.i'
      include 'math.i'
      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 moment(3),vec(3,3)
      real*8 work1(3),work2(3)
      real*8 tensor(3,3),a(3,3)
      logical print,move
c
c
c     decide upon the type of output desired
c
      print = .false.
      move = .false.
      if (mode.eq.1 .or. mode.eq.3)  print = .true.
      if (mode.eq.2 .or. mode.eq.3)  move = .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 inertial 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,3,tensor,moment,vec,work1,work2)
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     print the moments of inertia and the principal axes
c
      if (print) then
         write (iout,20)
   20    format (/,' Moments of Inertia and Principal Axes :',
     &           //,9x,'Moments',14x,'X-, Y- and Z-Components of Axis')
         write (iout,30)  (moment(i),vec(1,i),vec(2,i),vec(3,i),i=1,3)
   30    format (3(/,f16.4,9x,3f12.6))
      end if
c
c     principal moment axes form rows of Euler rotation matrix
c
      if (move) 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
      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
c     and variables that might not otherwise get initialized
c
c
      subroutine initial
      implicit none
      include 'sizes.i'
      include 'align.i'
      include 'argue.i'
      include 'atoms.i'
      include 'bath.i'
      include 'bound.i'
      include 'cell.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'linmin.i'
      include 'minima.i'
      include 'molcul.i'
      include 'mutant.i'
      include 'output.i'
      include 'pdb.i'
      include 'precis.i'
      include 'scales.i'
      include 'sequen.i'
      include 'warp.i'
      include 'zclose.i'
      real*8 precise
c
c
c     number of atoms used in superposition
c
      nfit = 0
c
c     names of biopolymer residue types
c
      call initres
c
c     number of command line arguments
c
      narg = 0
c
c     number of atoms in the system
c
      n = 0
c
c     flags for temperature and pressure baths
c
      isothermal = .false.
      isobaric = .false.
c
c     flags for periodic boundaries
c
      use_bounds = .false.
      use_image = .false.
      use_replica = .false.
c
c     number of unit cell replicates
c
      ncell = 0
c
c     highest numbered previous cycle file
c
      nprior = 0
c
c     information levels within the program
c
      verbose = .false.
      debug = .false.
      abort = .false.
c
c     default input/output unit numbers
c
      input = 5
      iout = 6
c
c     number of lines in the keyfile
c
      nkey = 0
c
c     type of coordinates file
c
      coordtype = 'none'
c
c     number of molecules in the system
c
      nmol = 0
c
c     number of hybrid (mutant) atoms in the system
c
      nhybrid = 0
c
c     number of atoms in Protein Data Bank ATOM records
c
      npdb = 0
c
c     generic parameters used by all optimizations
c
      fctmin = 0.0d0
      maxiter = 0
      nextiter = 0
      iprint = -1
      iwrite = -1
c
c     generic parameters used during line search
c
      cappa = 0.0d0
      stpmin = 0.0d0
      stpmax = 0.0d0
      angmax = 0.0d0
      intmax = 0
c
c     flag to show setting of optimization scale factors
c
      set_scale = .false.
c
c     number of residues and chains in biopolymer sequence
c
      nseq = 0
      nchain = 0
c
c     flag for Gaussian density annealing algorithm
c
      use_gda = .false.
c
c     number of bonds added or deleted from Z-matrix
c
      nadd = 0
      ndel = 0
c
c     display program info and copyright notice
c
      call promo
c
c     determine a set of machine precision values
c
      tiny = precise (1)
      small = precise (2)
      huge = precise (3)
c
c     get any command line arguments to the program
c
      call command
      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
      implicit none
      include 'sizes.i'
      include 'angpot.i'
      include 'bndpot.i'
      include 'chgpot.i'
      include 'fields.i'
      include 'kanang.i'
      include 'kangs.i'
      include 'katoms.i'
      include 'kbonds.i'
      include 'kchrge.i'
      include 'kdipol.i'
      include 'khbond.i'
      include 'kiprop.i'
      include 'kitors.i'
      include 'kmulti.i'
      include 'kopbnd.i'
      include 'kopdst.i'
      include 'korbs.i'
      include 'kpolr.i'
      include 'kstbnd.i'
      include 'ksttor.i'
      include 'ktorsn.i'
      include 'kurybr.i'
      include 'kvdws.i'
      include 'kvdwpr.i'
      include 'math.i'
      include 'mplpot.i'
      include 'polpot.i'
      include 'rxnpot.i'
      include 'urypot.i'
      include 'torpot.i'
      include 'vdwpot.i'
      integer i,j
c
c
c     initialize strings of parameter atom types and classes
c
      do i = 1, maxnvp
         kvpr(i) = '      '
      end do
      do i = 1, maxnhb
         khb(i) = '      '
      end do
      do i = 1, maxnb
         kb(i) = '      '
      end do
      do i = 1, maxnb5
         kb5(i) = '      '
      end do
      do i = 1, maxnb4
         kb4(i) = '      '
      end do
      do i = 1, maxnb3
         kb3(i) = '      '
      end do
      do i = 1, maxnel
         kel(i) = '         '
      end do
      do i = 1, maxna
         ka(i) = '         '
      end do
      do i = 1, maxna5
         ka5(i) = '         '
      end do
      do i = 1, maxna4
         ka4(i) = '         '
      end do
      do i = 1, maxna3
         ka3(i) = '         '
      end do
      do i = 1, maxnaf
         kaf(i) = '         '
      end do
      do i = 1, maxnu
         ku(i) = '         '
      end do
      do i = 1, maxnopb
         kaopb(i) = '      '
      end do
      do i = 1, maxnopd
         kaopd(i) = '            '
      end do
      do i = 1, maxndi
         kdi(i) = '            '
      end do
      do i = 1, maxnti
         kti(i) = '            '
      end do
      do i = 1, maxnt
         kt(i) = '            '
      end do
      do i = 1, maxnt5
         kt5(i) = '            '
      end do
      do i = 1, maxnt4
         kt4(i) = '            '
      end do
      do i = 1, maxnbt
         kbt(i) = '      '
      end do
      do i = 1, maxnd
         kd(i) = '      '
      end do
      do i = 1, maxnd5
         kd5(i) = '      '
      end do
      do i = 1, maxnd4
         kd4(i) = '      '
      end do
      do i = 1, maxnd3
         kd3(i) = '      '
      end do
      do i = 1, maxnmp
         kmp(i) = '         '
      end do
      do i = 1, maxnpi
         kpi(i) = '      '
      end do
c
c     initialize some of the force field parameters
c
      forcefield = '                    '
      do i = 1, maxtyp
         symbol(i) = '   '
         atmcls(i) = 0
         atmnum(i) = 0
         weight(i) = 0.0d0
         ligand(i) = 0
         describe(i) = '                    '
         chg(i) = 0.0d0
         polr(i) = 0.0d0
         do j = 1, maxval
            pgrp(j,i) = 0
         end do
      end do
      do i = 1, maxclass
         rad(i) = 0.0d0
         eps(i) = 0.0d0
         rad4(i) = 0.0d0
         eps4(i) = 0.0d0
         reduct(i) = 0.0d0
         do j = 1, 3
            stbn(j,i) = 0.0d0
            anan(j,i) = 0.0d0
         end do
         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
      mm2stbn = .false.
      ureyunit = 1.0d0
      cury = 0.0d0
      qury = 0.0d0
      aaunit = 1.0d0 / radian**2
      opbunit = 1.0d0 / radian**2
      opdunit = 1.0d0
      idihunit = 1.0d0
      itorunit = 1.0d0
      torsunit = 1.0d0
      storunit = 1.0d0
c
c     set default control parameters for van der Waals terms
c
      vdwtyp = 'LENNARD-JONES'
      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
      radrule = 'ARITHMETIC'
      radtyp = 'R-MIN'
      radsiz = 'RADIUS'
      epsrule = 'GEOMETRIC'
      gausstyp = 'NONE'
      ngauss = 0
c
c     set default control parameters for charge-charge terms
c
      dielec = 1.0d0
      c2scale = 0.0d0
      c3scale = 0.0d0
      c4scale = 1.0d0
      c5scale = 1.0d0
      neutnbr = .false.
      neutcut = .false.
c
c     set default control parameters for atomic multipole terms
c
      m2scale = 0.0d0
      m3scale = 0.0d0
      m4scale = 1.0d0
      m5scale = 1.0d0
c
c     set default control parameters for polarization terms
c
      poltyp = 'MUTUAL'
      poleps = 0.000001d0
      polsor = 0.7d0
      pgamma = 1.0d0
      p2scale = 0.0d0
      p3scale = 0.0d0
      p4scale = 1.0d0
      p5scale = 1.0d0
      d1scale = 0.0d0
      d2scale = 0.0d0
      d3scale = 0.0d0
      d4scale = 1.0d0
      u1scale = 1.0d0
      u2scale = 1.0d0
      u3scale = 1.0d0
      u4scale = 1.0d0
c
c     set default control parameters for reaction field terms
c
      rfsize = 1000000.0d0
      rfbulkd = 80.0d0
      rfterms = 1
      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 names for biopolymer residue types used in
c     PDB file conversion and automated generation of structures
c
c
      subroutine initres
      implicit none
      include 'sizes.i'
      include 'resdue.i'
      integer i
      character*1 acid1(maxamino)
      character*1 base1(maxnuc)
      character*3 acid3(maxamino)
      character*3 base3(maxnuc)
      data acid1  / 'G','A','V','L','I','S','T','C','C','P','F','Y',
     &              'W','H','U','Z','D','N','E','Q','M','K','R','O',
     &              'B','J','f','a','n','m','X' /
      data acid3  / 'GLY','ALA','VAL','LEU','ILE','SER','THR','CYS',
     &              'CYX','PRO','PHE','TYR','TRP','HIS','HID','HIE',
     &              'ASP','ASN','GLU','GLN','MET','LYS','ARG','ORN',
     &              'AIB','PCA','FOR','ACE','NH2','NME','UNK' /
      data base1  / 'A','G','C','U','D','B','I','T','1','2','3','X' /
      data base3  / 'ADE','GUA','CYT','URA','DAD','DGU','DCY','THY',
     &              'MPO','DPO','TPO','UNK' /
c
c
c     set values for the 1- and 3-letter amino acid names
c
      do i = 1, maxamino
         amino(i) = acid3(i)
         amino1(i) = acid1(i)
      end do
c
c     set values for the 1- and 3-letter nucleic acid names
c
      do i = 1, maxnuc
         nuclz(i) = base3(i)
         nuclz1(i) = base1(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" asks for torsional angles which are to be rotated
c     in subsequent computation, it will automatically locate all
c     rotatable single bonds if desired; assumes that an appropriate
c     internal coordinates file has already been read in
c
c
      subroutine initrot
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kgeoms.i'
      include 'math.i'
      include 'omega.i'
      include 'ring.i'
      include 'rotate.i'
      include 'usage.i'
      include 'zcoord.i'
      integer i,j,k
      integer j1,j2,mode
      integer bond1,bond2
      integer attach1,attach2
      integer nlist,nfixed
      integer list(maxatm)
      integer ifixed(2,maxbnd)
      logical exist,query
      logical rotate,rotcheck
      character*80 record
      character*80 string
c
c
c     initialize the number of rotatable torsional angles
c
      nomega = 0
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     manual selection of the torsional angles to be rotated
c
      if (mode .eq. 1) then
         dowhile (nomega .lt. maxrot)
            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 (a80)
            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     manual selection of the torsional angles to be frozen
c
      nfixed = 0
      if (mode .eq. 2) then
         do i = 1, maxrot
            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 (a80)
            read (record,*,err=110,end=110)  ifixed(1,i),ifixed(2,i)
            if (ifixed(1,i).eq.0 .and. 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 if both atoms of bond are in a small ring
c
               do j = 1, n
                  list(j) = 0
               end do
               do j = 1, nring3
                  do k = 1, 3
                     list(iring3(k,j)) = j
                  end do
                  if (list(bond1).eq.j .and. list(bond2).eq.j) then
                     rotate = .false.
                     goto 120
                  end if
               end do
               do j = 1, n
                  list(j) = 0
               end do
               do j = 1, nring4
                  do k = 1, 4
                     list(iring4(k,j)) = j
                  end do
                  if (list(bond1).eq.j .and. list(bond2).eq.j) then
                     rotate = .false.
                     goto 120
                  end if
               end do
               do j = 1, n
                  list(j) = 0
               end do
               do j = 1, nring5
                  do k = 1, 5
                     list(iring5(k,j)) = j
                  end do
                  if (list(bond1).eq.j .and. list(bond2).eq.j) then
                     rotate = .false.
                     goto 120
                  end if
               end do
               do j = 1, n
                  list(j) = 0
               end do
               do j = 1, nring6
                  do k = 1, 6
                     list(iring6(k,j)) = j
                  end do
                  if (list(bond1).eq.j .and. list(bond2).eq.j) then
                     rotate = .false.
                     goto 120
                  end if
               end do
  120          continue
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 130
                     end if
                  end do
               end if
  130          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,140)  bond1,bond2
  140                   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     make inactive the atoms not rotatable via any torsion
c
      if (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,150)
  150       format (/,' List of Active Atoms for Torsional',
     &                    ' Calculations :',/)
            write (iout,160)  (list(i),i=1,nlist)
  160       format (3x,10i7)
         end if
      end if
c
c     write out the number of rotatable torsions to be used
c
      if (nomega .eq. 0) then
         write (iout,170)
  170    format (/,' INITROT  --  No Torsions for Subsequent',
     &              ' Computation')
         call fatal
      else if (nomega .gt. maxrot) then
         write (iout,180)
  180    format (/,' INITROT  --  Too many Torsions;',
     &              ' Increase MAXROT')
         call fatal
      end if
      write (iout,190)  nomega
  190 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'rotate.i'
      include 'usage.i'
      integer i,base,partner
      logical rotcheck,value
      logical list(maxatm)
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
         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
      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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      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
      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 :',i8)
      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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'iounit.i'
      include 'katoms.i'
      include 'zcoord.i'
      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*60 coordfile
      character*80 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 (a80)
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 ()
            coordfile = filename(1:leng)//'.int'
            call version (coordfile,'new')
            open (unit=izmt,file=coordfile,status='new')
            call prtint (izmt)
            close (unit=izmt)
            write (iout,50)  coordfile(1:trimtext(coordfile))
   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,250)
  250       format (/,' Invalid Atom Number')
            error = .true.
         else
            if (j .ne. iz(1,i)) then
               value = geometry (i,j,0,0)
               write (iout,220)  value
  220          format (/,' The Current Distance is : ',f9.4)
               write (iout,230)
  230          format (' That Bond is not in the Z-matrix')
            else
               write (iout,240)  zbond(i)
  240          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
      implicit none
      include 'iounit.i'
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)
      implicit none
      include 'iounit.i'
      integer length
      integer trimtext
      real*8 x,xnew
      logical changed
      character*80 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 (a80)
      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)  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
      implicit none
      include 'files.i'
      include 'iounit.i'
      include 'titles.i'
      integer ixyz,freeunit
      character*60 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)  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     logical dimension of the matrix to be inverted
c     np    physical dimension of the matrix storage area
c     a     matrix to invert; contains inverse on exit
c
c
      subroutine invert (n,np,a)
      implicit none
      include 'iounit.i'
      integer maxinv
      parameter (maxinv=100)
      integer i,j,k,n,np
      integer icol,irow
      integer ipivot(maxinv)
      integer indxc(maxinv)
      integer indxr(maxinv)
      real*8 big,temp,pivot
      real*8 a(np,np)
c
c
c     check to see if the matrix is too large to handle
c
      if (n .gt. maxinv) then
         write (iout,10)
   10    format (/,' INVERT  --  Matrix Too Large; Increase MAXINV')
         call fatal
      end if
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,20)
   20                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,30)
   30       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
      return
      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     logical dimension of the matrix to be diagonalized
c     np    physical dimension of the matrix storage area
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,np,a,d,v,b,z)
      implicit none
      include 'iounit.i'
      integer i,j,k
      integer n,np,ip,iq
      integer nrot,maxrot
      real*8 sm,tresh,s,c,t
      real*8 theta,tau,h,g,p
      real*8 d(np),b(np),z(np)
      real*8 a(np,np),v(np,np)
c
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     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)  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
      implicit none
      include 'sizes.i'
      include 'angang.i'
      include 'angle.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      include 'kanang.i'
      include 'keys.i'
      include 'potent.i'
      integer i,j,k,m,next
      integer it,ia,ic
      integer nang,jang,kang
      real*8 fa,faa,aak(3)
      logical header
      character*20 keyword
      character*80 record
      character*80 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:80)
            read (string,*,err=10,end=10)  it,(aak(j),j=1,3)
   10       continue
            if (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Additional Angle-Angle Parameters :',
     &                 //,5x,'Atom Class',8x,'K(AA) 1',4x,'K(AA) 2',
     &                    4x,'K(AA) 3',/)
            end if
            write (iout,30)  it,(aak(j),j=1,3)
   30       format (9x,i3,7x,3f11.3)
            do j = 1, 3
               anan(j,it) = aak(j)
            end do
         end if
      end do
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)
         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 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
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kangs.i'
      include 'keys.i'
      include 'potent.i'
      include 'ring.i'
      integer i,j,k
      integer ia,ib,ic,id
      integer ita,itb,itc
      integer na,na5,na4
      integer na3,naf
      integer jen,ih,nh
      integer next,size
      integer minat,iring
      real*8 fc,an,pr
      real*8 an1,an2,an3
      logical header,done
      logical use_ring3
      logical use_ring4
      logical use_ring5
      character*3 pa,pb,pc
      character*6 label
      character*9 blank,pt
      character*20 keyword
      character*80 record
      character*80 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:80)
            read (string,*,err=10,end=10)  ia,ib,ic,fc,an1,an2,an3
   10       continue
            if (an2.ne.0.0d0 .or. an3.ne.0.0d0)  jen = 1
            if (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Additional Angle Bending Parameters :',
     &                 //,5x,'Atom Classes',9x,'K(B)',7x,'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,2x,2f12.3)
               else if (an1 .ne. 0.0d0) then
                  write (iout,40)  ia,ib,ic,fc,an1
   40             format (4x,3i4,2x,2f12.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,2x,2f12.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,2x,2f12.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,2x,2f12.3,3x,a6)
               else if (an1 .ne. 0.0d0) then
                  write (iout,80)  ia,ib,ic,fc,an1,label
   80             format (4x,3i4,2x,2f12.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,2x,2f12.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,2x,2f12.3,3x,a6,3x,'2-H''s')
               end if
            end if
            size = 3
            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 150
                  end if
               end do
               write (iout,110)
  110          format (/,' KANGLE  --  Too many Bond Angle',
     &                       ' Bending Parameters')
               abort = .true.
            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 150
                  end if
               end do
               write (iout,120)
  120          format (/,' KANGLE  --  Too many 5-Ring Angle',
     &                       ' Bending Parameters')
               abort = .true.
            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 150
                  end if
               end do
               write (iout,130)
  130          format (/,' KANGLE  --  Too many 4-Ring Angle',
     &                       ' Bending Parameters')
               abort = .true.
            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 150
                  end if
               end do
               write (iout,140)
  140          format (/,' KANGLE  --  Too many 3-Ring Angle',
     &                       ' Bending Parameters')
               abort = .true.
            end if
  150       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)
         iring = -1
         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:80)
            read (string,*,err=160,end=160)  ia,ib,ic,fc,an,pr
  160       continue
            if (header) then
               header = .false.
               write (iout,170)
  170          format (/,' Additional Fourier Angle Bending',
     &                    ' Parameters :',
     &                 //,5x,'Atom Classes',9x,'K(B)',7x,'Shift',
     &                    6x,'Period',/)
            end if
            write (iout,180)  ia,ib,ic,fc,an,pr
  180       format (4x,3i4,2x,3f12.3)
            size = 3
            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 200
               end if
            end do
            write (iout,190)
  190       format (/,' KANGLE  --  Too many Fourier Angle',
     &                    ' Bending Parameters')
            abort = .true.
  200       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      na = maxna
      na5 = maxna5
      na4 = maxna4
      na3 = maxna3
      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 = maxnaf, 1, -1
         if (kaf(i) .eq. blank)  naf = i - 1
      end do
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
c
c     use small rings if present and parameters are available
c
      use_ring5 = .true.
      use_ring4 = .true.
      use_ring3 = .true.
      if (nring5.eq.0 .or. na5.eq.0)  use_ring5 = .false.
      if (nring4.eq.0 .or. na4.eq.0)  use_ring4 = .false.
      if (nring3.eq.0 .or. na3.eq.0)  use_ring3 = .false.
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 = 3
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pt = pa//pb//pc
         else
            pt = pc//pb//pa
         end if
         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
         nh = 1
         do j = 1, n12(ib)
            ih = i12(j,ib)
            if (ih.ne.ia .and. ih.ne.ic .and. atomic(ih).eq.1)
     &         nh = nh + 1
         end do
c
c     make a check for bond angles inside small rings
c
         iring = 0
         if (n12(ia).eq.1 .or. n12(ic).eq.1)  goto 210
         if (use_ring3) then
            do j = 1, n12(ia)
               if (ic .eq. i12(j,ia)) then
                  iring = 3
                  goto 210
               end if
            end do
         end if
         if (use_ring4) then
            do j = 1, n12(ia)
               id = i12(j,ia)
               if (ib .ne. id) then
                  do k = 1, n12(ic)
                     if (id .eq. i12(k,ic)) then
                        iring = 4
                        goto 210
                     end if
                  end do
               end if
            end do
         end if
         if (use_ring5) then
            do j = 1, n12(ia)
               id = i12(j,ia)
               if (ib .ne. id) then
                  do k = 1, n13(ic)
                     if (id .eq. i13(k,ic)) then
                        iring = 5
                        goto 210
                     end if
                  end do
               end if
            end do
         end if
  210    continue
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(nh,j).ne.0.0d0) then
                  ak(i) = acon(j)
                  anat(i) = ang(nh,j)
                  done = .true.
                  goto 220
               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(nh,j).ne.0.0d0) then
                  ak(i) = acon5(j)
                  anat(i) = ang5(nh,j)
                  done = .true.
                  goto 220
               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(nh,j).ne.0.0d0) then
                  ak(i) = acon4(j)
                  anat(i) = ang4(nh,j)
                  done = .true.
                  goto 220
               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(nh,j).ne.0.0d0) then
                  ak(i) = acon3(j)
                  anat(i) = ang3(nh,j)
                  done = .true.
                  goto 220
               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 220
               end if
            end do
         end if
c
c     warning if suitable angle bending parameter not found
c
  220    continue
         minat = min(atomic(ia),atomic(ib),atomic(ic))
         if (minat .eq. 0)  done = .true.
         if (.not. done) then
            abort = .true.
            if (header) then
               header = .false.
               write (iout,230)
  230          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,240)  label,ia,name(ia),ib,name(ib),
     &                        ic,name(ic),ita,itb,itc
  240       format (1x,a6,5x,3(i6,'-',a3),7x,3i5)
         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     ##  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
      subroutine katom
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'katoms.i'
      include 'keys.i'
      integer i,k,next
      integer cls,atn,lig
      real*8 wght
      logical header
      character*3 symb
      character*20 keyword
      character*20 notice
      character*80 record
      character*80 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)
            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:80)
            read (string,*,err=50,end=50)  atn,wght,lig
            if (k.ge.1 .and. k.le.maxtyp) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Atom Type Parameters :',
     &                    //,4x,'Type  Class  Symbol',4x,'Description',
     &                       12x,'Atomic #',4x,'Mass',3x,'Valence',/)
               end if
               symbol(k) = symb
               describe(k) = notice
               atmnum(k) = atn
               weight(k) = wght
               ligand(k) = lig
               write (iout,30)  k,cls,symb,notice,atn,wght,lig
   30          format (2i7,5x,a3,5x,a20,i8,f12.3,i6)
            else if (k .ge. maxtyp) then
               write (iout,40)
   40          format (/,' KATOM   --  Too many Atom Types;',
     &                    ' Increase MAXTYP')
               abort = .true.
            end if
   50       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
            valence(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)
            valence(i) = ligand(k)
            story(i) = describe(k)
         end if
      end do
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)
            call getnumb (record,cls,next)
            call gettext (record,symb,next)
            call getstring (record,notice,next)
            string = record(next:80)
            read (string,*,err=90,end=90)  atn,wght,lig
            if (k.lt.0 .and. k.ge.-n) then
               if (header) then
                  header = .false.
                  write (iout,70)
   70             format (/,' Additional Atom Types for',
     &                       ' Specific Atoms :',
     &                    //,4x,'Type  Class  Symbol',4x,'Description',
     &                       12x,'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
               valence(k) = lig
               write (iout,80)  k,cls,symb,notice,atn,wght,lig
   80          format (2i7,5x,a3,5x,a20,i8,f12.3,i6)
            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',12x,i5,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. valence(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),valence(i),n12(i)
  130       format (' Valence',7x,i5,'-',a3,8x,i5,10x,i5,5x,i5)
         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 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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kbonds.i'
      include 'keys.i'
      include 'potent.i'
      include 'ring.i'
      integer i,j,k,m
      integer ia,ib,ic,id
      integer ita,itb
      integer nb,nb5,nb4,nb3
      integer size,next
      integer minat,iring
      real*8 fc,bd
      logical header,done
      logical use_ring3
      logical use_ring4
      logical use_ring5
      character*3 pa,pb
      character*6 blank,label,pt
      character*20 keyword
      character*80 record
      character*80 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:80)
            read (string,*,err=10,end=10)  ia,ib,fc,bd
   10       continue
            if (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Additional Bond Stretching Parameters :',
     &                 //,5x,'Atom Classes',9x,'K(S)',6x,'Length',/)
            end if
            if (iring .eq. 0) then
               write (iout,30)  ia,ib,fc,bd
   30          format (6x,2i4,4x,f12.3,f12.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,4x,f12.3,f12.4,3x,a6)
            end if
            size = 3
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            if (iring .eq. 0) then
               do j = 1, maxnb
                  if (kb(j).eq.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
         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
c
c     use small rings if present and parameters are available
c
      use_ring5 = .true.
      use_ring4 = .true.
      use_ring3 = .true.
      if (nring5.eq.0 .or. nb5.eq.0)  use_ring5 = .false.
      if (nring4.eq.0 .or. nb4.eq.0)  use_ring4 = .false.
      if (nring3.eq.0 .or. nb3.eq.0)  use_ring3 = .false.
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 = 3
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pt = pa//pb
         else
            pt = pb//pa
         end if
         bk(i) = 0.0d0
         bl(i) = 0.0d0
         done = .false.
c
c     make a check for bonds inside small rings
c
         iring = 0
         if (n12(ia).eq.1 .or. n12(ib).eq.1)  goto 130
         if (use_ring3) then
            do j = 1, n12(ia)
               ic = i12(j,ia)
               do k = 1, n12(ib)
                  if (ic .eq. i12(k,ib)) then
                     iring = 3
                     goto 130
                  end if
               end do
            end do
         end if
         if (use_ring4) then
            do j = 1, n12(ia)
               ic = i12(j,ia)
               if (ic .ne. ib) then
                  do k = 1, n12(ib)
                     id = i12(k,ib)
                     if (id .ne. ia) then
                        do m = 1, n12(ic)
                           if (id .eq. i12(m,ic)) then
                              iring = 4
                              goto 130
                           end if
                        end do
                     end if
                  end do
               end if
            end do
         end if
         if (use_ring5) then
            do j = 1, n13(ia)
               ic = i13(j,ia)
               do k = 1, n13(ib)
                  if (ic .eq. i13(k,ib)) then
                     iring = 5
                     goto 130
                  end if
               end do
            end do
         end if
  130    continue
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 (.not. done) then
            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     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
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'bond.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kbonds.i'
      include 'keys.i'
      include 'tors.i'
      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*3 pa,pb,pc,pd
      character*9 blank
      character*9 pt,pt1,pt2
      character*20 keyword
      character*80 record
      character*80 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:80)
            read (string,*,err=10,end=10)  ia,ib,ic,dl
   10       continue
            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)
            size = 3
            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 = 3
            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 = 3
            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     ##  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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'charge.i'
      include 'chgpot.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kchrge.i'
      include 'keys.i'
      include 'potent.i'
      integer i,j,k,m
      integer ia,next
      integer nc12(maxatm)
      real*8 cg
      logical header
      character*20 keyword
      character*80 record
      character*80 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:80)
            read (string,*,err=40,end=40)  ia,cg
            if (ia .gt. 0) then
               if (header) then
                  header = .false.
                  write (iout,10)
   10             format (/,' Additional Atomic Partial Charge',
     &                       ' Parameters :',
     &                    //,6x,'Atom Type',9x,'Charge',/)
               end if
               if (ia .le. maxtyp) then
                  chg(ia) = cg
                  write (iout,20)  ia,cg
   20             format (6x,i6,6x,f12.3)
               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     find and store all the atomic partial charges
c
      do i = 1, n
         pchg(i) = chg(type(i))
      end do
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:80)
            read (string,*,err=70,end=70)  ia,cg
            if (ia.lt.0 .and. ia.ge.-n) then
               ia = -ia
               if (header) then
                  header = .false.
                  write (iout,50)
   50             format (/,' Additional Partial Charges for',
     &                       ' Specific Atoms :',
     &                    //,8x,'Atom',12x,'Charge',/)
               end if
               write (iout,60)  ia,cg
   60          format (6x,i6,6x,f12.3)
               pchg(ia) = cg
            end if
   70       continue
         end if
      end do
c
c     remove zero partial charges from the list of charges
c
      nion = 0
      do i = 1, n
         chglist(i) = 0
         if (pchg(i) .ne. 0.0d0) then
            nion = nion + 1
            iion(nion) = i
            jion(nion) = i
            kion(nion) = i
            pchg(nion) = pchg(i)
            chglist(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, nion
            nc12(i) = 0
            k = iion(i)
            do j = 1, n12(k)
               m = chglist(i12(j,k))
               if (m .ne. 0)  nc12(i) = nc12(i) + 1
            end do
         end do
         do i = 1, nion
            if (nc12(i) .eq. 1) then
               k = iion(i)
               do j = 1, n12(k)
                  m = chglist(i12(j,k))
                  if (m .ne. 0) then
                     if (nc12(m) .gt. 1) then
                        if (neutnbr)  jion(i) = iion(m)
                        if (neutcut)  kion(i) = iion(m)
                     end if
                  end if
               end do
            end if
         end do
      end if
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     ##  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
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'dipole.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kdipol.i'
      include 'keys.i'
      include 'potent.i'
      include 'ring.i'
      integer i,j,k,m
      integer ia,ib,ic,id
      integer ita,itb
      integer nd,nd5,nd4,nd3
      integer iring,size,next
      real*8 dp,ps
      logical header
      logical use_ring3
      logical use_ring4
      logical use_ring5
      character*3 pa,pb
      character*6 blank
      character*6 label,pt
      character*20 keyword
      character*80 record
      character*80 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:80)
            read (string,*,err=10,end=10)  ia,ib,dp,ps
   10       continue
            if (ia.gt.0 .and. ib.gt.0) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Bond Dipole Moment ',
     &                       'Parameters :',
     &                    //,6x,'Atom Types',8x,'Moment',
     &                       6x,'Position',/)
               end if
               if (iring .eq. 0) then
                  write (iout,30)  ia,ib,dp,ps
   30             format (6x,2i4,4x,2f12.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,4x,2f12.3,3x,a6)
               end if
               size = 3
               call numeral (ia,pa,size)
               call numeral (ib,pb,size)
               if (ia .le. ib) then
                  pt = pa//pb
               else
                  pt = pb//pa
               end if
               if (iring .eq. 0) then
                  do j = 1, 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
c
c     use small rings if present and parameters are available
c
      use_ring5 = .true.
      use_ring4 = .true.
      use_ring3 = .true.
      if (nring5.eq.0 .or. nd5.eq.0)  use_ring5 = .false.
      if (nring4.eq.0 .or. nd4.eq.0)  use_ring4 = .false.
      if (nring3.eq.0 .or. nd3.eq.0)  use_ring3 = .false.
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 = 3
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pt = pa//pb
         else
            pt = pb//pa
         end if
         bdpl(i) = 0.0d0
c
c     make a check for bonds inside small rings
c
         iring = 0
         if (n12(ia).eq.1 .or. n12(ib).eq.1)  goto 100
         if (use_ring3) then
            do j = 1, n12(ia)
               ic = i12(j,ia)
               do k = 1, n12(ib)
                  if (ic .eq. i12(k,ib)) then
                     iring = 3
                     goto 100
                  end if
               end do
            end do
         end if
         if (use_ring4) then
            do j = 1, n12(ia)
               ic = i12(j,ia)
               if (ic .ne. ib) then
                  do k = 1, n12(ib)
                     id = i12(k,ib)
                     if (id .ne. ia) then
                        do m = 1, n12(ic)
                           if (id .eq. i12(m,ic)) then
                              iring = 4
                              goto 100
                           end if
                        end do
                     end if
                  end do
               end if
            end do
         end if
         if (use_ring5) then
            do j = 1, n13(ia)
               ic = i13(j,ia)
               do k = 1, n13(ib)
                  if (ic .eq. i13(k,ib)) then
                     iring = 5
                     goto 100
                  end if
               end do
            end do
         end if
  100    continue
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 110
               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 110
               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 110
               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 110
               end if
            end do
         end if
  110    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:80)
            read (string,*,err=120,end=120)  ia,ib,dp,ps
  120       continue
            if (ia.lt.0 .and. ib.lt.0) then
               ia = -ia
               ib = -ib
               if (header) then
                  header = .false.
                  write (iout,130)
  130             format (/,' Additional Bond Dipoles for',
     &                       ' Specific Bonds :',
     &                    //,5x,'Bonded Atoms',7x,'Moment',
     &                          6x,'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
                     write (iout,140)  ia,ib,dp,ps
  140                format (4x,i5,' -',i5,2x,2f12.3)
                     goto 150
                  end if
               end do
            end if
  150       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)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine kewald  --  PM Ewald parameter assignment  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "kewald" assigns both regular Ewald summation and particle
c     mesh Ewald parameters for a periodic box
c
c
      subroutine kewald
      implicit none
      include 'sizes.i'
      include 'boxes.i'
      include 'cutoff.i'
      include 'ewald.i'
      include 'ewreg.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'pme.i'
      include 'potent.i'
      integer maxpower
      parameter (maxpower=50)
      integer i,k
      integer next,ntable
      integer ifft1,ifft2,ifft3
      integer jmax,kmax,lmax
      integer multi(maxpower)
      real*8 delta,eps
      logical use_pme
      character*20 keyword
      character*80 record
      character*80 string
      data multi  /   2,   3,   4,   5,   6,   8,   9,  10,  12,  15,
     &               16,  18,  20,  24,  25,  27,  30,  32,  36,  40,
     &               45,  48,  50,  54,  60,  64,  72,  75,  80,  81,
     &               90,  96, 100, 108, 120, 125, 128, 135, 144, 150,
     &              160, 162, 180, 192, 200, 216, 225, 240, 243, 250 /
c
c
c     decide between regular Ewald and particle mesh Ewald
c
      use_pme = .false.
      if (use_charge)  use_pme = .true.
c
c     set defaults for reciprocal fraction and boundary treatment
c
      frecip = 0.5d0
      tinfoil = .true.
c
c     estimate an optimal value for the Ewald coefficient
c
      eps = 1.0d-8
      call ewaldcof (aewald,ewaldcut,eps)
c
c     set defaults for PME B-spline order and charge grid size;
c     grid is a product of powers of 2, 3 and/or 5 for efficiency
c
      if (use_pme) then
         bsorder = 8
         delta = 1.0d-8
         nfft1 = 0
         nfft2 = 0
         nfft3 = 0
         ifft1 = int(1.5d0*xbox-delta) + 1
         ifft2 = int(1.5d0*ybox-delta) + 1
         ifft3 = int(1.5d0*zbox-delta) + 1
         do i = maxpower, 1, -1
            k = multi(i)
            if (k .le. maxfft) then
               if (k.ge.ifft1 .or. nfft1.eq.0)  nfft1 = k
               if (k.ge.ifft2 .or. nfft2.eq.0)  nfft2 = k
               if (k.ge.ifft3 .or. nfft3.eq.0)  nfft3 = k
            end if
         end do
      end if
c
c     search keywords for Ewald summation commands
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:80)
         if (keyword(1:12) .eq. 'EWALD-ALPHA ') then
            read (string,*,err=20)  aewald
         else if (keyword(1:15) .eq. 'EWALD-FRACTION ') then
            read (string,*,err=20)  frecip
         else if (keyword(1:15) .eq. 'EWALD-BOUNDARY ') then
            tinfoil = .false.
         else if (keyword(1:9) .eq. 'PME-GRID ') then
            nfft1 = 0
            nfft2 = 0
            nfft3 = 0
            read (string,*,err=10,end=10)  nfft1,nfft2,nfft3
   10       continue
            if (nfft2 .eq. 0)  nfft2 = nfft1
            if (nfft3 .eq. 0)  nfft3 = nfft1
         else if (keyword(1:10) .eq. 'PME-ORDER ') then
            read (string,*,err=20)  bsorder
         end if
   20    continue
      end do
c
c     check the B-spline order and charge grid dimension for PME
c
      if (use_pme) then
         if (bsorder .gt. maxorder) then
            write (iout,30)
   30       format (/,' KEWALD  --  B-Spline Order Too Large;',
     &                 ' Increase MAXORDER')
            call fatal
         end if
         if (max(nfft1,nfft2,nfft3) .gt. maxfft) then 
            write (iout,40)
   40       format (/,' KEWALD  --  FFT Charge Grid Too Large;',
     &                 ' Increase MAXFFT')
            call fatal
         else if (nfft1.lt.ifft1 .or. nfft2.lt.ifft2
     &                .or. nfft3.lt.ifft3) then 
            write (iout,50)
   50       format (/,' KEWALD  --  Warning, Small Charge Grid',
     &                 ' may give Poor Energy')
         end if
c
c     check the number of k-vectors for regular Ewald summation
c
      else
         jmax = int(frecip/recip(1,1))
         kmax = int(frecip/recip(2,2))
         lmax = int(frecip/recip(3,3))
         if (max(jmax,kmax,lmax) .gt. maxvec) then
            jmax = min(maxvec,jmax)
            kmax = min(maxvec,kmax)
            lmax = min(maxvec,lmax)
            write (iout,60)
   60       format (/,' KEWALD  --  Too many Reciprocal Space',
     &                 ' K-Vectors; Increase MAXVEC')
         end if
      end if
c
c     initialize the PME arrays that can be precomputed
c
      if (use_pme) then
         ntable = maxtable
         call moduli
         call fftsetup (nfft1,nfft2,nfft3,ntable,table)
      end if
c
c     print a message listing some of the Ewald parameters
c
      if (verbose) then
         if (use_pme) then
            write (iout,70)  aewald,nfft1,nfft2,nfft3,bsorder
   70       format (/,' Smooth Particle Mesh Ewald Parameters :',
     &              //,4x,'Ewald Coefficient',6x,'Charge Grid',
     &                 ' Dimensions',6x,'B-Spline Order',
     &              //,8x,f8.4,11x,3i6,12x,i6)
         else
            write (iout,80)  aewald,jmax,kmax,lmax,frecip
   80       format (/,' Regular Ewald Summation Parameters :',
     &              //,4x,'Ewald Coefficient',6x,'K-Vector',
     &                 ' Dimensions',5x,'Reciprocal Fraction',
     &              //,8x,f8.4,11x,3i5,14x,f8.4)
         end if
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ewaldcof  --  estimation of Ewald coefficient  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ewaldcof" finds a value of the Ewald coefficient such that
c     all terms beyond the specified cutoff distance will have an
c     value less than a specified tolerance
c
c
      subroutine ewaldcof (alpha,cutoff,eps)
      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     get approximate value from cutoff and tolerance
c
      ratio = eps + 1.0d0
      x = 0.5d0
      i = 0
      dowhile (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 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; bsmod[1-3] hold these values,
c     nfft[1-3] are the grid dimensions, bsorder is the order of
c     B-spline approximation
c
c
      subroutine moduli
      implicit none
      include 'sizes.i'
      include 'pme.i'
      integer i,big
      real*8 w,bsarray(maxfft)
      real*8 array(maxorder)
c
c
c     compute and load the moduli values
c
      w = 0.0d0
      call bspline (w,bsorder,array)
      big = max(nfft1,nfft2,nfft3)
      do i = 1, big
         bsarray(i) = 0.0d0
      end do
      do i = 2, bsorder+1
         bsarray(i) = array(i-1)
      end do
      call dftmod (bsmod1,bsarray,nfft1)
      call dftmod (bsmod2,bsarray,nfft2)
      call dftmod (bsmod3,bsarray,nfft3)
      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", storing it into "bsmod"
c
c
      subroutine dftmod (bsmod,bsarray,nfft)
      implicit none
      include 'math.i'
      integer i,j,nfft
      real*8 eps,factor
      real*8 arg,sum1,sum2
      real*8 bsmod(*)
      real*8 bsarray(*)
c
c
c     get the modulus of the discrete Fourier transform
c
      eps = 1.0d-7
      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
      do i = 1, nfft
         if (bsmod(i) .lt. eps)
     &      bsmod(i) = 0.5d0 * (bsmod(i-1)+bsmod(i+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     ##  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
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kgeoms.i'
      include 'potent.i'
      integer i,ip,next
      integer ia,ib,ic,id
      real*8 xp,yp,zp
      real*8 p1,p2
      real*8 d1,d2,d3
      real*8 a1,a2,a3
      real*8 t1,t2,t3
      real*8 geometry
      logical exist
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     set the default values for the restraint variables
c
      npfix = 0
      ndfix = 0
      nafix = 0
      ntfix = 0
      depth = 0.0d0
      width = 0.0d0
      use_basin = .false.
      use_wall = .false.
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)
c
c     get atom restrained to a specified position range
c
         if (keyword(1:18) .eq. 'RESTRAIN-POSITION ') then
            xp = 0.0d0
            yp = 0.0d0
            zp = 0.0d0
            p1 = 0.0d0
            p2 = 0.0d0
            string = record(next:80)
            read (string,*,err=10,end=10)  ip,xp,yp,zp,p1,p2
   10       continue
            if (p2 .eq. 0.0d0)  p2 = 100.0d0
            npfix = npfix + 1
            ipfix(npfix) = ip
            xpfix(npfix) = xp
            ypfix(npfix) = yp
            zpfix(npfix) = zp
            pfix(1,npfix) = p1
            pfix(2,npfix) = p2
            if (npfix .gt. maxfix) then
               write (iout,20)
   20          format (/,' KGEOM  --  Too many Position Restraints;',
     &                    ' Increase MAXFIX')
               call fatal
            end if
c
c     get atoms restrained to a specified distance range
c
         else if (keyword(1:18) .eq. 'RESTRAIN-DISTANCE ') then
            d1 = 0.0d0
            d2 = 0.0d0
            d3 = 0.0d0
            string = record(next:80)
            exist = .false.
            read (string,*,err=30,end=30)  ia,ib,d1
            exist = .true.
   30       continue
            read (string,*,err=40,end=40)  ia,ib,d1,d2,d3
   40       continue
            if (.not. exist)  d1 = geometry (ia,ib,0,0)
            if (d2 .eq. 0.0d0)  d2 = d1
            if (d3 .eq. 0.0d0)  d3 = 100.0d0
            ndfix = ndfix + 1
            idfix(1,ndfix) = ia
            idfix(2,ndfix) = ib
            dfix(1,ndfix) = d1
            dfix(2,ndfix) = d2
            dfix(3,ndfix) = d3
            if (ndfix .gt. maxfix) then
               write (iout,50)
   50          format (/,' KGEOM  --  Too many Distance Restraints;',
     &                    ' Increase MAXFIX')
               call fatal
            end if
c
c     get atoms restrained to a specified angle range
c
         else if (keyword(1:15) .eq. 'RESTRAIN-ANGLE ') then
            a1 = 0.0d0
            a2 = 0.0d0
            a3 = 0.0d0
            string = record(next:80)
            exist = .false.
            read (string,*,err=60,end=60)  ia,ib,ic,a1
            exist = .true.
   60       continue
            read (string,*,err=70,end=70)  ia,ib,ic,a1,a2,a3
   70       continue
            if (.not. exist)  a1 = geometry (ia,ib,ic,0)
            if (a2 .eq. 0.0d0)  a2 = a1
            if (a3 .eq. 0.0d0)  a3 = 10.0d0
            nafix = nafix + 1
            iafix(1,nafix) = ia
            iafix(2,nafix) = ib
            iafix(3,nafix) = ic
            afix(1,nafix) = a1
            afix(2,nafix) = a2
            afix(3,nafix) = a3
            if (nafix .gt. maxfix) then
               write (iout,80)
   80          format (/,' KGEOM  --  Too many Angle Restraints;',
     &                    ' Increase MAXFIX')
               call fatal
            end if
c
c     get atoms restrained to a specified torsion range
c
         else if (keyword(1:17).eq.'RESTRAIN-TORSION ') then
            t1 = 0.0d0
            t2 = 0.0d0
            t3 = 0.0d0
            string = record(next:80)
            exist = .false.
            read (string,*,err=90,end=90)  ia,ib,ic,id,t1
            exist = .true.
   90       continue
            read (string,*,err=100,end=100)  ia,ib,ic,id,t1,t2,t3
            exist = .true.
  100       continue
            if (.not. exist)  t1 = geometry (ia,ib,ic,id)
            if (t2 .eq. 0.0d0)  t2 = t1
            if (t3 .eq. 0.0d0)  t3 = 1.0d0
            dowhile (t1 .gt. 180.0d0)
               t1 = t1 - 360.0d0
            end do
            dowhile (t1 .lt. -180.0d0)
               t1 = t1 + 360.0d0
            end do
            dowhile (t2 .gt. 180.0d0)
               t2 = t2 - 360.0d0
            end do
            dowhile (t2 .lt. -180.0d0)
               t2 = t2 + 360.0d0
            end do
            ntfix = ntfix + 1
            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
            if (ntfix .gt. maxfix) then
               write (iout,110)
  110          format (/,' KGEOM  --  Too many Torsion Restraints;',
     &                    ' Increase MAXFIX')
               call fatal
            end if
c
c     get any shallow Gaussian basin restraint between atoms
c
         else if (keyword(1:6) .eq. 'BASIN ') then
            string = record(next:80)
            read (string,*,err=120,end=120)  depth,width
  120       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     get any spherical droplet restraint between atoms
c
         else if (keyword(1:5) .eq. 'WALL ') then
            string = record(next:80)
            read (string,*,err=130,end=130)  rwall
  130       continue
            if (rwall .gt. 0.0d0)  use_wall = .true.
         end if
      end do
c
c     turn on the geometric restraint potential if it is used
c
      use_geom = .false.
      if (npfix .ne. 0)  use_geom = .true.
      if (ndfix .ne. 0)  use_geom = .true.
      if (nafix .ne. 0)  use_geom = .true.
      if (ntfix .ne. 0)  use_geom = .true.
      if (use_basin)  use_geom = .true.
      if (use_wall)  use_geom = .true.
      return
      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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'improp.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kiprop.i'
      include 'potent.i'
      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
      character*3 pa,pb,pc,pd
      character*12 blank,pti
      character*12 pt(6)
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     process keywords containing improper dihedral 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. 'IMPROPER ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            tk = 0.0d0
            tv = 0.0d0
            string = record(next:80)
            read (string,*,err=10,end=10)  ia,ib,ic,id,tk,tv
   10       continue
            size = 3
            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 (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 (1x,4i4,4x,2f14.4)
            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     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 = 3
               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
               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
               do j = 1, ndi
                  if (kdi(j)(1:3) .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)
                        end if
                     end do
                  end if
               end do
            end if
         end do
      end if
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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'imptor.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kitors.i'
      include 'math.i'
      include 'potent.i'
      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
      character*3 pa,pb,pc,pd
      character*12 blank,pti
      character*12 pt(6)
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     process keywords containing improper 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. '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:80)
            read (string,*,err=10,end=10)  ia,ib,ic,id,
     &                                     (vt(j),st(j),ft(j),j=1,6)
   10       continue
            size = 3
            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 (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Additional Improper Torsion Parameters :',
     &                 //,5x,'Atom Classes',12x,'1-Fold',12x,'2-Fold',
     &                    12x,'3-Fold',/)
            end if
            write (iout,30)  ia,ib,ic,id,(vt(j),st(j),j=1,3)
   30       format (1x,4i4,2x,3(f11.4,f7.1))
            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     assign improper torsional 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 = 3
               call numeral (ita,pa,size)
               call numeral (itb,pb,size)
               call numeral (itc,pc,size)
               call numeral (itd,pd,size)
               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
               do j = 1, nti
                  if (kti(j)(7:9) .eq. pc) then
                     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
                     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)
                        end if
                     end do
                  end if
               end do
            end if
         end do
      end if
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 torsional potential if it is not used
c
      if (nitors .eq. 0)  use_imptor = .false.
      return
      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
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kmulti.i'
      include 'mpole.i'
      include 'polgrp.i'
      include 'potent.i'
      include 'units.i'
      integer i,j,k,m
      integer it,mt,imp,nmp
      integer size,next,number
      integer kz,kx,ztyp,xtyp
      integer mpt(maxnmp)
      integer mpkey(maxnmp)
      integer mpz(maxnmp)
      integer mpx(maxnmp)
      integer start(maxtyp)
      integer stop(maxtyp)
      real*8 random,mpl(13)
      logical header,dummy
      character*3 pa,pb,pc
      character*8 axt
      character*9 blank,pt
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     process keywords containing atomic multipole 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:10) .eq. 'MULTIPOLE ') then
            k = 0
            kz = 0
            kx = 0
            axt = 'Z-then-X'
            do j = 1, 13
               mpl(j) = 0.0d0
            end do
            string = record(next:80)
            read (string,*,err=50,end=50)  k,kz,kx,mpl(1)
            if (k .gt. 0) then
               if (kx .lt. 0)  axt = 'Bisector'
               kz = abs(kz)
               kx = abs(kx)
               record = keyline(i+1)
               read (record,*,err=50,end=50)  (mpl(j),j=2,4)
               record = keyline(i+2)
               read (record,*,err=50,end=50)  mpl(5)
               record = keyline(i+3)
               read (record,*,err=50,end=50)  (mpl(j),j=8,9)
               record = keyline(i+4)
               read (record,*,err=50,end=50)  (mpl(j),j=11,13)
               mpl(6) = mpl(8)
               mpl(7) = mpl(11)
               mpl(10) = mpl(12)
               if (header) then
                  header = .false.
                  write (iout,10)
   10             format (/,' Additional Atomic Multipole Parameters :',
     &                    //,6x,'Atom Type',5x,'Local Axes Definition',
     &                       10x,'Multipole Moments')
               end if
               write (iout,20)  k,kz,kx,axt,(mpl(j),j=1,5),
     &                          mpl(8),mpl(9),(mpl(j),j=11,13)
   20          format (/,6x,i6,5x,i6,1x,i6,3x,a8,4x,f9.5,/,45x,3f9.5,
     &                    /,45x,f9.5,/,45x,2f9.5,/,45x,3f9.5)
               size = 3
               call numeral (k,pa,size)
               call numeral (kz,pb,size)
               call numeral (kx,pc,size)
               pt = pa//pb//pc
               do j = 1, maxnmp
                  if (kmp(j).eq.blank .or. kmp(j).eq.pt) then
                     kmp(j) = pt
                     mpaxis(j) = axt
                     do m = 1, 13
                        multip(m,j) = mpl(m)
                     end do
                     goto 40
                  end if
               end do
               write (iout,30)
   30          format (/,' KMPOLE  --  Too many Atomic Multipole',
     &                    ' Parameters')
               abort = .true.
   40          continue
            end if
   50       continue
         end if
      end do
c
c     zero out local axes, multipoles and polarization attachments
c
      dummy = .false.
      do i = 1, n
         zaxis(i) = 0
         xaxis(i) = 0
         polaxe(i) = '        '
         do j = 1, 13
            pole(j,i) = 0.0d0
         end do
         np11(i) = 0
         np12(i) = 0
         np13(i) = 0
         np14(i) = 0
      end do
c
c     determine the total number of forcefield parameters
c
      nmp = maxnmp
      do i = maxnmp, 1, -1
         if (kmp(i) .eq. blank)  nmp = i - 1
      end do
c
c     set indices into the list of atomic multipole parameters
c
      do i = 1, nmp
         mpt(i) = number(kmp(i)(1:3))
         mpz(i) = number(kmp(i)(4:6))
         mpx(i) = number(kmp(i)(7:9))
      end do
      call sort3 (nmp,mpt,mpkey)
      do i = 1, maxtyp
         start(i) = 0
         stop(i) = 0
      end do
      do i = 1, nmp
         k = mpt(i)
         if (start(k) .eq. 0)  start(k) = i
      end do
      do i = nmp, 1, -1
         k = mpt(i)
         if (stop(k) .eq. 0)  stop(k) = i
      end do
c
c     assign atomic multipole parameters to each atom
c
      do i = 1, n
         it = type(i)
         if (start(it) .ne. 0) then
            do j = start(it), stop(it)
               imp = mpkey(j)
               ztyp = mpz(imp)
               xtyp = mpx(imp)
               if (n12(i) .eq. 0) then
                  zaxis(i) = n + 1
                  xaxis(i) = n + 2
                  dummy = .true.
                  goto 60
               end if
               do k = 1, n12(i)
                  if (type(i12(k,i)) .eq. ztyp) then
                     if (n12(i) .ge. 2) then
                        do m = 1, n12(i)
                           mt = type(i12(m,i))
                           if (mt.eq.xtyp .and. m.ne.k) then
                              zaxis(i) = i12(k,i)
                              xaxis(i) = i12(m,i)
                              goto 60
                           end if
                        end do
                        do m = 1, n13(i)
                           mt = type(i13(m,i))
                           if (mt .eq. xtyp) then
                              zaxis(i) = i12(k,i)
                              xaxis(i) = i13(m,i)
                              goto 60
                           end if
                        end do
                     else if (n12(i) .eq. 1) then
                        if (n13(i) .eq. 0) then
                           zaxis(i) = i12(k,i)
                           xaxis(i) = n + 1
                           dummy = .true.
                           goto 60
                        else
                           do m = 1, n13(i)
                              mt = type(i13(m,i))
                              if (mt .eq. xtyp) then
                                 zaxis(i) = i12(k,i)
                                 xaxis(i) = i13(m,i)
                                 goto 60
                              end if
                           end do
                        end if
                     end if
                  end if
               end do
            end do
   60       continue
            if (zaxis(i) .ne. 0) then
               polaxe(i) = mpaxis(imp)
               do j = 1, 13
                  pole(j,i) = multip(j,imp)
               end do
            end if
         end if
      end do
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
            axt = 'Z-then-X'
            do j = 1, 13
               mpl(j) = 0.0d0
            end do
            string = record(next:80)
            read (string,*,err=90,end=90)  k,kz,kx,mpl(1)
            if (k.lt.0 .and. k.ge.-n) then
               k = -k
               if (kx .lt. 0)  axt = 'Bisector'
               kz = abs(kz)
               kx = abs(kx)
               record = keyline(i+1)
               read (record,*,err=90,end=90)  (mpl(j),j=2,4)
               record = keyline(i+2)
               read (record,*,err=90,end=90)  mpl(5)
               record = keyline(i+3)
               read (record,*,err=90,end=90)  (mpl(j),j=8,9)
               record = keyline(i+4)
               read (record,*,err=90,end=90)  (mpl(j),j=11,13)
               mpl(6) = mpl(8)
               mpl(7) = mpl(11)
               mpl(10) = mpl(12)
               if (header) then
                  header = .false.
                  write (iout,70)
   70             format (/,' Additional Atomic Multipoles',
     &                       ' for Specific Atoms :',
     &                    //,8x,'Atom',8x,'Local Axes Definition',
     &                       10x,'Multipole Moments',/)
               end if
               write (iout,80)  k,kz,kx,axt,(mpl(j),j=1,5),
     &                          mpl(8),mpl(9),(mpl(j),j=11,13)
   80          format (6x,i6,5x,i6,1x,i6,3x,a8,4x,f9.5,/,45x,3f9.5,
     &                    /,45x,f9.5,/,45x,2f9.5,/,45x,3f9.5)
               if (kz .eq. 0)  kz = n + 1
               if (kx .eq. 0)  kx = n + 1
               if (kz.eq.n+1 .and. kx.eq.n+1)  kx = n + 2
               if (kz.gt.n .or. kx.gt.n)  dummy = .true.
               zaxis(k) = kz
               xaxis(k) = kx
               polaxe(k) = axt
               do j = 1, 13
                  pole(j,k) = mpl(j)
               end do
            end if
   90       continue
         end if
      end do
c
c     generate random coordinates for dummy axis defining atoms
c
      if (dummy) then
         do i = n+1, n+2
            x(i) = random ()
            y(i) = random ()
            z(i) = random ()
         end do
      end if
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
      do i = 1, n
         size = 0
         do k = 1, 13
            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
      end do
c
c     if polarization not used, remove zero and undefined multipoles
c
      if (.not. use_polar) then
         npole = 0
         do i = 1, n
            if (polsiz(i) .ne. 0) then
               if (zaxis(i).ne.0 .and. xaxis(i).ne.0) then
                  npole = npole + 1
                  ipole(npole) = i
                  zaxis(npole) = zaxis(i)
                  xaxis(npole) = xaxis(i)
                  polaxe(npole) = polaxe(i)
                  polsiz(npole) = polsiz(i)
                  do j = 1, 13
                     pole(j,npole) = pole(j,i)
                  end do
               end if
            end if
         end do
c
c     turn off the atomic multipole potential if it is not used
c
         if (npole .eq. 0)  use_mpole = .false.
      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 kopbend  --  out-of-plane bending parameters  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "kopbend" assigns the force constants for out-of-plane
c     bending at trigonal centers via Wilson-Decius-Cross angle
c     bends; also processes any new or changed parameter values
c
c
      subroutine kopbend
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kopbnd.i'
      include 'opbend.i'
      include 'potent.i'
      integer i,j,nopb
      integer ia,ib,id,it
      integer itb,itd,number
      integer next,size
      real*8 fopb
      logical header
      logical jopb(maxclass)
      character*3 pa,pb,pd
      character*6 blank,ps
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     process keywords containing out-of-plane 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. 'OPBEND ') then
            ia = 0
            ib = 0
            fopb = 0.0d0
            string = record(next:80)
            read (string,*,err=10,end=10)  ia,ib,fopb
   10       continue
            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,fopb
   30       format (6x,2i4,16x,f12.3)
            size = 3
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            ps = pa//pb
            do j = 1, maxnopb
               if (kaopb(j).eq.blank .or. kaopb(j).eq.ps) then
                  kaopb(j) = ps
                  copb(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     determine the total number of forcefield parameters
c
      nopb = maxnopb
      do i = maxnopb, 1, -1
         if (kaopb(i) .eq. blank)  nopb = i - 1
      end do
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 (kaopb(i) .eq. blank)  goto 60
         it = number (kaopb(i)(1:3))
         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
               id = iang(4,i)
               itd = class(id)
               size = 3
               call numeral (itb,pb,size)
               call numeral (itd,pd,size)
               ps = pb//pd
               do j = 1, nopb
                  if (kaopb(j) .eq. ps) then
                     nopbend = nopbend + 1
                     iopb(nopbend) = i
                     kopb(nopbend) = copb(j)
                     angtyp(i) = 'IN-PLANE'
                     goto 90
                  end if
               end do
               abort = .true.
               if (header) then
                  header = .false.
                  write (iout,70)
   70             format (/,' Undefined Out-of-Plane Bending',
     &                       ' Parameters :',
     &                    //,' Type',13x,'Atom Names',11x,
     &                       'Atom Classes',/)
               end if
               write (iout,80)  ib,name(ib),id,name(id),itb,itd
   80          format (' Angle-OP',3x,i6,'-',a3,i6,'-',a3,7x,2i5)
   90          continue
            else
               iang(4,i) = ib
            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)  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
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kopdst.i'
      include 'opdist.i'
      include 'potent.i'
      integer i,j,k,nopd
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer size,next
      real*8 fopd
      logical header
      character*3 pa,pb,pc,pd
      character*12 blank
      character*12 pti,pt(6)
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     process keywords containing out-of-plane distance 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. 'OPDIST ') then
            ia = 0
            ib = 0
            ic = 0
            id = 0
            fopd = 0.0d0
            string = record(next:80)
            read (string,*,err=10,end=10)  ia,ib,ic,id,fopd
   10       continue
            size = 3
            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 (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Additional Out-of-Plane Distance',
     &                    ' Parameters :',
     &                 //,5x,'Atom Classes',12x,'K(OPD)',/)
            end if
            write (iout,30)  ia,ib,ic,id,fopd
   30       format (1x,4i4,4x,2f14.4)
            do j = 1, maxnopd
               if (kaopd(j).eq.blank .or. kaopd(j).eq.pti) then
                  kaopd(j) = pti
                  copd(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 (kaopd(i) .eq. blank)  nopd = i - 1
      end do
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 = 3
               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
               do j = 1, nopd
                  if (kaopd(j)(1:3) .eq. pa) then
                     do k = 1, 6
                        if (kaopd(j) .eq. pt(k)) then
                           nopdist = nopdist + 1
                           iopd(1,nopdist) = ia
                           if (k .eq. 1) then
                              iopd(2,nopdist) = ib
                              iopd(3,nopdist) = ic
                              iopd(4,nopdist) = id
                           else if (k .eq. 2) then
                              iopd(2,nopdist) = ib
                              iopd(3,nopdist) = id
                              iopd(4,nopdist) = ic
                           else if (k .eq. 3) then
                              iopd(2,nopdist) = ic
                              iopd(3,nopdist) = ib
                              iopd(4,nopdist) = id
                           else if (k .eq. 4) then
                              iopd(2,nopdist) = ic
                              iopd(3,nopdist) = id
                              iopd(4,nopdist) = ib
                           else if (k .eq. 5) then
                              iopd(2,nopdist) = id
                              iopd(3,nopdist) = ib
                              iopd(4,nopdist) = ic
                           else if (k .eq. 6) then
                              iopd(2,nopdist) = id
                              iopd(3,nopdist) = ic
                              iopd(4,nopdist) = ib
                           end if
                           kopd(nopdist) = copd(j)
                           goto 60
                        end if
                     end do
                  end if
               end do
   60          continue
            end if
         end do
      end if
c
c     mark angles at trigonal sites to use projected in-plane values
c
      do i = 1, nopdist
         ia = iopd(1,i)
         do j = 1, 3
            angtyp(anglist(j,ia)) = 'IN-PLANE'
         end do
      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)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine korbit  --  pisystem parameter assignment  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "korbit" assigns pi-orbital parameters to conjugated
c     systems and processes any new or changed parameters
c
c
      subroutine korbit
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'korbs.i'
      include 'orbits.i'
      include 'piorbs.i'
      include 'pistuf.i'
      include 'tors.i'
      include 'units.i'
      integer i,j,k,npi
      integer ia,ib,it
      integer ita,itb
      integer size,next
      real*8 elect,ioniz
      real*8 repuls
      real*8 sslop,tslop
      logical header
      character*3 pa,pb
      character*6 blank,pt
      character*20 keyword
      character*80 record
      character*80 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
            if (header) then
               header = .false.
               write (iout,10)
   10          format (/,' Additional Pisystem Atom Parameters :',
     &                 //,6x,'Atom Type',3x,'Electron',3x,'Ionization',
     &                    3x,'Repulsion',/)
            end if
            ia = 0
            elect = 0.0d0
            ioniz = 0.0d0
            repuls = 0.0d0
            string = record(next:80)
            read (string,*,err=20)  ia,elect,ioniz,repuls
   20       continue
            write (iout,30)  ia,elect,ioniz,repuls
   30       format (8x,i4,3x,f10.3,3x,f10.3,2x,f10.3)
            if (ia.gt.0 .and. ia.le.maxclass) then
               electron(ia) = elect
               ionize(ia) = ioniz
               repulse(ia) = repuls
            else
   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)
         if (keyword(1:7) .eq. 'PIBOND ') then
            if (header) then
               header = .false.
               write (iout,50)
   50          format (/,' Additional Pisystem Bond Parameters :',
     &                 //,6x,'Atom Types',7x,'d Force',4x,'d Length',/)
            end if
            ia = 0
            ib = 0
            sslop = 0.0d0
            tslop = 0.0d0
            string = record(next:80)
            read (string,*,err=60)  ia,ib,sslop,tslop
   60       continue
            write (iout,70)  ia,ib,sslop,tslop
   70       format (6x,2i4,5x,2f11.3)
            size = 3
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            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 90
               end if
            end do
            write (iout,80)
   80       format (/,' KORBIT  --  Too many Pi-System Bond',
     &                 ' Type Parameters')
            abort = .true.
   90       continue
         end if
      end do
c
c     determine the total number of forcefield parameters
c
      npi = maxnpi
      do i = maxnpi, 1, -1
         if (kpi(i) .eq. blank)  npi = i - 1
      end do
c
c     assign the values characteristic of the piatom types;
c     count the number of filled pi molecular orbitals
c
      nfill = 0
      do i = 1, norbit
         it = type(iorbit(i))
         q(i) = electron(it)
         w(i) = ionize(it) / evolt
         em(i) = repulse(it) / evolt
         nfill = nfill + nint(q(i))
      end do
      nfill = nfill / 2
c
c     assign parameters for all bonds between piatoms;
c     store the original bond lengths and force constants
c
      do i = 1, npibond
         j = pibond(1,i)
         ia = pibond(2,i)
         ib = pibond(3,i)
         ita = class(iorbit(ia))
         itb = class(iorbit(ib))
         size = 3
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            pt = pa//pb
         else
            pt = pb//pa
         end if
         do k = 1, npi
            if (kpi(k) .eq. pt) then
               bkpi(i) = bk(j)
               blpi(i) = bl(j)
               kslope(i) = sslope(k)
               lslope(i) = tslope(k)
               goto 110
            end if
         end do
         write (iout,100)  ita,itb
  100    format (/,' KORBIT  --  No Parameters for Pi-Bond',
     &              ' between Atom Types',2i4)
  110    continue
      end do
c
c     store the original torsional constants across pibonds
c
      do i = 1, npitors
         j = pitors(1,i)
         torspi(i) = tors2(1,j)
      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 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
      subroutine kpolar
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kpolr.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polpot.i'
      include 'potent.i'
      integer i,j,k
      integer npg,next
      integer pg(maxval)
      real*8 pol,sixth
      logical header
      character*20 keyword
      character*80 record
      character*80 string
c
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
            do j = 1, 20
               pg(j) = 0
            end do
            string = record(next:80)
            read (string,*,err=10,end=10)  k,pol,(pg(j),j=1,maxval)
   10       continue
            if (k .gt. 0) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Atomic Dipole',
     &                       ' Polarizability Parameters :',
     &                    //,6x,'Atom Type',10x,'Alpha',10x,
     &                       'Group Atom Types'/)
               end if
               if (k .le. maxtyp) then
                  polr(k) = pol
                  do j = 1, maxval
                     pgrp(j,k) = pg(j)
                     if (pg(j) .eq. 0) then
                        npg = j - 1
                        goto 30
                     end if
                  end do
   30             continue
                  write (iout,40)  k,pol,(pg(j),j=1,npg)
   40             format (6x,i6,6x,f12.3,10x,20i5)
               else
                  write (iout,50)
   50             format (/,' KPOLAR  --  Too many Dipole',
     &                       ' Polarizability Parameters')
                  abort = .true.
               end if
            end if
         end if
      end do
c
c     find and store all the atomic dipole polarizabilities
c
      do i = 1, n
         polarity(i) = polr(type(i))
      end do
c
c     process keywords containing atom specific polarizabilities
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
            string = record(next:80)
            read (string,*,err=80,end=80)  k,pol
            if (k.lt.0 .and. k.ge.-n) then
               k = -k
               if (header) then
                  header = .false.
                  write (iout,60)
   60             format (/,' Additional Dipole Polarizabilities',
     &                       ' for Specific Atoms :',
     &                    //,8x,'Atom',13x,'Alpha',/)
               end if
               write (iout,70)  k,pol
   70          format (6x,i6,6x,f12.3)
               polarity(k) = pol
            end if
   80       continue
         end if
      end do
c
c     remove zero and undefined polarizable multipoles from the list
c
      npole = 0
      do i = 1, n
         if (polsiz(i).ne.0 .or. polarity(i).ne.0.0d0) then
            if (zaxis(i).ne.0 .and. xaxis(i).ne.0) then
               npole = npole + 1
               ipole(npole) = i
               zaxis(npole) = zaxis(i)
               xaxis(npole) = xaxis(i)
               polaxe(npole) = polaxe(i)
               polsiz(npole) = polsiz(i)
               do k = 1, maxpole
                  pole(k,npole) = pole(k,i)
               end do
               polarity(npole) = polarity(i)
            end if
         end if
      end do
c
c     set the values used in the damping of the polarizability
c
      if (pgamma .eq. 0.0d0) then
         do i = 1, npole
            pdamp(i) = 0.0d0
         end do
      else
         sixth = 1.0d0 / 6.0d0
         do i = 1, npole
            pdamp(i) = polarity(i)**sixth
         end do
      end if
c
c     assign polarization group connectivity of each atom
c
      call polargrp
c
c     count the final number of polarizable multipole sites
c
      npolar = 0
      do i = 1, npole
         if (polarity(i) .ne. 0.0d0)  npolar = npolar + 1
      end do
c
c     turn off polarizable multipole terms if they are not used
c
      if (npole .eq. 0)  use_mpole = .false.
      if (npolar .eq. 0)  use_polar = .false.
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kpolr.i'
      include 'mpole.i'
      include 'polgrp.i'
      integer i,j,k
      integer it,jt
      integer jj,kk
      integer start,stop
      integer nlist,nkeep
      integer list(maxatm)
      integer keep(maxatm)
      integer mask(maxatm)
      logical done
c
c
c     find the directly connected group members for each atom
c
      do i = 1, n
         np11(i) = 1
         ip11(1,i) = i
         it = type(i)
         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
                  np11(i) = np11(i) + 1
                  if (np11(i) .le. maxp11) then
                     ip11(np11(i),i) = jj
                  else
                     write (iout,10)
   10                format (/,' POLARGRP  --  Too Many Atoms',
     &                          ' in Polarization Group')
                     abort = .true.
                  end if
               end if
            end do
   20       continue
         end do
      end do
c
c     find any other group members for each atom in turn
c
      do i = 1, n
         list(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
               list(jj) = i
            end if
         end do
         dowhile (.not. done)
            done = .true.
            do j = start, stop
               jj = ip11(j,i)
               do k = 1, np11(jj)
                  kk = ip11(k,jj)
                  if (list(kk) .ne. i) then
                     np11(i) = np11(i) + 1
                     if (np11(i) .le. maxp11) then
                        ip11(np11(i),i) = kk
                     else
                        write (iout,30)
   30                   format (/,' POLARGRP  --  Too Many Atoms',
     &                             ' in Polarization Group')
                        abort = .true.
                     end if
                     list(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
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
         nlist = 0
         do j = 1, np11(i)
            jj = ip11(j,i)
            nlist = nlist + 1
            list(nlist) = jj
            mask(jj) = i
         end do
         nkeep = 0
         do j = 1, nlist
            jj = list(j)
            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)
         np12(i) = nlist
         do j = 1, nlist
            ip12(j,i) = list(j)
         end do
      end do
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)
         np13(i) = nlist
         do j = 1, nlist
            ip13(j,i) = list(j)
         end do
      end do
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)
         np14(i) = nlist
         do j = 1, nlist
            ip14(j,i) = list(j)
         end do
      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 ksolv  --  solvation parameter assignment  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "ksolv" assigns continuum solvation energy parameters for
c     the Eisenberg-McLachlan ASP, Ooi-Scheraga SASA or various
c     GB/SA solvation models
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 ksolv
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'keys.i'
      include 'math.i'
      include 'potent.i'
      include 'solute.i'
      include 'units.i'
      integer i,j,k,m,kc
      integer ia,ib,ic,id
      integer mm,nh,next
      integer atmnum,atmmas
      real*8 ri,ri2,rk,rk2
      real*8 r,r2,r4,rab,rbc
      real*8 cosine,factor
      real*8 h,ratio,term
      real*8 c1,c2,c3,pi2
      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
      character*20 keyword
      character*20 value
      character*80 record
c
c
c     default is to not use the continuum solvation term
c
      use_solv = .false.
      use_gbsa = .false.
      solvtyp = '      '
c
c     search keywords for continuum solvation commands
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:8) .eq. 'SOLVATE ') then
            use_solv = .true.
            use_gbsa = .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_gbsa = .true.
               solvtyp = 'ONION'
            else if (value(1:5) .eq. 'STILL') then
               use_gbsa = .true.
               solvtyp = 'STILL'
            else if (value(1:3) .eq. 'HCT') then
               use_gbsa = .true.
               solvtyp = 'HCT'
            else if (value(1:3) .eq. 'ACE') then
               use_gbsa = .true.
               solvtyp = 'ACE'
            else if (value(1:4) .eq. 'GBSA') then
               use_gbsa = .true.
               solvtyp = 'STILL'
            end if
         end if
      end do
c
c     set the dielectric offset to the radii for GB/SA methods
c
      if (use_gbsa)  doffset = -0.09d0
c     
c     set offset and scaling values for analytical Still method
c
      if (solvtyp .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 Hawkins-Cramer-Truhlar method
c
      if (solvtyp .eq. 'HCT') 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 the Gaussian width factor for the ACE method
c
      if (solvtyp .eq. 'ACE') then
         width = 1.2d0
      end if
c
c     assign surface area factors for various GB/SA methods
c
      if (solvtyp .eq. 'ONION') then
         do i = 1, n
            asolv(i) = 0.0072d0
         end do
      else if (solvtyp .eq. 'STILL') then
         do i = 1, n
            asolv(i) = 0.0049d0
         end do
      else if (solvtyp .eq. 'HCT') then
         do i = 1, n
            asolv(i) = 0.0054d0
         end do
      else if (solvtyp .eq. 'ACE') then
         do i = 1, n
            asolv(i) = 0.0030d0
         end do
      end if
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
c
c     assign standard radii for GB/SA methods other than ACE;
c     taken from Macromodel and OPLS-AA, except for hydrogens
c
      if (use_gbsa .and. solvtyp.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 (solvtyp .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     these values are intended for united-atom force fields
c
      if (solvtyp .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) = 0.0d0
               k = i12(1,i)
               if (atomic(k).eq.7 .and. n12(k).eq.4) then
                  rsolv(i) = 0.60d0
                  vsolv(i) = 0.529d0
               else if (atomic(k).ne.6) then
                  rsolv(i) = 0.80d0
                  vsolv(i) = 0.31d0
               end if
            else if (atmnum .eq. 6) then
               rsolv(i) = 2.49d0
               vsolv(i) = 0.0d0
               if (atmmas .eq. 15) then
                  rsolv(i) = 2.165d0
                  vsolv(i) = 40.947d0
               else if (atmmas .eq. 14) then
                  rsolv(i) = 2.235d0
                  vsolv(i) = 35.356d0
               else if (atmmas.eq.13 .and. n12(i).eq.2) then
                  rsolv(i) = 2.10d0
                  vsolv(i) = 18.583d0
               else if (atmmas .eq. 13) then
                  rsolv(i) = 2.365d0
                  vsolv(i) = 12.257d0
               else
                  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) = 12.403d0
                     end if
                  end do
               end if
            else if (atmnum .eq. 7) then
               rsolv(i) = 1.60d0
               vsolv(i) = 17.16d0
               if (n12(i) .eq. 4) then
                  vsolv(i) = 15.521d0
               else
                  nh = 0
                  amide = .false.
                  do j = 1, n12(i)
                     m = i12(j,i)
                     if (atomic(m) .eq. 1) then
                        nh = nh + 1
                     else 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) = 0.0d0
                     else if (nh .eq. 1) then
                        vsolv(i) = 1.708d0
                     else if (nh .eq. 2) then
                        vsolv(i) = 18.677d0
                     end if
                  else
                     if (nh .eq. 2) then
                        vsolv(i) = 19.336d0
                     end if
                  end if
               end if
            else if (atmnum .eq. 8) then
               rsolv(i) = 1.60d0
               vsolv(i) = 17.16d0
               if (n12(i) .eq. 1) then
                  k = i12(1,i)
                  if (n12(k) .eq. 1) then
                     vsolv(i) = 20.545d0
                  else
                     vsolv(i) = 14.435d0
                     do j = 1, n13(i)
                        k = i13(j,i)
                        if (atomic(j).eq.8 .and. n12(j).eq.1) then
                           vsolv(i) = 16.404d0
                        end if
                     end do
                  end if
               else if (n12(i) .eq. 2) then
                  if (atomic(i12(1,i)).eq.1 .and.
     &                atomic(i12(2,i)).eq.1) then
                     vsolv(i) = 29.70d0
                  else
                     vsolv(i) = 21.427d0
                  end if
               end if
            else if (atmnum .eq. 16) then
               rsolv(i) = 1.89d0
               vsolv(i) = 15.196d0
            else if (atmnum .eq. 26) then
               rsolv(i) = 0.65d0
               vsolv(i) = 0.411d0
            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 * sqrt(2.0d0) / 512.0d0
         c3 = 2.0d0 * pi * sqrtpi
         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(kc)
               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     ##  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 the parameters for the stretch-bend
c     interactions and processes new or changed parameter values
c
c
      subroutine kstrbnd
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'angpot.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kstbnd.i'
      include 'potent.i'
      include 'strbnd.i'
      integer i,j,k,next
      integer ia,ib,ic
      integer it,itb,ina,inc
      integer nh,nb1,nb2
      real*8 sbk(3)
      logical header
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     process keywords containing stretch-bend 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
            it = 0
            do j = 1, 3
               sbk(j) = 0.0d0
            end do
            string = record(next:80)
            read (string,*,err=10,end=10)  it,(sbk(j),j=1,3)
   10       continue
            if (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Additional Stretch-Bend Parameters :',
     &                 //,5x,'Atom Class',8x,'K(SB) 1',4x,'K(SB) 2',
     &                    4x,'K(SB) 3',/)
            end if
            write (iout,30)  it,(sbk(j),j=1,3)
   30       format (9x,i3,7x,3f11.3)
            do j = 1, 3
               stbn(j,it) = sbk(j)
            end do
         end if
      end do
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)
         itb = class(ib)
         ina = atomic(ia)
         inc = atomic(ic)
         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
         nh = 1
         if (ina .le. 1)  nh = nh + 1
         if (inc .le. 1)  nh = nh + 1
         if (stbn(nh,itb) .ne. 0.0d0) then
            nstrbnd = nstrbnd + 1
            isb(1,nstrbnd) = i
            isb(2,nstrbnd) = nb1
            isb(3,nstrbnd) = nb2
            ksb(nstrbnd) = stbn(nh,itb)
            if (mm2stbn) then
               if (ina .le. 1)  isb(2,nstrbnd) = 0
               if (inc .le. 1)  isb(3,nstrbnd) = 0
            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
      implicit none
      include 'sizes.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'ksttor.i'
      include 'potent.i'
      include 'strtor.i'
      include 'tors.i'
      integer i,j,k,nbt
      integer ib,ic,itb,itc
      integer size,next
      real*8 bt1,bt2,bt3
      logical header
      character*3 pb,pc
      character*6 blank,pt
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     process keywords containing stretch-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. 'STRTORS ') then
            ib = 0
            ic = 0
            bt1 = 0.0d0
            bt2 = 0.0d0
            bt3 = 0.0d0
            string = record(next:80)
            read (string,*,err=10,end=10)  ib,ic,bt1,bt2,bt3
   10       continue
            if (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Additional Stretch-Torsion Parameters :',
     &                 //,5x,'Atom Classes',7x,'1-Fold',6x,'2-Fold',
     &                    6x,'3-Fold',/)
            end if
            write (iout,30)  ib,ic,bt1,bt2,bt3
   30       format (6x,2i4,4x,3f12.3)
            size = 3
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            if (ib .le. ic) then
               pt = pb//pc
            else
               pt = pc//pb
            end if
            do j = 1, maxnbt
               if (kbt(j).eq.blank .or. kbt(j).eq.pt) then
                  kbt(j) = pt
                  btcon(1,j) = bt1
                  btcon(2,j) = bt2
                  btcon(3,j) = bt3
                  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     assign stretch-torsion parameters as required
c
      nstrtor = 0
      if (nbt .ne. 0) then
         do i = 1, ntors
            ib = itors(2,i)
            ic = itors(3,i)
            itb = class(ib)
            itc = class(ic)
            size = 3
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            if (itb .le. itc) then
               pt = pb//pc
            else
               pt = pc//pb
            end if
            do j = 1, nbt
               if (kbt(j) .eq. pt) then
                  nstrtor = nstrtor + 1
                  kst(1,nstrtor) = btcon(1,j)
                  kst(2,nstrtor) = btcon(2,j)
                  kst(3,nstrtor) = btcon(3,j)
                  ist(1,nstrtor) = i
                  do k = 1, n12(ib)
                     if (i12(k,ib) .eq. ic) then
                        ist(2,nstrtor) = bndlist(k,ib)
                        goto 60
                     end if
                  end do
               end if
            end do
   60       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)  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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'ktorsn.i'
      include 'math.i'
      include 'potent.i'
      include 'ring.i'
      include 'tors.i'
      integer i,j,k
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer nt,nt5,nt4
      integer size,next
      integer iring,minat
      integer nuse,iuse
      integer kindex(maxnt)
      integer ft(6)
      real*8 angle,vt(6),st(6)
      logical header,done
      logical use_ring5
      logical use_ring4
      character*3 pa,pb,pc,pd
      character*7 label
      character*12 blank,pt
      character*12 kuse(maxnt)
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     process keywords containing torsional angle 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: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:80)
            read (string,*,err=10,end=10)  ia,ib,ic,id,
     &                                     (vt(j),st(j),ft(j),j=1,6)
   10       continue
            size = 3
            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 (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Additional Torsional Parameters :',
     &                 //,5x,'Atom Classes',4x,'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 (1x,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 (1x,4i4,1x,6(f6.2,i4),3x,a6)
            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
         end if
      end do
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
c
c     use small rings if present and parameters are available
c
      use_ring5 = .true.
      use_ring4 = .true.
      if (nring5.eq.0 .or. nt5.eq.0)  use_ring5 = .false.
      if (nring4.eq.0 .or. nt4.eq.0)  use_ring4 = .false.
c
c     assign torsional parameters for each torsional angle
c     by putting the parameter values into the "tors" arrays
c
      header = .true.
      nuse = 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 = 3
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (itb .lt. itc) then
            pt = pa//pb//pc//pd
         else if (itc .lt. itb) then
            pt = pd//pc//pb//pa
         else if (ita .le. itd) then
            pt = pa//pb//pc//pd
         else if (itd .lt. ita) then
            pt = pd//pc//pb//pa
         end if
         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 (n12(ia).eq.1 .or. n12(id).eq.1)  goto 110
         if (use_ring4) then
            do j = 1, n12(id)
               if (ia .eq. i12(j,id)) then
                  iring = 4
                  goto 110
               end if
            end do
         end if
         if (use_ring5) then
            do j = 1, n12(id)
               if (ic .ne. i12(j,id)) then
                  do k = 1, n12(ia)
                     if (i12(j,id) .eq. i12(k,ia)) then
                        iring = 5
                        goto 110
                     end if
                  end do
               end if
            end do
         end if
  110    continue
c
c     find parameters for this torsion; first check "kuse"
c     to save time for angle types already located
c
         if (iring .eq. 0) then
            do j = 1, nuse
               if (kuse(j) .eq. pt) then
                  iuse = kindex(j)
                  tors1(1,i) = tors1(1,iuse)
                  tors1(2,i) = tors1(2,iuse)
                  tors2(1,i) = tors2(1,iuse)
                  tors2(2,i) = tors2(2,iuse)
                  tors3(1,i) = tors3(1,iuse)
                  tors3(2,i) = tors3(2,iuse)
                  tors4(1,i) = tors4(1,iuse)
                  tors4(2,i) = tors4(2,iuse)
                  tors5(1,i) = tors5(1,iuse)
                  tors5(2,i) = tors5(2,iuse)
                  tors6(1,i) = tors6(1,iuse)
                  tors6(2,i) = tors6(2,iuse)
                  done = .true.
                  goto 120
               end if
            end do
            do j = 1, nt
               if (kt(j) .eq. pt) then
                  nuse = nuse + 1
                  kuse(nuse) = pt
                  kindex(nuse) = 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
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
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
         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 (.not. done) then
            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     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)  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
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'kurybr.i'
      include 'potent.i'
      include 'urey.i'
      integer i,j,nu
      integer ia,ib,ic
      integer ita,itb,itc
      integer size,next
      real*8 bb,tt
      logical header
      character*3 pa,pb,pc
      character*9 blank,pt
      character*20 keyword
      character*80 record
      character*80 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:80)
            read (string,*,err=10,end=10)  ia,ib,ic,bb,tt
   10       continue
            if (header) then
               header = .false.
               write (iout,20)
   20          format (/,' Additional Urey-Bradley Parameters :',
     &                 //,5x,'Atom Classes',8x,'K(UB)',5x,'Distance',/)
            end if
            write (iout,30)  ia,ib,ic,bb,tt
   30       format (4x,3i4,2x,f12.3,f12.4)
            size = 3
            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     loop over all angles assigning the necessary constants
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 = 3
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itc,pc,size)
            if (ita .le. itc) then
               pt = pa//pb//pc
            else
               pt = pc//pb//pa
            end if
c
c     search for Urey-Bradley parameters for current angle
c
            do j = 1, nu
               if (ku(j) .eq. pt) then
                  nurey = nurey + 1
                  iury(1,nurey) = ia
                  iury(2,nurey) = ic
                  uk(nurey) = ucon(j)
                  ul(nurey) = dst13(j)
                  goto 60
               end if
            end do
   60       continue
         end do
      end if
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)  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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'khbond.i'
      include 'kvdws.i'
      include 'kvdwpr.i'
      include 'math.i'
      include 'potent.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,k,ia,ib,next
      integer size,number
      real*8 rd,ep,rdn
      real*8 srad(maxclass)
      real*8 srad4(maxclass)
      real*8 seps(maxclass)
      real*8 seps4(maxclass)
      logical header
      character*3 pa,pb
      character*6 blank,pt
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     process keywords containing van der Waals 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:4) .eq. 'VDW ') then
            k = 0
            rd = 0.0d0
            ep = 0.0d0
            rdn = 0.0d0
            string = record(next:80)
            read (string,*,err=10,end=10)  k,rd,ep,rdn
   10       continue
            if (k.ge.1 .and. k.le.maxclass) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional van der Waals Parameters :',
     &                    //,6x,'Class',6x,'Radius',5x,'Epsilon',
     &                       4x,'Reduction',/)
               end if
               if (ep .eq. 0.0d0)  ep = eps(k)
               if (rdn .eq. 0.0d0)  rdn = reduct(k)
               rad(k) = rd
               eps(k) = ep
               reduct(k) = rdn
               write (iout,30)  k,rd,ep,rdn
   30          format (4x,i6,1x,2f12.4,f11.3)
            else if (k .gt. maxclass) then
               write (iout,40)  maxclass
   40          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
      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
            k = 0
            rd = 0.0d0
            ep = 0.0d0
            string = record(next:80)
            read (string,*,err=50,end=50)  k,rd,ep
   50       continue
            if (k.ge.1 .and. k.le.maxclass) then
               if (header) then
                  header = .false.
                  write (iout,60)
   60             format (/,' Additional 1-4 van der Waals',
     &                       ' Parameters :',
     &                    //,6x,'Class',6x,'Radius',5x,'Epsilon',/)
               end if
               if (ep .eq. 0.0d0)  ep = eps4(k)
               rad4(k) = rd
               eps4(k) = ep
               write (iout,70)  k,rd,ep
   70          format (4x,i6,1x,2f12.4)
            else if (k .gt. maxclass) then
               write (iout,80)  maxclass
   80          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
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:6) .eq. 'VDWPR ') then
            ia = 0
            ib = 0
            rd = 0.0d0
            ep = 0.0d0
            string = record(next:80)
            read (string,*,err=120,end=120)  ia,ib,rd,ep
            if (header) then
               header = .false.
               write (iout,90)
   90          format (/,' Additional van der Waals Parameters for',
     &                    ' Specific Pairs :',
     &                 //,6x,'Classes',5x,'Radii Sum',3x,'Epsilon',/)
            end if
            write (iout,100)  ia,ib,rd,ep
  100       format (3x,2i4,2x,2f12.4)
            size = 3
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            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 120
               end if
            end do
            write (iout,110)
  110       format (/,' KVDW  --  Too many Special VDW Pair',
     &                 ' Parameters')
            abort = .true.
  120       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:80)
            read (string,*,err=160,end=160)  ia,ib,rd,ep
            if (header) then
               header = .false.
               write (iout,130)
  130          format (/,' Additional van der Waals Hydrogen Bonding',
     &                    ' Parameters :',
     &                 //,6x,'Classes',5x,'Radii Sum',3x,'Epsilon',/)
            end if
            write (iout,140)  ia,ib,rd,ep
  140       format (3x,2i4,2x,2f12.4)
            size = 3
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            if (ia .le. ib) then
               pt = pa//pb
            else
               pt = pb//pa
            end if
            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 160
               end if
            end do
            write (iout,150)
  150       format (/,' KVDW  --  Too many Hydrogen Bonding Pair',
     &                 ' Parameters')
            abort = .true.
  160       continue
         end if
      end do
c
c     get the vdw radii and well depths for each atom class
c
      do i = 1, maxclass
         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     use combination rules to set pairwise vdw radii sums
c
      do i = 1, maxclass
         do k = i, maxclass
            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(i,k) = rd
            radmin(k,i) = rd
         end do
      end do
c
c     use combination rules to set pairwise well depths
c
      do i = 1, maxclass
         do k = i, maxclass
            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
               ep = seps(i) * seps(k)
            end if
            epsilon(i,k) = ep
            epsilon(k,i) = ep
         end do
      end do
c
c     use combination rules to set pairwise 1-4 vdw radii sums
c
      do i = 1, maxclass
         do k = i, maxclass
            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(i,k) = rd
            radmin4(k,i) = rd
         end do
      end do
c
c     use combination rules to set pairwise 1-4 well depths
c
      do i = 1, maxclass
         do k = i, maxclass
            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
               ep = seps4(i) * seps4(k)
            end if
            epsilon4(i,k) = ep
            epsilon4(k,i) = ep
         end do
      end do
c
c     vdw reduction factor information for each individual atom
c
      do i = 1, n
         kred(i) = reduct(class(i))
         if (n12(i).ne.1 .or. kred(i).eq.0.0d0) then
            ired(i) = i
         else
            ired(i) = i12(1,i)
         end if
      end do
c
c     radii and well depths for special atom class pairs
c
      do i = 1, maxnvp
         if (kvpr(i) .eq. blank)  goto 170
         ia = number (kvpr(i)(1:3))
         ib = number (kvpr(i)(4:6))
         if (rad(ia) .eq. 0.0d0)  rad(ia) = 0.001d0
         if (rad(ib) .eq. 0.0d0)  rad(ib) = 0.001d0
         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 do
  170 continue
c
c     radii and well depths for hydrogen bonding pairs
c
      if (vdwtyp .eq. 'MM3-HBOND') then
         do i = 1, maxclass
            do k = 1, maxclass
               radhbnd(k,i) = 0.0d0
               epshbnd(k,i) = 0.0d0
            end do
         end do
         do i = 1, maxnhb
            if (khb(i) .eq. blank)  goto 180
            ia = number (khb(i)(1:3))
            ib = number (khb(i)(4:6))
            if (rad(ia) .eq. 0.0d0)  rad(ia) = 0.001d0
            if (rad(ib) .eq. 0.0d0)  rad(ib) = 0.001d0
            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 do
  180    continue
      end if
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 (rad(class(i)) .ne. 0.0d0) then
            nvdw = nvdw + 1
            ivdw(nvdw) = i
         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)  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
      implicit none
      include 'sizes.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      real*8 alpha_cos
      real*8 ar1,ar2,ar3
      real*8 br1,br2,br3
      real*8 cr1,cr2,cr3
c
c
c     only necessary if periodic boundaries are in use
c
      if (.not. use_bounds)  return
c
c     set the half width values for the periodic box
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 to those of unitcell
c
      xcell = xbox
      ycell = ybox
      zcell = zbox
      xcell2 = xbox2
      ycell2 = ybox2
      zcell2 = zbox2
c
c     get values needed for fractional coordinate computations
c
      if (orthogonal .or. octahedron) then
         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
      else if (monoclinic) then
         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 if (triclinic) then
         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(1.0d0 - beta_cos**2 - beta_term**2)
      end if
c
c     determine the volume of the periodic box
c
      if (orthogonal) then
         volbox = xbox * ybox * zbox
      else if (monoclinic) then
         volbox = beta_sin * xbox * ybox * zbox
      else if (triclinic) then
         volbox = (gamma_sin*gamma_term) * xbox * ybox * zbox
      else if (octahedron) then
         volbox = 0.5d0 * xbox * ybox * zbox
      end if
c
c     place the reciprocal lattice vectors into columns
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
      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
      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" is 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
      subroutine lbfgs (nvar,x,minimum,grdmin,fgvalue,writeout)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'linmin.i'
      include 'math.i'
      include 'minima.i'
      include 'output.i'
      include 'scales.i'
      integer maxsav
      parameter (maxsav=15)
      integer i,j,k,nvar
      integer msav,muse
      integer npt,pt,cp
      integer niter,ncalls
      integer nerror,next
      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
      real*8 step,beta
      real*8 yp,pq,yr,yy
      real*8 x(maxvar)
      real*8 x_old(maxvar)
      real*8 g(maxvar)
      real*8 g_old(maxvar)
      real*8 diag(maxvar)
      real*8 p(maxsav*maxvar)
      real*8 y(maxsav*maxvar)
      real*8 w(maxvar+2*maxsav)
      logical done
      character*9 blank,status
      character*20 keyword
      character*80 record
      external fgvalue,writeout
c
c
c     initialize some values to be used below
c
      if (nvar .gt. maxvar) then
         write (iout,10)
   10    format (/,' LBFGS  --  Too many Parameters,',
     &              ' Increase value of MAXVAR')
         return
      end if
      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.
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,maxsav)
      if (fctmin .eq. 0.0d0)  fctmin = -1000000.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 (cappa .eq. 0.0d0)  cappa = 0.9d0
      if (stpmin .eq. 0.0d0)  stpmin = 1.0d-16
      if (stpmax .eq. 0.0d0)  stpmax = 5.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)
         if (keyword(1:14) .eq. 'LBFGS-VECTORS ') then
            read (record(next:80),*,err=20)  msav
         else if (keyword(1:7) .eq. 'FCTMIN ') then
            read (record(next:80),*,err=20)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (record(next:80),*,err=20)  maxiter
         else if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (record(next:80),*,err=20)  iprint
         else if (keyword(1:9) .eq. 'WRITEOUT ') then
            read (record(next:80),*,err=20)  iwrite
         else if (keyword(1:8) .eq. 'STEPMAX ') then
            read (record(next:80),*,err=20)  stpmax
         else if (keyword(1:8) .eq. 'STEPMIN ') then
            read (record(next:80),*,err=20)  stpmin
         else if (keyword(1:6) .eq. 'CAPPA ') then
            read (record(next:80),*,err=20)  cappa
         else if (keyword(1:7) .eq. 'ANGMAX ') then
            read (record(next:80),*,err=20)  angmax
         else if (keyword(1:7) .eq. 'INTMAX ') then
            read (record(next:80),*,err=20)  intmax
         end if
   20    continue
      end do
c
c     check the number of saved correction vectors
c
      if (msav.le.0 .or. msav.gt.min(nvar,maxsav)) then
         msav = min(nvar,maxsav)
         write (iout,30)  msav
   30    format (/,' LBFGS  --  Number of Saved Vectors Set to',
     &              ' the Maximum of',i5)
      end if
c
c     evaluate the function and get the initial gradient
c
      niter = nextiter - 1
      maxiter = niter + maxiter
      ncalls = ncalls + 1
      nerror = 0
      pt = 0
      f = fgvalue (x,g)
      f_old = f
      g_rms = 0.0d0
      do i = 1, nvar
         x_old(i) = x(i)
         g_rms = g_rms + (g(i)*scale(i))**2
      end do
      g_rms = sqrt(g_rms) / rms
c
c     print header information prior to first iteration
c
      if (iprint .gt. 0) then
         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',/)
         if (f.lt.1.0d7 .and. f.gt.-1.0d6 .and. g_rms.lt.1.0d5) then
            write (iout,60)  niter,f,g_rms,ncalls
   60       format (i6,f13.4,f11.4,30x,i7)
         else
            write (iout,70)  niter,f,g_rms,ncalls
   70       format (i6,d13.4,d11.4,30x,i7)
         end if
      end if
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
      dowhile (.not. done)
         niter = niter + 1
         muse = min(niter-1,msav)
         step = 1.0d0
c
c     estimate an appropriate stepsize for the first iteration
c
         if (niter .eq. 1) then
            g_norm = 0.0d0
            do i = 1, nvar
               diag(i) = 1.0d0
               p(i) = -g(i) * diag(i)
               g_norm = g_norm + g(i)*g(i)
            end do
            g_norm = sqrt(g_norm)
            step = 1.0d0 / g_norm
            f_move = 0.0d0
            do i = 1, nvar
               f_move = f_move + g(i)**2
            end do
            f_move = 0.5d0 * stpmax * sqrt(f_move)
c
c     compute -Hg, diagonal scaling vector and search direction
c
         else
            do i = 1, nvar
               diag(i) = yp / yy
               if (diag(i) .le. 0.0d0)  diag(i) = -diag(i)
            end do
            cp = pt
            if (pt .eq. 0)  cp = msav
            w(nvar+cp) = 1.0d0 / yp
            do i = 1, nvar
               w(i) = -g(i)
            end do
            cp = pt
            do k = 1, muse
               cp = cp - 1
               if (cp .eq. -1)  cp = msav - 1
               pq = 0.0d0
               do i = 1, nvar
                  pq = pq + p(cp*nvar+i)*w(i)
               end do
               j = nvar + cp + 1
               w(j+msav) = w(j) * pq
               do i = 1, nvar
                  w(i) = w(i) - w(j+msav)*y(cp*nvar+i)
               end do
            end do
            do i = 1, nvar
               w(i) = diag(i) * w(i)
            end do
            do k = 1, muse
               yr = 0.0d0
               do i = 1, nvar
                  yr = yr + y(cp*nvar+i)*w(i)
               end do
               j = nvar + cp + 1
               beta = w(j) * yr
               do i = 1, nvar
                  w(i) = w(i) + p(cp*nvar+i)*(w(j+msav)-beta)
               end do
               cp = cp + 1
               if (cp .eq. msav)  cp = 0
            end do
            do i = 1, nvar
               p(pt*nvar+i) = w(i)
            end do
         end if
c
c     store the gradient prior to the line search
c
         do i = 1, nvar
            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,x,p(pt*nvar+1),f_move,angle,
     &                      ncalls,fgvalue,status)
c
c     update variables based on results of this iteration
c
         yp = 0.0d0
         yy = 0.0d0
         npt = pt * nvar
         do i = 1, nvar
            k = npt + i
            p(k) = step * p(k)
            y(k) = g(i) - g_old(i)
            yp = yp + y(k)*p(k)
            yy = yy + y(k)*y(k)
         end do
         pt = pt + 1
         if (pt .eq. msav)  pt = 0
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 + ((x(i)-x_old(i))/scale(i))**2
            x_old(i) = x(i)
         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
            nerror = nerror + 1
            if (nerror .eq. 2)  done = .true.
         else
            nerror = 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 every few iterations
c
         if (iprint .gt. 0) then
            if (done .or. mod(niter,iprint).eq.0) then
               if (f.lt.1.0d7 .and. f.gt.-1.0d6 .and.
     &             g_rms.lt.1.0d5 .and. f_move.lt.1.0d5) then
                  write (iout,80)  niter,f,g_rms,f_move,x_move,
     &                             angle,ncalls,status
   80             format (i6,f13.4,f11.4,f11.4,f10.4,f9.2,i7,3x,a9)
               else
                  write (iout,90)  niter,f,g_rms,f_move,x_move,
     &                             angle,ncalls,status
   90             format (i6,d13.4,d11.4,d11.4,f10.4,f9.2,i7,3x,a9)
               end if
            end if
         end if
c
c     write intermediate results every few iterations
c
         if (iwrite .gt. 0) then
            if (done .or. mod(niter,iwrite).eq.0) then
               call writeout (x,niter)
            end if
         end if
      end do
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
      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 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     literature reference:
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
      subroutine lights (nsite,map,xsort,ysort,zsort)
      implicit none
      include 'sizes.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'iounit.i'
      include 'light.i'
      include 'shunt.i'
      integer i,j,k,nsite
      integer map(maxlight)
      real*8 box,xcut,ycut,zcut
      real*8 xmove,ymove,zmove
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
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  --  Cutoff Distance is Too Large',
     &                 ' for Method of Lights')
            call fatal
         end if
      end if
c
c     truncated octahedron periodicity is not handled at present
c
      if (use_bounds) then
         if (octahedron) then
            write (iout,20)
   20       format (/,' LIGHTS  --  Method of Lights not available',
     &                 ' for Truncated Octahedron')
            call fatal
         end if
      end if
c
c     when using images, move coordinates into periodic cell
c
      if (use_image) then
         do i = 1, nsite
            zsort(i) = zsort(i) / gamma_term
            ysort(i) = (ysort(i) - zsort(i)*beta_term) / gamma_sin
            xsort(i) = xsort(i) - ysort(i)*gamma_cos - zsort(i)*beta_cos
            dowhile (xsort(i) .gt. xcell2)
               xsort(i) = xsort(i) - xcell
            end do
            dowhile (xsort(i) .lt. -xcell2)
               xsort(i) = xsort(i) + xcell
            end do
            dowhile (ysort(i) .gt. ycell2)
               ysort(i) = ysort(i) - ycell
            end do
            dowhile (ysort(i) .lt. -ycell2)
               ysort(i) = ysort(i) + ycell
            end do
            dowhile (zsort(i) .gt. zcell2)
               zsort(i) = zsort(i) - zcell
            end do
            dowhile (zsort(i) .lt. -zcell2)
               zsort(i) = zsort(i) + zcell
            end do
         end do
      end if
c
c     generate replica coordinates for the sort arrays
c
      if (use_replica) then
         k = nsite
         do j = 1, ncell
            xmove = icell(1,j) * xbox
            ymove = icell(2,j) * ybox
            zmove = icell(3,j) * zbox
            do i = 1, nsite
               k = k + 1
               map(k) = i
               xsort(k) = xsort(i) + xmove
               ysort(k) = ysort(i) + ymove
               zsort(k) = zsort(i) + zmove
               dowhile (xsort(k) .gt. xcell2)
                  xsort(k) = xsort(k) - xcell
               end do
               dowhile (xsort(k) .lt. -xcell2)
                  xsort(k) = xsort(k) + xcell
               end do
               dowhile (ysort(k) .gt. ycell2)
                  ysort(k) = ysort(k) - ycell
               end do
               dowhile (ysort(k) .lt. -ycell2)
                  ysort(k) = ysort(k) + ycell
               end do
               dowhile (zsort(k) .gt. zcell2)
                  zsort(k) = zsort(k) - zcell
               end do
               dowhile (zsort(k) .lt. -zcell2)
                  zsort(k) = zsort(k) + zcell
               end do
            end do
         end do
      end if
c
c     map image and replicate sites onto their parent sites
c
      nlight = (ncell+1) * nsite
      do i = 0, ncell
         j = i * nsite
         do k = 1, nsite
            map(j+k) = k
         end do
      end do
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     set the light width based on interaction cutoff
c
      xcut = off
      ycut = off
      zcut = off
      if (use_image) then
         if (monoclinic) then
            zcut = zcut / beta_sin
            xcut = xcut + zcut*abs(beta_cos)
         else if (triclinic) then
            zcut = zcut / gamma_term
            ycut = (ycut + zcut*abs(beta_term)) / gamma_sin
            xcut = xcut + ycut*abs(gamma_cos) + zcut*abs(beta_cos)
         end if
         xcut = min(xcut,xcell2)
         ycut = min(ycut,ycell2)
         zcut = min(zcut,zcell2)
      end if
c
c     find the negative x-coordinate boundary for each atom
c
      do i = nlight, 1, -1
         k = locx(i)
         if (k .le. nsite) then
            kbx(k) = i
         end if
      end do
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
            dowhile (xsort(j)-xsort(i)+box .lt. xcut)
               if (j .eq. nlight) then
                  if (use_image) then
                     j = 0
                     box = xcell
                  end if
               end if
               j = j + 1
               if (j .gt. nlight)  goto 30
            end do
   30       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
            dowhile (ysort(i)-ysort(j)+box .le. ycut)
               if (j .eq. 1) then
                  if (use_image) then
                     j = nlight + 1
                     box = ycell
                  end if
               end if
               j = j - 1
               if (j .lt. 1)  goto 40
            end do
   40       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
            dowhile (ysort(j)-ysort(i)+box .lt. ycut)
               if (j .eq. nlight) then
                  if (use_image) then
                     j = 0
                     box = ycell
                  end if
               end if
               j = j + 1
               if (j .gt. nlight)  goto 50
            end do
   50       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
            dowhile (zsort(i)-zsort(j)+box .le. zcut)
               if (j .eq. 1) then
                  if (use_image) then
                     j = nlight + 1
                     box = zcell
                  end if
               end if
               j = j - 1
               if (j .lt. 1)  goto 60
            end do
   60       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
            dowhile (zsort(j)-zsort(i)+box .lt. zcut)
               if (j .eq. nlight) then
                  if (use_image) then
                     j = 0
                     box = zcell
                  end if
               end if
               j = j + 1
               if (j .gt. nlight)  goto 70
            end do
   70       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)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
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,length
      integer code,ichar
      character*1 char
      character*(*) string
c
c
c     convert upper case to lower case letters one at a time
c
      length = len(string)
      do i = 1, length
         code = ichar(string(i:i))
         if (code.ge.65 .and. code.le.90)
     &      string(i:i) = char(code+32)
      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 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      include 'math.i'
      include 'zclose.i'
      include 'zcoord.i'
      integer i,j
      integer i1,i2,i3,i4,i5
      integer adjacent,trial
      integer mode,next
      integer iz0(0:maxatm)
      integer iz1(maxatm)
      real*8 geometry,sign
      logical more
      character*1 answer
      character*1 default
      character*8 phrase
      character*80 record
c
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 .ne. 2) then
               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
            else if (mode .eq. 2) then
               i2 = iz(1,i1)
            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 .ne. 2) then
               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
            else if (mode .eq. 2) then
               i3 = iz(2,i1)
            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. 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 (a80)
               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
            else if (mode .eq. 2) then
               if (iz(4,i1) .eq. 0) then
                  answer = 'D'
               else
                  answer = 'B'
               end if
            else if (mode .eq. 3) then
               answer = 'D'
            end if
            if (answer .eq. 'B') then
               if (mode .ne. 2) then
                  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
               else if (mode .eq. 2) then
                  i4 = iz(3,i1)
               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 .ne. 2) then
                  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
               else if (mode .eq. 2) then
                  i4 = iz(3,i1)
               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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'zclose.i'
      integer i,j,k,i1,i2
      integer nc,adjacent,mode
      integer ic(maxval)
      integer iz0(0:maxatm)
      integer iz1(maxatm)
      real*8 dist,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 = 1000000.0d0
            do i = 1, n
               if (iz0(i).ne.0 .and. i.ne.i1 .and. i.ne.i2) then
                  dist = sqrt((x(i)-x(i1))**2 + (y(i)-y(i1))**2
     &                              + (z(i)-z(i1))**2)
                  if (dist .lt. short) then
                     short = dist
                     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)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine makepdb  --  convert Cartesian to PDB format  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "makexyz" converts a set of Cartesian coordinates to Protein
c     Data Bank format with special handling for systems consisting
c     of polypeptide chains, ligands and water molecules
c
c
      subroutine makepdb
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'files.i'
      include 'molcul.i'
      include 'pdb.i'
      include 'resdue.i'
      include 'sequen.i'
      integer i,j,k,m
      integer kp,ka,kn
      integer iseq,freeunit
      integer start,stop
      integer pdbnum,justify
      integer noxy,nhydro,cbi
      integer ni(maxres),cai(maxres)
      integer ci(maxres),oi(maxres)
      integer poi(maxres),c1i(maxres)
      integer c2i(maxres),o2i(maxres)
      integer c3i(maxres),o3i(maxres)
      integer c4i(maxres),o4i(maxres)
      integer c5i(maxres),o5i(maxres)
      integer op1(maxres),op2(maxres)
      integer op3(maxres)
      logical exist,cbone
      logical nbone,obone
      logical water(maxatm)
      logical hetmol(maxatm)
      character*3 resname
      character*4 atmname
      character*7 moltyp
      character*60 seqfile
c
c
c     initialize the mapping between TINKER and PDB atoms
c
      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     assign the molecule type based on sequence information
c
      moltyp = 'GENERIC'
      do i = 1, nseq
         resname = seq(i)
         do j = 1, maxamino
            if (resname .eq. amino(j)) then
               moltyp = 'PEPTIDE'
               goto 10
            end if
         end do
         moltyp = 'GENERIC'
   10    continue
      end do
      if (moltyp .eq. 'GENERIC') then
         do i = 1, nseq
            resname = seq(i)
            do j = 1, maxnuc
               if (resname .eq. nuclz(j)) then
                  moltyp = 'NUCACID'
                  goto 20
               end if
            end do
            moltyp = 'GENERIC'
   20       continue
         end do
      end if
c
c     zero out the backbone atoms for biopolymer sequences
c
      if (moltyp .eq. 'PEPTIDE') then
         do i = 1, nseq
            ni(i) = 0
            cai(i) = 0
            ci(i) = 0
            oi(i) = 0
         end do
      end if
      if (moltyp .eq. 'NUCACID') then
         do i = 1, nseq
            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
      end if
c
c     check each molecule to see if it is a water molecule
c
      do i = 1, nmol
         water(i) = .false.
         if (imol(2,i)-imol(1,i) .eq. 2) then
            noxy = 0
            nhydro = 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)  nhydro = nhydro + 1
            end do
            if (noxy.eq.1 .and. nhydro.eq.2)  water(i) = .true.
         end if
      end do
c
c     for general structures, transfer each atom to PDB format
c
      if (moltyp .eq. '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 pdbatm (atmname,resname,pdbnum,k)
               pdbtyp(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
      if (moltyp .eq. 'PEPTIDE') then
         call attach
         m = 1
         do i = 1, n
            resname = amino(seqtyp(m))
            if (resname .eq. 'FOR') then
               if (atomic(i) .eq. 6) then
                  nbone = .false.
                  obone = .false.
                  do j = 1, n13(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. '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
                  nbone = .false.
                  obone = .false.
                  do j = 1, n14(i)
                     k = i14(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
                     ni(m) = i
                     cai(m) = i + 1
                     ci(m) = i + 2
                     oi(m) = i + 3
                     m = m + 1
                  end if
               end if
            end if
            if (m .gt. nseq)  goto 30
         end do
   30    continue
      end if
c
c     get all the atoms for each peptide residue in order
c
      if (moltyp .eq. 'PEPTIDE') then
         npdb = 0
         do m = 1, nchain
            start = ichain(1,m)
            stop = ichain(2,m)
            do i = start, stop
               resname = amino(seqtyp(i))
               if (resname .eq. 'FOR') then
                  call pdbatm (' C  ',resname,i,ci(i))
                  call pdbatm (' O  ',resname,i,oi(i))
               else if (resname .eq. 'ACE') then
                  call pdbatm (' CH3',resname,i,cai(i))
                  call pdbatm (' C  ',resname,i,ci(i))
                  call pdbatm (' O  ',resname,i,oi(i))
               else if (resname .eq. 'NH2') then
                  call pdbatm (' N  ',resname,i,ni(i))
               else if (resname .eq. 'NME') then
                  call pdbatm (' N  ',resname,i,ni(i))
                  call pdbatm (' CH3',resname,i,cai(i))
               else
                  call pdbatm (' N  ',resname,i,ni(i))
                  call pdbatm (' CA ',resname,i,cai(i))
                  call pdbatm (' C  ',resname,i,ci(i))
                  call pdbatm (' O  ',resname,i,oi(i))
               end if
               call getside (resname,i,ci(i),cai(i),cbi)
               if (resname.eq.'CYS' .or. resname.eq.'CYX') 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 pdbatm (' OXT',resname,i,k)
                        goto 40
                     end if
                  end do
   40             continue
               end if
               call getproh (resname,i,m,ni(i),cai(i),cbi)
            end do
         end do
      end if
c
c     find the phosphates and other nucleotide backbone atoms
c
      if (moltyp .eq. 'NUCACID') then
         call attach
         m = 1
         do i = 1, n
            resname = nuclz(seqtyp(m))
            if (resname .eq. 'MPO') 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 do
         do i = 1, nseq
            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. 'MPO')  poi(i) = 0
               if (resname .eq. 'DPO')  poi(i) = 0
               if (resname .eq. 'TPO')  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
c
c     get all the atoms for each nucleotide residue in order
c
      if (moltyp .eq. 'NUCACID') then
         npdb = 0
         do m = 1, nchain
            start = ichain(1,m)
            stop = ichain(2,m)
            do i = start, stop
               resname = nuclz(seqtyp(i))
               if (resname .eq. 'MPO') then
                  call pdbatm (' P  ',resname,i,poi(i))
                  call pdbatm (' O1P',resname,i,op1(i))
                  call pdbatm (' O2P',resname,i,op2(i))
                  call pdbatm (' O3P',resname,i,op3(i))
               else if (resname .eq. 'DPO') then
               else if (resname .eq. 'TPO') then
               else
                  call pdbatm (' P  ',resname,i,poi(i))
                  call pdbatm (' O1P',resname,i,op1(i))
                  call pdbatm (' O2P',resname,i,op2(i))
                  call pdbatm (' O5*',resname,i,o5i(i))
                  call pdbatm (' C5*',resname,i,c5i(i))
                  call pdbatm (' C4*',resname,i,c4i(i))
                  call pdbatm (' O4*',resname,i,o4i(i))
                  call pdbatm (' C3*',resname,i,c3i(i))
                  call pdbatm (' O3*',resname,i,o3i(i))
                  call pdbatm (' C2*',resname,i,c2i(i))
                  call pdbatm (' O2*',resname,i,o2i(i))
                  call pdbatm (' 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 do
      end if
c
c     get any ligands and waters following biopolymer chains
c
      if (moltyp .ne. '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)
                  atmname = ' '//name(k)
                  if (water(i)) then
                     resname = 'HOH'
                  else
                     justify = 0
                     call numeral (type(k),resname,justify)
                  end if
                  pdbnum = nseq + i - 1
                  call pdbatm (atmname,resname,pdbnum,k)
                  pdbtyp(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
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine pdbatm  --  add a single atom to PDB file  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "pdbatm" adds an atom to the Protein Data Bank file
c
c
      subroutine pdbatm (atmname,resname,ires,icoord)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'pdb.i'
      integer ires,icoord
      character*3 resname
      character*4 atmname
c
c
c     for each atom set the sequential number, record type, atom
c     name, residue name, residue number and atomic coordinates
c
      if (icoord .ne. 0) then
         npdb = npdb + 1
         pdbtyp(npdb) = 'ATOM  '
         atmnam(npdb) = atmname
         resnam(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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      integer i,j,ires
      integer ci,cai,cbi
      character*3 resname
c
c
c     if residue is glycine or a cap, there is no side chain
c
      cbi = 0
      if (resname .eq. 'GLY')  return
      if (resname .eq. 'UNK')  return
      if (resname .eq. 'FOR')  return
      if (resname .eq. 'ACE')  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, n
         if (i.ne.ci .and. atomic(i).eq.6) then
            do j = 1, 4
               if (i12(j,i) .eq. cai) then
                  cbi = i
                  if (resname .ne. 'AIB') then
                     call pdbatm (' CB ',resname,ires,cbi)
                  else
                     call pdbatm (' CB1',resname,ires,cbi)
                  end if
                  goto 10
               end if
            end do
         end if
      end do
   10 continue
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 pdbatm (' CG1',resname,ires,cbi+1)
         call pdbatm (' CG2',resname,ires,cbi+2)
c
c     leucine residue  (LEU)
c
      else if (resname .eq. 'LEU') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD1',resname,ires,cbi+2)
         call pdbatm (' CD2',resname,ires,cbi+3)
c
c     isoleucine residue  (ILE)
c
      else if (resname .eq. 'ILE') then
         call pdbatm (' CG1',resname,ires,cbi+1)
         call pdbatm (' CG2',resname,ires,cbi+2)
         call pdbatm (' CD1',resname,ires,cbi+3)
c
c     serine residue  (SER)
c
      else if (resname .eq. 'SER') then
         call pdbatm (' OG ',resname,ires,cbi+1)
c
c     threonine residue  (THR)
c
      else if (resname .eq. 'THR') then
         call pdbatm (' OG1',resname,ires,cbi+1)
         call pdbatm (' CG2',resname,ires,cbi+2)
c
c     cysteine residue  (CYS)
c
      else if (resname .eq. 'CYS') then
         call pdbatm (' SG ',resname,ires,cbi+1)
c
c     cysteine residue  (CYX)
c
      else if (resname .eq. 'CYX') then
         call pdbatm (' SG ',resname,ires,cbi+1)
c
c     proline residue  (PRO)
c
      else if (resname .eq. 'PRO') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD ',resname,ires,cbi+2)
c
c     phenylalanine residue  (PHE)
c
      else if (resname .eq. 'PHE') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD1',resname,ires,cbi+2)
         call pdbatm (' CD2',resname,ires,cbi+3)
         call pdbatm (' CE1',resname,ires,cbi+4)
         call pdbatm (' CE2',resname,ires,cbi+5)
         call pdbatm (' CZ ',resname,ires,cbi+6)
c
c     tyrosine residue  (TYR)
c
      else if (resname .eq. 'TYR') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD1',resname,ires,cbi+2)
         call pdbatm (' CD2',resname,ires,cbi+3)
         call pdbatm (' CE1',resname,ires,cbi+4)
         call pdbatm (' CE2',resname,ires,cbi+5)
         call pdbatm (' CZ ',resname,ires,cbi+6)
         call pdbatm (' OH ',resname,ires,cbi+7)
c
c     tryptophan residue  (TRP)
c
      else if (resname .eq. 'TRP') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD1',resname,ires,cbi+2)
         call pdbatm (' CD2',resname,ires,cbi+3)
         call pdbatm (' NE1',resname,ires,cbi+4)
         call pdbatm (' CE2',resname,ires,cbi+5)
         call pdbatm (' CE3',resname,ires,cbi+6)
         call pdbatm (' CZ2',resname,ires,cbi+7)
         call pdbatm (' CZ3',resname,ires,cbi+8)
         call pdbatm (' CH2',resname,ires,cbi+9)
c
c     histidine (HD and HE) residue  (HIS)
c
      else if (resname .eq. 'HIS') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' ND1',resname,ires,cbi+2)
         call pdbatm (' CD2',resname,ires,cbi+3)
         call pdbatm (' CE1',resname,ires,cbi+4)
         call pdbatm (' NE2',resname,ires,cbi+5)
c
c     histidine (HD only) residue  (HID)
c
      else if (resname .eq. 'HID') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' ND1',resname,ires,cbi+2)
         call pdbatm (' CD2',resname,ires,cbi+3)
         call pdbatm (' CE1',resname,ires,cbi+4)
         call pdbatm (' NE2',resname,ires,cbi+5)
c
c     histidine (HE only) residue  (HIE)
c
      else if (resname .eq. 'HIE') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' ND1',resname,ires,cbi+2)
         call pdbatm (' CD2',resname,ires,cbi+3)
         call pdbatm (' CE1',resname,ires,cbi+4)
         call pdbatm (' NE2',resname,ires,cbi+5)
c
c     aspartic acid residue  (ASP)
c
      else if (resname .eq. 'ASP') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' OD1',resname,ires,cbi+2)
         call pdbatm (' OD2',resname,ires,cbi+3)
c
c     asparagine residue  (ASN)
c
      else if (resname .eq. 'ASN') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' OD1',resname,ires,cbi+2)
         call pdbatm (' ND2',resname,ires,cbi+3)
c
c     glutamic acid residue  (GLU)
c
      else if (resname .eq. 'GLU') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD ',resname,ires,cbi+2)
         call pdbatm (' OE1',resname,ires,cbi+3)
         call pdbatm (' OE2',resname,ires,cbi+4)
c
c     glutamine residue  (GLN)
c
      else if (resname .eq. 'GLN') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD ',resname,ires,cbi+2)
         call pdbatm (' OE1',resname,ires,cbi+3)
         call pdbatm (' NE2',resname,ires,cbi+4)
c
c     methionine residue  (MET)
c
      else if (resname .eq. 'MET') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' SD ',resname,ires,cbi+2)
         call pdbatm (' CE ',resname,ires,cbi+3)
c
c     lysine residue  (LYS)
c
      else if (resname .eq. 'LYS') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD ',resname,ires,cbi+2)
         call pdbatm (' CE ',resname,ires,cbi+3)
         call pdbatm (' NZ ',resname,ires,cbi+4)
c
c     arginine residue  (ARG)
c
      else if (resname .eq. 'ARG') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD ',resname,ires,cbi+2)
         call pdbatm (' NE ',resname,ires,cbi+3)
         call pdbatm (' CZ ',resname,ires,cbi+4)
         call pdbatm (' NH1',resname,ires,cbi+5)
         call pdbatm (' NH2',resname,ires,cbi+6)
c
c     ornithine residue  (ORN)
c
      else if (resname .eq. 'ORN') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD ',resname,ires,cbi+2)
         call pdbatm (' NE ',resname,ires,cbi+3)
c
c     methylalanine residue  (AIB)
c
      else if (resname .eq. 'AIB') then
         call pdbatm (' CB2',resname,ires,cbi+1)
c
c     pyroglutamic acid residue  (PCA)
c
      else if (resname .eq. 'PCA') then
         call pdbatm (' CG ',resname,ires,cbi+1)
         call pdbatm (' CD ',resname,ires,cbi+2)
         call pdbatm (' 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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'sequen.i'
      integer i,nh,hca
      integer ires,jchain
      integer ni,cai,cbi
      character*3 resname
      character*4 atmname
      logical allatom
c
c
c     get any amide hydrogen atoms for non-N-terminal residues
c
      if (ires .ne. ichain(1,jchain)) 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. 'NH2') then
                     call pdbatm ('1H  ',resname,ires,i)
                     call pdbatm ('2H  ',resname,ires,i+1)
                  else
                     call pdbatm (' 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
            nh = 0
            do i = 1, n
               if (atomic(i).eq.1 .and. i12(1,i).eq.ni) then
                  nh = nh + 1
                  if (nh .eq. 1) then
                     atmname = '1H  '
                  else if (nh .eq. 2) then
                     atmname = '2H  '
                  end if
                  call pdbatm (atmname,resname,ires,i)
                  if (nh .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 pdbatm (atmname,resname,ires,i)
                  goto 10
               end if
            end do
         else
            nh = 0
            do i = 1, n
               if (atomic(i).eq.1 .and. i12(1,i).eq.ni) then
                  nh = nh + 1
                  if (nh .eq. 1) then
                     atmname = '1H  '
                  else if (nh .eq. 2) then
                     atmname = '2H  '
                  else if (nh .eq. 3) then
                     atmname = '3H  '
                  end if
                  call pdbatm (atmname,resname,ires,i)
                  if (nh .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 = '1HA '
            else if (resname .eq. 'FOR') then
               atmname = ' H  '
            else if (resname .eq. 'ACE') then
               atmname = '1H  '
            else if (resname .eq. 'NME') then
               atmname = '1H  '
            else
               atmname = ' HA '
            end if
            call pdbatm (atmname,resname,ires,i)
            goto 20
         end if
      end do
   20 continue
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 pdbatm ('2HA ',resname,ires,hca+1)
         end if
c
c     alanine residue  (ALA)
c
      else if (resname .eq. 'ALA') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+2)
            call pdbatm ('2HB ',resname,ires,hca+3)
            call pdbatm ('3HB ',resname,ires,hca+4)
         end if
c
c     valine residue  (VAL)
c
      else if (resname .eq. 'VAL') then
         if (allatom) then
            call pdbatm (' HB ',resname,ires,hca+4)
            call pdbatm ('1HG1',resname,ires,hca+5)
            call pdbatm ('2HG1',resname,ires,hca+6)
            call pdbatm ('3HG1',resname,ires,hca+7)
            call pdbatm ('1HG2',resname,ires,hca+8)
            call pdbatm ('2HG2',resname,ires,hca+9)
            call pdbatm ('3HG2',resname,ires,hca+10)
         end if
c
c     leucine residue  (LEU)
c
      else if (resname .eq. 'LEU') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+5)
            call pdbatm ('2HB ',resname,ires,hca+6)
            call pdbatm (' HG ',resname,ires,hca+7)
            call pdbatm ('1HD1',resname,ires,hca+8)
            call pdbatm ('2HD1',resname,ires,hca+9)
            call pdbatm ('3HD1',resname,ires,hca+10)
            call pdbatm ('1HD2',resname,ires,hca+11)
            call pdbatm ('2HD2',resname,ires,hca+12)
            call pdbatm ('3HD2',resname,ires,hca+13)
         end if
c
c     isoleucine residue  (ILE)
c
      else if (resname .eq. 'ILE') then
         if (allatom) then
            call pdbatm (' HB ',resname,ires,hca+5)
            call pdbatm ('1HG1',resname,ires,hca+6)
            call pdbatm ('2HG1',resname,ires,hca+7)
            call pdbatm ('1HG2',resname,ires,hca+8)
            call pdbatm ('2HG2',resname,ires,hca+9)
            call pdbatm ('3HG2',resname,ires,hca+10)
            call pdbatm ('1HD1',resname,ires,hca+11)
            call pdbatm ('2HD1',resname,ires,hca+12)
            call pdbatm ('3HD1',resname,ires,hca+13)
         end if
c
c     serine residue  (SER)
c
      else if (resname .eq. 'SER') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+3)
            call pdbatm ('2HB ',resname,ires,hca+4)
            call pdbatm (' HG ',resname,ires,hca+5)
         else
            call pdbatm (' HG ',resname,ires,cbi+2)
         end if
c
c     threonine residue  (THR)
c
      else if (resname .eq. 'THR') then
         if (allatom) then
            call pdbatm (' HB ',resname,ires,hca+4)
            call pdbatm ('1HG ',resname,ires,hca+5)
            call pdbatm ('1HG2',resname,ires,hca+6)
            call pdbatm ('2HG2',resname,ires,hca+7)
            call pdbatm ('3HG2',resname,ires,hca+8)
         else
            call pdbatm ('1HG ',resname,ires,cbi+3)
         end if
c
c     cysteine residue  (CYS)
c
      else if (resname .eq. 'CYS') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+3)
            call pdbatm ('2HB ',resname,ires,hca+4)
            call pdbatm (' HG ',resname,ires,hca+5)
         else
            call pdbatm (' HG ',resname,ires,cbi+2)
         end if
c
c     cystine residue  (CYX)
c
      else if (resname .eq. 'CYX') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+3)
            call pdbatm ('2HB ',resname,ires,hca+4)
         end if
c
c     proline residue  (PRO)
c
      else if (resname .eq. 'PRO') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+4)
            call pdbatm ('2HB ',resname,ires,hca+5)
            call pdbatm ('1HG ',resname,ires,hca+6)
            call pdbatm ('2HG ',resname,ires,hca+7)
            call pdbatm ('1HD ',resname,ires,hca+8)
            call pdbatm ('2HD ',resname,ires,hca+9)
         end if
c
c     phenylalanine residue  (PHE)
c
      else if (resname .eq. 'PHE') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+8)
            call pdbatm ('2HB ',resname,ires,hca+9)
            call pdbatm (' HD1',resname,ires,hca+10)
            call pdbatm (' HD2',resname,ires,hca+11)
            call pdbatm (' HE1',resname,ires,hca+12)
            call pdbatm (' HE2',resname,ires,hca+13)
            call pdbatm (' HZ ',resname,ires,hca+14)
         end if
c
c     tyrosine residue  (TYR)
c
      else if (resname .eq. 'TYR') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+9)
            call pdbatm ('2HB ',resname,ires,hca+10)
            call pdbatm (' HD1',resname,ires,hca+11)
            call pdbatm (' HD2',resname,ires,hca+12)
            call pdbatm (' HE1',resname,ires,hca+13)
            call pdbatm (' HE2',resname,ires,hca+14)
            call pdbatm (' HH ',resname,ires,hca+15)
         else
            call pdbatm (' HH ',resname,ires,cbi+12)
         end if
c
c     tryptophan residue  (TRP)
c
      else if (resname .eq. 'TRP') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+11)
            call pdbatm ('2HB ',resname,ires,hca+12)
            call pdbatm (' HD1',resname,ires,hca+13)
            call pdbatm (' HE1',resname,ires,hca+14)
            call pdbatm (' HE3',resname,ires,hca+15)
            call pdbatm (' HZ2',resname,ires,hca+16)
            call pdbatm (' HZ3',resname,ires,hca+17)
            call pdbatm (' HH2',resname,ires,hca+18)
         else
            call pdbatm (' HE1',resname,ires,cbi+18)
         end if
c
c     histidine (HD and HE) residue  (HIS)
c
      else if (resname .eq. 'HIS') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+7)
            call pdbatm ('2HB ',resname,ires,hca+8)
            call pdbatm (' HD1',resname,ires,hca+9)
            call pdbatm (' HD2',resname,ires,hca+10)
            call pdbatm (' HE1',resname,ires,hca+11)
            call pdbatm (' HE2',resname,ires,hca+12)
         else
            call pdbatm (' HD1',resname,ires,cbi+6)
            call pdbatm (' HE2',resname,ires,cbi+9)
         end if
c
c     histidine (HD only) residue  (HID)
c
      else if (resname .eq. 'HID') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+7)
            call pdbatm ('2HB ',resname,ires,hca+8)
            call pdbatm (' HD1',resname,ires,hca+9)
            call pdbatm (' HD2',resname,ires,hca+10)
            call pdbatm (' HE1',resname,ires,hca+11)
         else
            call pdbatm (' 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 pdbatm ('1HB ',resname,ires,hca+7)
            call pdbatm ('2HB ',resname,ires,hca+8)
            call pdbatm (' HD2',resname,ires,hca+9)
            call pdbatm (' HE1',resname,ires,hca+10)
            call pdbatm (' HE2',resname,ires,hca+11)
         else
            call pdbatm (' HE2',resname,ires,cbi+8)
         end if
c
c     aspartic acid residue  (ASP)
c
      else if (resname .eq. 'ASP') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+5)
            call pdbatm ('2HB ',resname,ires,hca+6)
         end if
c
c     asparagine residue  (ASN)
c
      else if (resname .eq. 'ASN') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+5)
            call pdbatm ('2HB ',resname,ires,hca+6)
            call pdbatm ('1HD2',resname,ires,hca+7)
            call pdbatm ('2HD2',resname,ires,hca+8)
         else
            call pdbatm ('1HD2',resname,ires,cbi+4)
            call pdbatm ('2HD2',resname,ires,cbi+5)
         end if
c
c     glutamic acid residue  (GLU)
c
      else if (resname .eq. 'GLU') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+6)
            call pdbatm ('2HB ',resname,ires,hca+7)
            call pdbatm ('1HG ',resname,ires,hca+8)
            call pdbatm ('2HG ',resname,ires,hca+9)
         end if
c
c     glutamine residue  (GLN)
c
      else if (resname .eq. 'GLN') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+6)
            call pdbatm ('2HB ',resname,ires,hca+7)
            call pdbatm ('1HG ',resname,ires,hca+8)
            call pdbatm ('2HG ',resname,ires,hca+9)
            call pdbatm ('1HE2',resname,ires,hca+10)
            call pdbatm ('2HE2',resname,ires,hca+11)
         else
            call pdbatm ('1HE2',resname,ires,cbi+5)
            call pdbatm ('2HE2',resname,ires,cbi+6)
         end if
c
c     methionine residue  (MET)
c
      else if (resname .eq. 'MET') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+5)
            call pdbatm ('2HB ',resname,ires,hca+6)
            call pdbatm ('1HG ',resname,ires,hca+7)
            call pdbatm ('2HG ',resname,ires,hca+8)
            call pdbatm ('1HE ',resname,ires,hca+9)
            call pdbatm ('2HE ',resname,ires,hca+10)
            call pdbatm ('3HE ',resname,ires,hca+11)
         end if
c
c     lysine residue  (LYS)
c
      else if (resname .eq. 'LYS') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+6)
            call pdbatm ('2HB ',resname,ires,hca+7)
            call pdbatm ('1HG ',resname,ires,hca+8)
            call pdbatm ('2HG ',resname,ires,hca+9)
            call pdbatm ('1HD ',resname,ires,hca+10)
            call pdbatm ('2HD ',resname,ires,hca+11)
            call pdbatm ('1HE ',resname,ires,hca+12)
            call pdbatm ('2HE ',resname,ires,hca+13)
            call pdbatm ('1HZ ',resname,ires,hca+14)
            call pdbatm ('2HZ ',resname,ires,hca+15)
            call pdbatm ('3HZ ',resname,ires,hca+16)
         else
            call pdbatm ('1HZ ',resname,ires,cbi+5)
            call pdbatm ('2HZ ',resname,ires,cbi+6)
            call pdbatm ('3HZ ',resname,ires,cbi+7)
         end if
c
c     arginine residue  (ARG)
c
      else if (resname .eq. 'ARG') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+8)
            call pdbatm ('2HB ',resname,ires,hca+9)
            call pdbatm ('1HG ',resname,ires,hca+10)
            call pdbatm ('2HG ',resname,ires,hca+11)
            call pdbatm ('1HD ',resname,ires,hca+12)
            call pdbatm ('2HD ',resname,ires,hca+13)
            call pdbatm (' HE ',resname,ires,hca+14)
            call pdbatm ('1HH1',resname,ires,hca+15)
            call pdbatm ('2HH1',resname,ires,hca+16)
            call pdbatm ('1HH2',resname,ires,hca+17)
            call pdbatm ('2HH2',resname,ires,hca+18)
         else
            call pdbatm (' HE ',resname,ires,cbi+7)
            call pdbatm ('1HH1',resname,ires,cbi+8)
            call pdbatm ('2HH1',resname,ires,cbi+9)
            call pdbatm ('1HH2',resname,ires,cbi+10)
            call pdbatm ('2HH2',resname,ires,cbi+11)
         end if
c
c     ornithine residue  (ORN)
c
      else if (resname .eq. 'ORN') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+5)
            call pdbatm ('2HB ',resname,ires,hca+6)
            call pdbatm ('1HG ',resname,ires,hca+7)
            call pdbatm ('2HG ',resname,ires,hca+8)
            call pdbatm ('1HD ',resname,ires,hca+9)
            call pdbatm ('2HD ',resname,ires,hca+10)
            call pdbatm ('1HE ',resname,ires,hca+11)
            call pdbatm ('2HE ',resname,ires,hca+12)
            call pdbatm ('1HE ',resname,ires,hca+13)
         else
            call pdbatm ('1HE ',resname,ires,cbi+4)
            call pdbatm ('2HE ',resname,ires,cbi+5)
            call pdbatm ('3HE ',resname,ires,cbi+6)
         end if
c
c     methylalanine residue  (AIB)
c
      else if (resname .eq. 'AIB') then
         if (allatom) then
            call pdbatm ('1HB1',resname,ires,cbi+2)
            call pdbatm ('2HB1',resname,ires,cbi+3)
            call pdbatm ('3HB1',resname,ires,cbi+4)
            call pdbatm ('1HB2',resname,ires,cbi+5)
            call pdbatm ('2HB2',resname,ires,cbi+6)
            call pdbatm ('3HB2',resname,ires,cbi+7)
         end if
c
c     pyroglutamic acid residue  (PCA)
c
      else if (resname .eq. 'PCA') then
         if (allatom) then
            call pdbatm ('1HB ',resname,ires,hca+5)
            call pdbatm ('2HB ',resname,ires,hca+6)
            call pdbatm ('1HG ',resname,ires,hca+7)
            call pdbatm ('2HG ',resname,ires,hca+8)
         end if
c
c     unknown residue  (UNK)
c
      else if (resname .eq. 'UNK') then
         if (allatom) then
            call pdbatm ('2HA ',resname,ires,hca+1)
         end if
c
c     N-terminal acetyl residue  (ACE)
c
      else if (resname .eq. 'ACE') then
         if (allatom) then
            call pdbatm ('2H  ',resname,ires,hca+1)
            call pdbatm ('3H  ',resname,ires,hca+2)
         end if
c
c     N-terminal formyl residue  (FOR)
c
      else if (resname .eq. 'FOR') then
         continue
c
c     C-terminal N-methylamide residue  (NME)
c
      else if (resname .eq. 'NME') then
         if (allatom) then
            call pdbatm ('2H  ',resname,ires,hca+1)
            call pdbatm ('3H  ',resname,ires,hca+2)
         end if
c
c     C-terminal amide residue  (NH2)
c
      else if (resname .eq. 'NH2') then
         continue
      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  (ADE)
c
      if (resname .eq. 'ADE') then
         call pdbatm (' N9 ',resname,ires,ni)
         call pdbatm (' C8 ',resname,ires,ni+1)
         call pdbatm (' N7 ',resname,ires,ni+2)
         call pdbatm (' C5 ',resname,ires,ni+3)
         call pdbatm (' C6 ',resname,ires,ni+4)
         call pdbatm (' N6 ',resname,ires,ni+5)
         call pdbatm (' N1 ',resname,ires,ni+6)
         call pdbatm (' C2 ',resname,ires,ni+7)
         call pdbatm (' N3 ',resname,ires,ni+8)
         call pdbatm (' C4 ',resname,ires,ni+9)
c
c     guanine in guanosine residue  (GUA)
c
      else if (resname .eq. 'GUA') then
         call pdbatm (' N9 ',resname,ires,ni)
         call pdbatm (' C8 ',resname,ires,ni+1)
         call pdbatm (' N7 ',resname,ires,ni+2)
         call pdbatm (' C5 ',resname,ires,ni+3)
         call pdbatm (' C6 ',resname,ires,ni+4)
         call pdbatm (' O6 ',resname,ires,ni+5)
         call pdbatm (' N1 ',resname,ires,ni+6)
         call pdbatm (' C2 ',resname,ires,ni+7)
         call pdbatm (' N2 ',resname,ires,ni+8)
         call pdbatm (' N3 ',resname,ires,ni+9)
         call pdbatm (' C4 ',resname,ires,ni+10)
c
c     cytosine in cytidine residue  (CYT)
c
      else if (resname .eq. 'CYT') then
         call pdbatm (' N1 ',resname,ires,ni)
         call pdbatm (' C2 ',resname,ires,ni+1)
         call pdbatm (' O2 ',resname,ires,ni+2)
         call pdbatm (' N3 ',resname,ires,ni+3)
         call pdbatm (' C4 ',resname,ires,ni+4)
         call pdbatm (' N4 ',resname,ires,ni+5)
         call pdbatm (' C5 ',resname,ires,ni+6)
         call pdbatm (' C6 ',resname,ires,ni+7)
c
c     uracil in uridine residue  (URA)
c
      else if (resname .eq. 'URA') then
         call pdbatm (' N1 ',resname,ires,ni)
         call pdbatm (' C2 ',resname,ires,ni+1)
         call pdbatm (' O2 ',resname,ires,ni+2)
         call pdbatm (' N3 ',resname,ires,ni+3)
         call pdbatm (' C4 ',resname,ires,ni+4)
         call pdbatm (' O4 ',resname,ires,ni+5)
         call pdbatm (' C5 ',resname,ires,ni+6)
         call pdbatm (' C6 ',resname,ires,ni+7)
c
c     adenine in deoxyadenosine residue  (DAD)
c
      else if (resname .eq. 'DAD') then
         call pdbatm (' N9 ',resname,ires,ni)
         call pdbatm (' C8 ',resname,ires,ni+1)
         call pdbatm (' N7 ',resname,ires,ni+2)
         call pdbatm (' C5 ',resname,ires,ni+3)
         call pdbatm (' C6 ',resname,ires,ni+4)
         call pdbatm (' N6 ',resname,ires,ni+5)
         call pdbatm (' N1 ',resname,ires,ni+6)
         call pdbatm (' C2 ',resname,ires,ni+7)
         call pdbatm (' N3 ',resname,ires,ni+8)
         call pdbatm (' C4 ',resname,ires,ni+9)
c
c     guanine in deoxyguanosine residue  (DGU)
c
      else if (resname .eq. 'DGU') then
         call pdbatm (' N9 ',resname,ires,ni)
         call pdbatm (' C8 ',resname,ires,ni+1)
         call pdbatm (' N7 ',resname,ires,ni+2)
         call pdbatm (' C5 ',resname,ires,ni+3)
         call pdbatm (' C6 ',resname,ires,ni+4)
         call pdbatm (' O6 ',resname,ires,ni+5)
         call pdbatm (' N1 ',resname,ires,ni+6)
         call pdbatm (' C2 ',resname,ires,ni+7)
         call pdbatm (' N2 ',resname,ires,ni+8)
         call pdbatm (' N3 ',resname,ires,ni+9)
         call pdbatm (' C4 ',resname,ires,ni+10)
c
c     cytosine in deoxycytidine residue  (DCY)
c
      else if (resname .eq. 'DCY') then
         call pdbatm (' N1 ',resname,ires,ni)
         call pdbatm (' C2 ',resname,ires,ni+1)
         call pdbatm (' O2 ',resname,ires,ni+2)
         call pdbatm (' N3 ',resname,ires,ni+3)
         call pdbatm (' C4 ',resname,ires,ni+4)
         call pdbatm (' N4 ',resname,ires,ni+5)
         call pdbatm (' C5 ',resname,ires,ni+6)
         call pdbatm (' C6 ',resname,ires,ni+7)
c
c     thymine in deoxythymidine residue  (THY)
c
      else if (resname .eq. 'THY') then
         call pdbatm (' N1 ',resname,ires,ni)
         call pdbatm (' C2 ',resname,ires,ni+1)
         call pdbatm (' O2 ',resname,ires,ni+2)
         call pdbatm (' N3 ',resname,ires,ni+3)
         call pdbatm (' C4 ',resname,ires,ni+4)
         call pdbatm (' O4 ',resname,ires,ni+5)
         call pdbatm (' C5 ',resname,ires,ni+6)
         call pdbatm (' C5M',resname,ires,ni+7)
         call pdbatm (' 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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'couple.i'
      integer i,k,h1,h2
      integer ires,ni
      integer c1i,c4i
      integer c2i,o2i
      integer c3i,o3i
      integer c5i,o5i
      logical allatom
      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
      h1 = 0
      h2 = 0
      do i = 1, n12(c5i)
         k = i12(i,c5i)
         if (atomic(k).eq.1 .and. h1.eq.0)  h1 = k
         if (atomic(k).eq.1 .and. h1.ne.0)  h2 = k
         call pdbatm ('1H5*',resname,ires,h1)
         call pdbatm ('2H5*',resname,ires,h2)
      end do
      do i = 1, n12(c4i)
         k = i12(i,c4i)
         if (atomic(k) .eq. 1)  call pdbatm (' H4*',resname,ires,k)
      end do
      do i = 1, n12(c3i)
         k = i12(i,c3i)
         if (atomic(k) .eq. 1)  call pdbatm (' H3*',resname,ires,k)
      end do
      h1 = 0
      h2 = 0
      do i = 1, n12(c2i)
         k = i12(i,c2i)
         if (atomic(k).eq.1 .and. h1.eq.0)  h1 = k
         if (atomic(k).eq.1 .and. h1.ne.0)  h2 = k
         call pdbatm ('1H2*',resname,ires,h1)
         call pdbatm ('2H2*',resname,ires,h2)
      end do
      do i = 1, n12(o2i)
         k = i12(i,o2i)
         if (atomic(k) .eq. 1)  call pdbatm ('2HO*',resname,ires,k)
      end do
      do i = 1, n12(c1i)
         k = i12(i,c1i)
         if (atomic(k) .eq. 1)  call pdbatm (' H1*',resname,ires,k)
      end do
c
c     adenine in adenosine residue  (ADE)
c
      if (resname .eq. 'ADE') then
         if (allatom) then
            call pdbatm (' H8 ',resname,ires,ni+10)
            call pdbatm ('1H6 ',resname,ires,ni+11)
            call pdbatm ('2H6 ',resname,ires,ni+12)
            call pdbatm (' H2 ',resname,ires,ni+13)
         else
            call pdbatm ('1H6 ',resname,ires,ni+10)
            call pdbatm ('2H6 ',resname,ires,ni+11)
         end if
c
c     guanine in guanosine residue  (GUA)
c
      else if (resname .eq. 'GUA') then
         if (allatom) then
            call pdbatm (' H8 ',resname,ires,ni+11)
            call pdbatm (' H1 ',resname,ires,ni+12)
            call pdbatm ('1H2 ',resname,ires,ni+13)
            call pdbatm ('2H2 ',resname,ires,ni+14)
         else
            call pdbatm (' H1 ',resname,ires,ni+11)
            call pdbatm ('1H2 ',resname,ires,ni+12)
            call pdbatm ('2H2 ',resname,ires,ni+13)
         end if
c
c     cytosine in cytidine residue  (CYT)
c
      else if (resname .eq. 'CYT') then
         if (allatom) then
            call pdbatm ('1H4 ',resname,ires,ni+8)
            call pdbatm ('2H4 ',resname,ires,ni+9)
            call pdbatm (' H5 ',resname,ires,ni+10)
            call pdbatm (' H6 ',resname,ires,ni+11)
         else
            call pdbatm ('1H4 ',resname,ires,ni+8)
            call pdbatm ('2H4 ',resname,ires,ni+9)
         end if
c
c     uracil in uridine residue  (URA)
c
      else if (resname .eq. 'URA') then
         if (allatom) then
            call pdbatm (' H3 ',resname,ires,ni+8)
            call pdbatm (' H5 ',resname,ires,ni+9)
            call pdbatm (' H6 ',resname,ires,ni+10)
         else
            call pdbatm (' H3 ',resname,ires,ni+8)
         end if
c
c     adenine in deoxyadenosine residue  (DAD)
c
      else if (resname .eq. 'DAD') then
         if (allatom) then
            call pdbatm (' H8 ',resname,ires,ni+10)
            call pdbatm ('1H6 ',resname,ires,ni+11)
            call pdbatm ('2H6 ',resname,ires,ni+12)
            call pdbatm (' H2 ',resname,ires,ni+13)
         else
            call pdbatm ('1H6 ',resname,ires,ni+10)
            call pdbatm ('2H6 ',resname,ires,ni+11)
         end if
c
c     guanine in deoxyguanosine residue  (DGU)
c
      else if (resname .eq. 'DGU') then
         if (allatom) then
            call pdbatm (' H8 ',resname,ires,ni+11)
            call pdbatm (' H1 ',resname,ires,ni+12)
            call pdbatm ('1H2 ',resname,ires,ni+13)
            call pdbatm ('2H2 ',resname,ires,ni+14)
         else
            call pdbatm (' H1 ',resname,ires,ni+11)
            call pdbatm ('1H2 ',resname,ires,ni+12)
            call pdbatm ('2H2 ',resname,ires,ni+13)
         end if
c
c     cytosine in deoxycytidine residue  (DCY)
c
      else if (resname .eq. 'DCY') then
         if (allatom) then
            call pdbatm ('1H4 ',resname,ires,ni+8)
            call pdbatm ('2H4 ',resname,ires,ni+9)
            call pdbatm (' H5 ',resname,ires,ni+10)
            call pdbatm (' H6 ',resname,ires,ni+11)
         else
            call pdbatm ('1H4 ',resname,ires,ni+8)
            call pdbatm ('2H4 ',resname,ires,ni+9)
         end if
c
c     thymine in deoxythymidine residue  (THY)
c
      else if (resname .eq. 'THY') then
         if (allatom) then
            call pdbatm (' H3 ',resname,ires,ni+9)
            call pdbatm ('1H5M',resname,ires,ni+10)
            call pdbatm ('2H5M',resname,ires,ni+11)
            call pdbatm ('3H5M',resname,ires,ni+12)
            call pdbatm (' H6 ',resname,ires,ni+13)
         else
            call pdbatm (' 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 pdbatm (' H5T',resname,ires,k)
      end do
      do i = 1, n12(o3i)
         k = i12(i,o3i)
         if (atomic(k) .eq. 1)  call pdbatm (' H3T',resname,ires,k)
      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 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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'files.i'
      include 'refer.i'
      include 'titles.i'
      integer i,j
c
c
c     copy the filename and title line for the structure
c
      reffile = filename
      refleng = leng
      reftitle = title
      refltitle = ltitle
c
c     copy the coordinates, type and connectivity of each atom
c
      nref = n
      do i = 1, n
         refnam(i) = name(i)
         xref(i) = x(i)
         yref(i) = y(i)
         zref(i) = z(i)
         reftyp(i) = type(i)
         n12ref(i) = n12(i)
         do j = 1, n12(i)
            i12ref(j,i) = i12(j,i)
         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 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'zcoord.i'
      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)  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 and system temperature
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)
      implicit none
      include 'units.i'
      real*8 maxwell
      real*8 mass,temper
      real*8 rho,beta
      real*8 random,erfinv
      real*8 xspeed,yspeed
      real*8 zspeed
c
c
c     set normalization factor for cumulative velocity distribution
c
      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)
      return
      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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bath.i'
      include 'bound.i'
      include 'files.i'
      include 'group.i'
      include 'inform.i'
      include 'keys.i'
      include 'mdstuf.i'
      include 'moldyn.i'
      include 'rgddyn.i'
      include 'shake.i'
      include 'stodyn.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,idyn
      integer size,next
      integer lext,freeunit
      real*8 e,maxwell,speed
      real*8 vec(3)
      real*8 derivs(3,maxatm)
      logical exist
      character*7 ext
      character*20 keyword
      character*60 dynfile
      character*80 record
c
c
c     set some default parameters for the dynamics run
c
      integrate = 'BEEMAN'
      velsave = .false.
      uindsave = .false.
      thermostat = 'BERENDSEN'
      tautemp = 0.1d0
      taupres = 2.0d0
      compress = 0.000046d0
      collide = 0.1d0
      friction = 91.0d0
      use_sdarea = .false.
      iprint = 100
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)
         if (keyword(1:10) .eq. 'INTEGRATE ') then
            call getword (record,integrate,next)
            call upcase (integrate)
         else if (keyword(1:14) .eq. 'SAVE-VELOCITY ') then
            velsave = .true.
         else if (keyword(1:13) .eq. 'SAVE-INDUCED ') then
            uindsave = .true.
         else if (keyword(1:11) .eq. 'THERMOSTAT ') then
            call getword (record,thermostat,next)
            call upcase (thermostat)
         else if (keyword(1:16) .eq. 'TAU-TEMPERATURE ') then
            read (record(next:80),*,err=10)  tautemp
         else if (keyword(1:13) .eq. 'TAU-PRESSURE ') then
            read (record(next:80),*,err=10)  taupres
         else if (keyword(1:9) .eq. 'COMPRESS ') then
            read (record(next:80),*,err=10)  compress
         else if (keyword(1:10) .eq. 'COLLISION ') then
            read (record(next:80),*,err=10)  collide
         else if (keyword(1:9) .eq. 'FRICTION ') then
            read (record(next:80),*,err=10)  friction
         else if (keyword(1:9) .eq. 'FRICTION ') then
            read (record(next:80),*,err=10)  friction
         else if (keyword(1:17) .eq. 'FRICTION-SCALING ') then
            use_sdarea = .true.
         else if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (record(next:80),*,err=10)  iprint
         end if
   10    continue
      end do
c
c     make sure all atoms have a nonzero atomic mass
c
      do i = 1, n
         if (use(i)) then
            if (mass(i) .le. 0.0d0)  mass(i) = 1.0d0
         end if
      end do
c
c     set the number of degrees of freedom for the system
c
      if (integrate .eq. 'RIGIDBODY') then
         call grpline
         nfree = 6*ngrp - 6
         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
         if (use_bounds)  nfree = nfree + 3
      else if (integrate .eq. 'STOCHASTIC') then
         nfree = 3*nuse - nrat
      else
         nfree = 3*nuse - nrat - 6
         if (use_bounds)  nfree = nfree + 3
      end if
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
         idyn = freeunit ()
         open (unit=idyn,file=dynfile,status='old')
         rewind (unit=idyn)
         call readdyn (idyn)
         close (unit=idyn)
         call lattice
c
c     initialize velocities and accelerations for first step
c
      else
         call gradient (e,derivs)
         do i = 1, n
            if (use(i)) then
               speed = maxwell (mass(i),kelvin)
               call ranvec (vec)
               do j = 1, 3
                  v(j,i) = speed * vec(j)
                  a(j,i) = -convert * derivs(j,i) / mass(i)
                  aold(j,i) = a(j,i)
               end do
            else
               do j = 1, 3
                  v(j,i) = 0.0d0
                  a(j,i) = 0.0d0
                  aold(j,i) = 0.0d0
               end do
            end if
         end do
         if (nuse .eq. n)  call mdrest
      end if
c
c     check for any prior dynamics coordinate sets
c
      i = 0
      exist = .true.
      dowhile (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 overall system center of mass
c
c
      subroutine mdrest
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'mdstuf.i'
      include 'moldyn.i'
      include 'rgddyn.i'
      include 'units.i'
      integer i,j,k
      real*8 etrans,erot
      real*8 weight,totmass
      real*8 xx,xy,xz,yy,yz,zz
      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 xcm(maxgrp)
      real*8 ycm(maxgrp)
      real*8 zcm(maxgrp)
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
      if (integrate .eq. 'RIGIDBODY') then
         do i = 1, ngrp
            weight = grpmass(i)
            totmass = totmass + weight
            do j = 1, 3
               vtot(j) = vtot(j) + vcm(j,i)*weight
            end do
         end do
      else
         do i = 1, n
            weight = mass(i)
            totmass = totmass + weight
            do j = 1, 3
               vtot(j) = vtot(j) + v(j,i)*weight
            end do
         end do
      end if
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 / convert
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
         if (integrate .eq. 'RIGIDBODY') then
            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)
                  weight = mass(k)
                  xcm(i) = xcm(i) + x(k)*weight
                  ycm(i) = ycm(i) + y(k)*weight
                  zcm(i) = zcm(i) + z(k)*weight
               end do
               xtot = xtot + xcm(i)
               ytot = ytot + ycm(i)
               ztot = ztot + zcm(i)
               xcm(i) = xcm(i) / grpmass(i)
               ycm(i) = ycm(i) / grpmass(i)
               zcm(i) = zcm(i) / grpmass(i)
            end do
         else
            do i = 1, n
               weight = mass(i)
               xtot = xtot + x(i)*weight
               ytot = ytot + y(i)*weight
               ztot = ztot + z(i)*weight
            end do
         end if
         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
         if (integrate .eq. 'RIGIDBODY') then
            do i = 1, ngrp
               weight = grpmass(i)
               mang(1) = mang(1) + (ycm(i)*vcm(3,i)
     &                             -zcm(i)*vcm(2,i))*weight
               mang(2) = mang(2) + (zcm(i)*vcm(1,i)
     &                             -xcm(i)*vcm(3,i))*weight
               mang(3) = mang(3) + (xcm(i)*vcm(2,i)
     &                             -ycm(i)*vcm(1,i))*weight
            end do
         else
            do i = 1, n
               weight = mass(i)
               mang(1) = mang(1) + (y(i)*v(3,i)-z(i)*v(2,i))*weight
               mang(2) = mang(2) + (z(i)*v(1,i)-x(i)*v(3,i))*weight
               mang(3) = mang(3) + (x(i)*v(2,i)-y(i)*v(1,i))*weight
            end do
         end if
         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 and then invert the inertia tensor
c
         xx = 0.0d0
         xy = 0.0d0
         xz = 0.0d0
         yy = 0.0d0
         yz = 0.0d0
         zz = 0.0d0
         if (integrate .eq. 'RIGIDBODY') then
            do i = 1, ngrp
               weight = grpmass(i)
               xdel = xcm(i) - xtot
               ydel = ycm(i) - ytot
               zdel = zcm(i) - ztot
               xx = xx + xdel*xdel*weight
               xy = xy + xdel*ydel*weight
               xz = xz + xdel*zdel*weight
               yy = yy + ydel*ydel*weight
               yz = yz + ydel*zdel*weight
               zz = zz + zdel*zdel*weight
            end do
         else
            do i = 1, n
               weight = mass(i)
               xdel = x(i) - xtot
               ydel = y(i) - ytot
               zdel = z(i) - ztot
               xx = xx + xdel*xdel*weight
               xy = xy + xdel*ydel*weight
               xz = xz + xdel*zdel*weight
               yy = yy + ydel*ydel*weight
               yz = yz + ydel*zdel*weight
               zz = zz + zdel*zdel*weight
            end do
         end if
         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 invert (3,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 / convert
      end if
c
c     eliminate any translation of the overall system
c
      if (integrate .eq. 'RIGIDBODY') then
         do i = 1, ngrp
            do j = 1, 3
               vcm(j,i) = vcm(j,i) - vtot(j)
            end do
         end do
      else
         do i = 1, n
            do j = 1, 3
               v(j,i) = v(j,i) - vtot(j)
            end do
         end do
      end if
c
c     print the translational velocity of the overall system
c
      if (verbose) then
         write (iout,10)  (vtot(i),i=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
         if (integrate .eq. 'RIGIDBODY') 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
         else
            do i = 1, n
               xdel = x(i) - xtot
               ydel = y(i) - ytot
               zdel = z(i) - ztot
               v(1,i) = v(1,i) - vang(2)*zdel + vang(3)*ydel
               v(2,i) = v(2,i) - vang(3)*xdel + vang(1)*zdel
               v(3,i) = v(3,i) - vang(1)*ydel + vang(2)*xdel
            end do
         end if
c
c     print the angular velocity of the overall system
c
         if (verbose) then
            write (iout,20)  (vang(i),i=1,3),erot
   20       format (/,' System Angular Velocity : ',3d12.2,
     &              /,' Rotational Kinetic Energy :',13x,f12.4,
     &                 ' Kcal/mole')
         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 mdsave  --  save trajectory and restart files  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "mdsave" writes molecular dynamics trajectory snapshots and
c     auxiliary files with velocity and induced dipole information;
c     also checks for user requested termination of a simulation
c
c
      subroutine mdsave (istep)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'mdstuf.i'
      include 'moldyn.i'
      include 'mpole.i'
      include 'output.i'
      include 'polar.i'
      include 'potent.i'
      include 'titles.i'
      include 'units.i'
      integer i,j,k,istep
      integer ixyz,iend
      integer ivel,iind
      integer idump,moddump
      integer lext,freeunit
      logical exist
      character*7 ext
      character*60 xyzfile
      character*60 endfile
      character*60 velfile
      character*60 indfile
c
c
c     check number of steps between trajectory file dumps
c
      moddump = mod(istep,iwrite)
      if (moddump .ne. 0)  return
c
c     get the sequence number of the current trajectory frame
c
      idump = nprior + istep/iwrite
      lext = 3
      call numeral (idump,ext,lext)
c
c     update the information needed to restart the trajectory
c
      call prtdyn
c
c     save coordinates to an archive or numbered structure file
c
      ixyz = freeunit ()
      if (archive) then
         xyzfile = filename(1:leng)
         call suffix (xyzfile,'arc')
         call version (xyzfile,'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)
c
c     save the current velocity components for each atom
c
      if (velsave) then
         ivel = freeunit ()
         if (archive) then
            velfile = filename(1:leng)
            call suffix (velfile,'vel')
            call version (velfile,'old')
            inquire (file=velfile,exist=exist)
            if (exist) then
               call openend (ivel,velfile)
            else
               open (unit=ivel,file=velfile,status='new')
            end if
         else
            velfile = filename(1:leng)//'.'//ext(1:lext)//'v'
            call version (velfile,'new')
            open (unit=ivel,file=velfile,status='new')
         end if
         write (ivel,10)  n,title(1:ltitle)
   10    format (i6,2x,a)
         do i = 1, n
            write (ivel,20)  i,name(i),(v(j,i),j=1,3)
   20       format (i6,2x,a3,3x,d13.6,3x,d13.6,3x,d13.6)
         end do
         close (unit=ivel)
      end if
c
c     save the current induced dipole moment at each site
c
      if (uindsave .and. use_polar) then
         iind = freeunit ()
         if (archive) then
            indfile = filename(1:leng)
            call suffix (indfile,'uind')
            call version (indfile,'old')
            inquire (file=indfile,exist=exist)
            if (exist) then
               call openend (iind,indfile)
            else
               open (unit=iind,file=indfile,status='new')
            end if
         else
            indfile = filename(1:leng)//'.'//ext(1:lext)//'u'
            call version (indfile,'new')
            open (unit=iind,file=indfile,status='new')
         end if
         write (iind,30)  n,title(1:ltitle)
   30    format (i6,2x,a)
         do i = 1, npole
            if (polarity(i) .ne. 0.0d0) then
               k = ipole(i)
               write (iind,40)  k,name(k),(debye*uind(j,i),j=1,3)
   40          format (i6,2x,a3,3f12.6)
            end if
         end do
         close (unit=iind)
      end if
c
c     check for requested termination of the dynamics run
c
      iend = freeunit ()
      endfile = filename(1:leng)//'.end'
      inquire (file=endfile,exist=exist)
      if (exist) then
         write (iout,50)
   50    format (/,' Molecular Dynamics run Terminating 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 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bath.i'
      include 'boxes.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'units.i'
      include 'usage.i'
      include 'warp.i'
      integer istep,modstep
      real*8 dt,etot,epot,ekin
      real*8 temp,pres,pico,dens
      real*8 fluctuate,fluctuate2
      real*8 intfluct,intfluct2
      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 eint_sum,eint2_sum
      real*8 etot_ave,etot2_ave
      real*8 eint_ave,eint2_ave
      real*8 epot_sum,epot2_sum
      real*8 ekin_sum,ekin2_sum
      real*8 epot_ave,epot2_ave
      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 eint_sum,eint2_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     print energy, temperature and pressure for current step
c
      if (verbose) then
         if (isobaric) then
            write (iout,10)  istep,etot,epot,ekin,temp,pres
   10       format (i10,2f14.4,f12.4,2f11.2)
         else
            write (iout,20)  istep,etot,epot,ekin,temp
   20       format (i10,2f14.4,f12.4,f11.2)
         end if
      end if
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) 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
         eint_sum = 0.0d0
         eint2_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 header for the averages over a group of recent steps
c
      if (modstep .eq. 0) then
         pico = dble(istep) * dt
         write (iout,30)  iprint,istep,pico
   30    format (/,' Values over the last',i6,' out of',i9,
     &              ' Dynamics Steps',
     &           //,' Cumulative Time',5x,f15.4,' Picosecond')
      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
         write (iout,40)  etot_ave,fluctuate
   40    format (' Total Energy',8x,f15.4,' Kcal/mole',3x,
     &              '(+/-',f9.4,')')
      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
         write (iout,50)  epot_ave,potfluct
   50    format (' Potential Energy',4x,f15.4,' Kcal/mole',3x,
     &              '(+/-',f9.4,')')
      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
         write (iout,60)  ekin_ave,kinfluct
   60    format (' Kinetic Energy',6x,f15.4,' Kcal/mole',3x,
     &              '(+/-',f9.4,')')
      end if
c
c     compute average intermolecular energy and its fluctuation
c
      if (nmol.ne.1 .and. nmol.ne.n) then
         eint_sum = eint_sum + einter
         eint2_sum = eint2_sum + einter**2
         if (modstep .eq. 0) then
            eint_ave = eint_sum / dble(iprint)
            eint2_ave = eint2_sum / dble(iprint)
            intfluct2 = eint2_ave - eint_ave**2
            if (intfluct2 .gt. 0.0d0) then
               intfluct = sqrt(intfluct2)
            else
               intfluct = 0.0d0
            end if
            write (iout,70)  eint_ave,intfluct
   70       format (' Intermolecular',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
         write (iout,80)  temp_ave,tfluct
   80    format (' Temperature',9x,f15.2,' Kelvin',6x,
     &              '(+/-',f9.2,')')
      end if
c
c     compute the average pressure and its fluctuation
c
      if (isobaric) 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
            write (iout,90)  pres_ave,pfluct
   90       format (' Pressure',12x,f15.2,' Atmosphere',2x,
     &                 '(+/-',f9.2,')')
         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
            write (iout,100)  dens_ave,dfluct
  100       format (' Density',13x,f15.4,' Grams/cc',4x,
     &                 '(+/-',f9.4,')')
         end if
      end if
c
c     current deformation value for diffusional smoothing
c
      if (use_deform) then
         if (modstep .eq. 0) then
            write (iout,110)  deform
  110       format (' Deformation',9x,f15.3,' Sqr Angs')
         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 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
      implicit none
      include 'cutoff.i'
      include 'inform.i'
      include 'iounit.i'
      include 'potent.i'
      include 'vdwpot.i'
c
c
c     set the bonded connectivity lists and active atoms
c
      call attach
      call active
c
c     find and store each bond, angle and torsion
c
      call bonds
      call angles
      call torsions
c
c     find unit cell type and lattice values for images
c
      call unitcell
      call lattice
      call polymer
c
c     find small connected rings and set cutoff values
c
      call rings
      call cutoffs
c
c     get the force field parameters and assign atom types
c
      call field
      call katom
c
c     find any pisystem atoms, bonds and torsional angles
c
      call orbital
c
c     assign bond, angle and cross term potential parameters
c
      if (use_bond .or. use_strbnd .or. use_strtor
     &    .or. (use_vdw .and. vdwtyp.eq.'MM3-HBOND'))  call kbond
      if (use_angle .or. use_strbnd .or. use_angang)  call kangle
      if (use_strbnd)  call kstrbnd
      if (use_urey)  call kurey
      if (use_angang)  call kangang
c
c     assign out-of-plane deformation potential parameters
c
      if (use_angle .or. use_opbend)  call kopbend
      if (use_angle .or. use_opdist)  call kopdist
      if (use_improp)  call kimprop
      if (use_imptor)  call kimptor
c
c     assign torsion and torsion cross term potential parameters
c
      if (use_tors .or. use_strtor .or. use_tortor)  call ktors
      if (use_strtor)  call kstrtor
c     if (use_tortor)  call ktortor
c
c     assign van der Walls and electrostatic potential parameters
c
      if (use_vdw)  call kvdw
      if (use_charge .or. use_chgdpl .or.
     &    use_ewald .or. use_solv)   call kcharge
      if (use_dipole .or. use_chgdpl)  call kdipole
      if (use_mpole .or. use_polar .or. use_rxnfld)  call kmpole
      if (use_polar)  call kpolar
      if (use_ewald)  call kewald
c
c     assign solvation, metal, pisystem and restraint parameters
c
      if (use_solv)  call ksolv
      if (use_metal)  call kmetal
      if (use_orbit)  call korbit
      if (use_geom)  call kgeom
c
c     assign atoms to molcules and set the atom groups
c
      call molecule
      call cluster
c
c     setup for potential smoothing and free energy perturbation
c
      call smooth
      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)  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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      include 'refer.i'
      integer i,j,k
      integer ntotal
c
c
c     check for too many total atoms in the combined system
c
      ntotal = n + nref
      if (ntotal .gt. maxatm) then
         write (iout,10)  maxatm
   10    format (/,' MERGE  --  The Maximum of',i6,' 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
         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
         end do
      end do
c
c     place reference structure in the current structure
c
      call getref
      n = ntotal
      return
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'scales.i'
      include 'usage.i'
      integer i,j,nvar
      integer imin,freeunit
      real*8 minimiz1,minimum
      real*8 grdmin,gnorm,grms
      real*8 xx(maxvar)
      real*8 derivs(3,maxatm)
      logical exist
      character*60 minfile
      character*80 string
      external minimiz1
      external writeout
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
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     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, n
         if (use(i)) then
            do j = 1, 3
               nvar = nvar + 1
               scale(nvar) = 12.0d0
            end do
         end if
      end do
c
c     scale the coordinates of each active atom
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            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 if
      end do
c
c     make the call to the optimization routine
c
      call lbfgs (nvar,xx,minimum,grdmin,minimiz1,writeout)
c
c     unscale the final coordinates for active atoms
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     compute the final function and RMS gradient values
c
      call gradient (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, n
         if (use(i)) then
            do j = 1, 3
               gnorm = gnorm + derivs(j,i)**2
            end do
         end if
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(nvar/3))
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 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'scales.i'
      include 'usage.i'
      integer i,nvar
      real*8 minimiz1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(3,maxatm)
c
c
c     translate 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     compute and store the energy and gradient
c
      call gradient (e,derivs)
      minimiz1 = e
c
c     store atom gradients as optimization gradient, also
c     translate the coordinates of each active atom; the
c     latter may be needed when using periodic boundaries
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            xx(nvar) = x(i) * scale(nvar)
            g(nvar) = derivs(1,i) / scale(nvar)
            nvar = nvar + 1
            xx(nvar) = y(i) * scale(nvar)
            g(nvar) = derivs(2,i) / scale(nvar)
            nvar = nvar + 1
            xx(nvar) = z(i) * scale(nvar)
            g(nvar) = derivs(3,i) / scale(nvar)
         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 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
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'omega.i'
      include 'scales.i'
      include 'zcoord.i'
      integer i,imin,freeunit
      real*8 minirot1,minimum
      real*8 grdmin,grms,gnorm
      real*8 xx(maxvar)
      real*8 derivs(maxrot)
      logical exist
      character*60 minfile
      character*80 string
      external minirot1
      external writeout
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getint
      call mechanic
      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     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     get optimization parameters as scaled dihedral angles
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,writeout)
c
c     unscale the final dihedral angle values
c
      do i = 1, nomega
         dihed(i) = xx(i) / scale(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
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     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)
      implicit none
      include 'sizes.i'
      include 'math.i'
      include 'omega.i'
      include 'scales.i'
      include 'zcoord.i'
      integer i
      real*8 minirot1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(maxrot)
c
c
c     translate optimization variables into dihedrals
c
      do i = 1, nomega
         dihed(i) = xx(i) / scale(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     get coordinates, then compute energy and gradient
c
      call makexyz
      call gradrot (e,derivs)
      minirot1 = e
c
c     store angle gradients as optimization gradient
c
      do i = 1, nomega
         g(i) = derivs(i) / scale(i)
      end do
      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
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'output.i'
      include 'rigid.i'
      integer i,j,nvar
      integer imin,freeunit
      real*8 minrigid1,minimum
      real*8 grdmin,grms,gnorm
      real*8 xx(maxvar)
      real*8 derivs(6,maxgrp)
      logical exist
      character*60 minfile
      character*80 string
      external minrigid1
      external writeout
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getxyz
      call mechanic
      call orient
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     transfer 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
      coordtype = 'rigidbody'
      call lbfgs (nvar,xx,minimum,grdmin,minrigid1,writeout)
c
c     transfer 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     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     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)
      implicit none
      include 'sizes.i'
      include 'group.i'
      include 'math.i'
      include 'rigid.i'
      integer i,j,nvar
      real*8 minrigid1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(6,maxgrp)
c
c
c     translate 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     compute and store the energy and gradient
c
      call rigidxyz
      call gradrgd (e,derivs)
      call xyzrigid
      minrigid1 = e
c
c     translate rigid body variables to optimization arrays
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            xx(nvar) = rbc(j,i)
            g(nvar) = derivs(j,i)
         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 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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'molcul.i'
      integer i,j,k
      integer mi,mj,mk
      integer iattach
      integer list(maxatm)
c
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 iattach = 1, n12(i)
            j = i12(iattach,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     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     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)  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 and
c     quadrupole moments for the entire system as a sum over the
c     partial charges, bond dipoles and atomic multipole moments
c
c
      subroutine moments
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'centre.i'
      include 'charge.i'
      include 'dipole.i'
      include 'moment.i'
      include 'mpole.i'
      include 'polar.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k
      real*8 weight,qave
      real*8 xc,yc,zc
      real*8 xi,yi,zi,ri
      real*8 xmid,ymid,zmid
      real*8 xbnd,ybnd,zbnd
      real*8 work1(3),work2(3)
      real*8 a(3,3),b(3,3)
c
c
c     zero out total charge, dipole and quadrupole components
c
      netchg = 0.0d0
      netdpl = 0.0d0
      netqdp(1) = 0.0d0
      netqdp(2) = 0.0d0
      netqdp(3) = 0.0d0
      xdpl = 0.0d0
      ydpl = 0.0d0
      zdpl = 0.0d0
      xxqdp = 0.0d0
      xyqdp = 0.0d0
      xzqdp = 0.0d0
      yxqdp = 0.0d0
      yyqdp = 0.0d0
      yzqdp = 0.0d0
      zxqdp = 0.0d0
      zyqdp = 0.0d0
      zzqdp = 0.0d0
c
c     find the center of mass of the set of active atoms
c
      weight = 0.0d0
      xmid = 0.0d0
      ymid = 0.0d0
      zmid = 0.0d0
      do i = 1, n
         if (use(i)) then
            weight = weight + 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 (weight .ne. 0.0d0) then
         xmid = xmid / weight
         ymid = ymid / weight
         zmid = zmid / weight
      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     set the multipole moment components due to partial charges
c
      do i = 1, nion
         k = iion(i)
         if (use(k)) then
            netchg = netchg + pchg(i)
            xdpl = xdpl + xcm(k)*pchg(i)
            ydpl = ydpl + ycm(k)*pchg(i)
            zdpl = zdpl + zcm(k)*pchg(i)
            xxqdp = xxqdp + xcm(i)*xcm(i)*pchg(i)
            xyqdp = xyqdp + xcm(i)*ycm(i)*pchg(i)
            xzqdp = xzqdp + xcm(i)*zcm(i)*pchg(i)
            yxqdp = yxqdp + ycm(i)*xcm(i)*pchg(i)
            yyqdp = yyqdp + ycm(i)*ycm(i)*pchg(i)
            yzqdp = yzqdp + ycm(i)*zcm(i)*pchg(i)
            zxqdp = zxqdp + zcm(i)*xcm(i)*pchg(i)
            zyqdp = zyqdp + zcm(i)*ycm(i)*pchg(i)
            zzqdp = zzqdp + zcm(i)*zcm(i)*pchg(i)
         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
            xxqdp = xxqdp + 2.0d0*xc*xbnd
            xyqdp = xyqdp + xc*ybnd + yc*xbnd
            xzqdp = xzqdp + xc*zbnd + zc*xbnd
            yxqdp = yxqdp + yc*xbnd + xc*ybnd
            yyqdp = yyqdp + 2.0d0*yc*ybnd
            yzqdp = yzqdp + yc*zbnd + zc*ybnd
            zxqdp = zxqdp + zc*xbnd + xc*zbnd
            zyqdp = zyqdp + zc*ybnd + yc*zbnd
            zzqdp = zzqdp + 2.0d0*zc*zbnd
         end if
      end do
c
c     find atomic multipoles and induced dipoles in global frame
c
      do i = 1, npole
         call rotmat (i,a)
         call rotpole (i,a)
      end do
      call induce
      do i = 1, npole
         rpole(2,i) = rpole(2,i) + uind(1,i)
         rpole(3,i) = rpole(3,i) + uind(2,i)
         rpole(4,i) = rpole(4,i) + uind(3,i)
      end do
c
c     set the multipole moment components due to atomic multipoles
c
      do i = 1, npole
         k = ipole(i)
         if (use(k)) then
            netchg = netchg + rpole(1,i)
            xdpl = xdpl + xcm(k)*rpole(1,i) + rpole(2,i)
            ydpl = ydpl + ycm(k)*rpole(1,i) + rpole(3,i)
            zdpl = zdpl + zcm(k)*rpole(1,i) + rpole(4,i)
            xxqdp = xxqdp + xcm(i)*xcm(i)*rpole(1,i)
     &                 + 2.0d0*xcm(i)*rpole(2,i)
            xyqdp = xyqdp + xcm(i)*ycm(i)*rpole(1,i)
     &                 + xcm(i)*rpole(3,i) + ycm(i)*rpole(2,i)
            xzqdp = xzqdp + xcm(i)*zcm(i)*rpole(1,i)
     &                 + xcm(i)*rpole(4,i) + zcm(i)*rpole(2,i)
            yxqdp = yxqdp + ycm(i)*xcm(i)*rpole(1,i)
     &                 + ycm(i)*rpole(2,i) + xcm(i)*rpole(3,i)
            yyqdp = yyqdp + ycm(i)*ycm(i)*rpole(1,i)
     &                 + 2.0d0*ycm(i)*rpole(3,i)
            yzqdp = yzqdp + ycm(i)*zcm(i)*rpole(1,i)
     &                 + ycm(i)*rpole(4,i) + zcm(i)*rpole(3,i)
            zxqdp = zxqdp + zcm(i)*xcm(i)*rpole(1,i)
     &                 + zcm(i)*rpole(2,i) + xcm(i)*rpole(4,i)
            zyqdp = zyqdp + zcm(i)*ycm(i)*rpole(1,i)
     &                 + zcm(i)*rpole(3,i) + ycm(i)*rpole(4,i)
            zzqdp = zzqdp + zcm(i)*zcm(i)*rpole(1,i)
     &                 + 2.0d0*zcm(i)*rpole(4,i)
         end if
      end do
c
c     convert the quadrupole from traced to traceless form
c
      qave = (xxqdp + yyqdp + zzqdp) / 3.0d0
      xxqdp = 1.5d0 * (xxqdp-qave)
      xyqdp = 1.5d0 * xyqdp
      xzqdp = 1.5d0 * xzqdp
      yxqdp = 1.5d0 * yxqdp
      yyqdp = 1.5d0 * (yyqdp-qave)
      yzqdp = 1.5d0 * yzqdp
      zxqdp = 1.5d0 * zxqdp
      zyqdp = 1.5d0 * zyqdp
      zzqdp = 1.5d0 * (zzqdp-qave)
c
c     add the traceless atomic quadrupoles to total quadrupole
c
      do i = 1, npole
         k = ipole(i)
         if (use(k)) then
            xxqdp = xxqdp + 3.0d0*rpole(5,i)
            xyqdp = xyqdp + 3.0d0*rpole(6,i)
            xzqdp = xzqdp + 3.0d0*rpole(7,i)
            yxqdp = yxqdp + 3.0d0*rpole(8,i)
            yyqdp = yyqdp + 3.0d0*rpole(9,i)
            yzqdp = yzqdp + 3.0d0*rpole(10,i)
            zxqdp = zxqdp + 3.0d0*rpole(11,i)
            zyqdp = zyqdp + 3.0d0*rpole(12,i)
            zzqdp = zzqdp + 3.0d0*rpole(13,i)
         end if
      end do
c
c     convert dipole to Debyes and quadrupole to Buckinghams
c
      xdpl = xdpl * debye
      ydpl = ydpl * debye
      zdpl = zdpl * debye
      xxqdp = xxqdp * debye
      xyqdp = xyqdp * debye
      xzqdp = xzqdp * debye
      yxqdp = yxqdp * debye
      yyqdp = yyqdp * debye
      yzqdp = yzqdp * debye
      zxqdp = zxqdp * debye
      zyqdp = zyqdp * debye
      zzqdp = zzqdp * debye
c
c     get dipole magnitude and diagonalize quadrupole tensor
c
      netdpl = sqrt(xdpl*xdpl + ydpl*ydpl + zdpl*zdpl)
      a(1,1) = xxqdp
      a(1,2) = xyqdp
      a(1,3) = xzqdp
      a(2,1) = yxqdp
      a(2,2) = yyqdp
      a(2,3) = yzqdp
      a(3,1) = zxqdp
      a(3,2) = zyqdp
      a(3,3) = zzqdp
      call jacobi (3,3,a,netqdp,b,work1,work2)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1995  by  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
      subroutine mutate
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'katoms.i'
      include 'keys.i'
      include 'mutant.i'
      integer i,ihyb
      integer it0,it1,next
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     zero number of hybrid atoms and hybrid atom list
c
      nhybrid = 0
      do i = 1, n
         alter(i) = .false.
      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
            nhybrid = 0
            lambda = 0.0d0
            string = record(next:80)
            read (string,*,err=10)  lambda
         else if (keyword(1:7) .eq. 'MUTATE ') then
            string = record(next:80)
            read (string,*,err=10)  ihyb,it0,it1
            nhybrid = nhybrid + 1
            ihybrid(nhybrid) = ihyb
            type0(nhybrid) = it0
            type1(nhybrid) = it1
            class0(nhybrid) = atmcls(it0)
            class1(nhybrid) = atmcls(it1)
            alter(ihyb) = .true.
         end if
   10    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     ##  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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'usage.i'
      integer i,j,imin,nvar
      integer next,freeunit
      real*8 gnorm,grms,grdmin
      real*8 newton1,minimum
      real*8 xx(maxvar)
      real*8 derivs(3,maxatm)
      character*1 answer
      character*6 mode,method
      character*60 minfile
      character*80 record
      character*80 string
      logical exist
      external newton1
      external newton2
      external writeout
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
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 (a80)
         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 (a80)
         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     translate the coordinates of each active atom
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            xx(nvar) = x(i)
            nvar = nvar + 1
            xx(nvar) = y(i)
            nvar = nvar + 1
            xx(nvar) = z(i)
         end if
      end do
c
c     make the call to the optimization routine
c
      call tncg (mode,method,nvar,xx,minimum,grdmin,
     &               newton1,newton2,writeout)
c
c     untranslate the final coordinates for active atoms
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            x(i) = xx(nvar)
            nvar = nvar + 1
            y(i) = xx(nvar)
            nvar = nvar + 1
            z(i) = xx(nvar)
         end if
      end do
c
c     compute the final function and RMS gradient values
c
      call gradient (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, n
         if (use(i)) then
            do j = 1, 3
               gnorm = gnorm + derivs(j,i)**2
            end do
         end if
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(nvar/3))
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 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'usage.i'
      integer i,nvar
      real*8 newton1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(3,maxatm)
c
c
c     translate optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            x(i) = xx(nvar)
            nvar = nvar + 1
            y(i) = xx(nvar)
            nvar = nvar + 1
            z(i) = xx(nvar)
         end if
      end do
c
c     compute and store the energy and gradient
c
      call gradient (e,derivs)
      newton1 = e
c
c     store atom gradients as optimization gradient, also
c     translate the coordinates of each active atom; the
c     latter may be needed when using periodic boundaries
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            xx(nvar) = x(i)
            g(nvar) = derivs(1,i)
            nvar = nvar + 1
            xx(nvar) = y(i)
            g(nvar) = derivs(2,i)
            nvar = nvar + 1
            xx(nvar) = z(i)
            g(nvar) = derivs(3,i)
         end if
      end do
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'usage.i'
      integer i,j,k,nvar
      integer hinit(maxvar)
      integer hstop(maxvar)
      integer hindex(maxhess)
      integer hvar(maxvar)
      integer huse(maxvar)
      real*8 xx(maxvar)
      real*8 hdiag(maxvar)
      real*8 h(maxhess)
      character*4 mode
c
c
c     translate optimization parameters to atomic coordinates
c
      if (mode .eq. 'none')  return
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            x(i) = xx(nvar)
            nvar = nvar + 1
            y(i) = xx(nvar)
            nvar = nvar + 1
            z(i) = xx(nvar)
         end if
      end do
c
c     compute and store the Hessian elements
c
      call hessian (h,hinit,hstop,hindex,hdiag)
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     translate the coordinates of each active atom;
c     this may be needed when using periodic boundaries
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            xx(nvar) = x(i)
            nvar = nvar + 1
            xx(nvar) = y(i)
            nvar = nvar + 1
            xx(nvar) = z(i)
         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 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
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'omega.i'
      include 'zcoord.i'
      integer i,imin,next
      integer freeunit
      real*8 grdmin,gnorm,grms
      real*8 newtrot1,minimum
      real*8 xx(maxvar)
      real*8 derivs(maxrot)
      character*1 answer
      character*6 mode,method
      character*60 minfile
      character*80 record
      character*80 string
      logical exist
      external newtrot1
      external newtrot2
      external writeout
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getint
      call mechanic
      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 (a80)
         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 (a80)
         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     translate the initial coordinates
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,writeout)
c
c     untranslate the final coordinates
c
      do i = 1, nomega
         dihed(i) = xx(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
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     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)
      implicit none
      include 'sizes.i'
      include 'math.i'
      include 'omega.i'
      include 'zcoord.i'
      integer i
      real*8 newtrot1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(maxrot)
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     get coordinates, then compute energy and gradient
c
      call makexyz
      call gradrot (e,derivs)
      newtrot1 = e
c
c     store angle gradients as optimization gradient
c
      do i = 1, nomega
         g(i) = derivs(i)
      end do
      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,h_init,h_stop,h_index,h_diag)
      implicit none
      include 'sizes.i'
      include 'hescut.i'
      include 'math.i'
      include 'omega.i'
      include 'zcoord.i'
      integer i,j,ihess
      integer h_init(maxvar)
      integer h_stop(maxvar)
      integer h_index(maxhess)
      real*8 xx(maxvar)
      real*8 h_diag(maxvar)
      real*8 h(maxhess)
      real*8 hrot(maxrot,maxrot)
      character*4 mode
      save hrot
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     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
            h_diag(i) = hrot(i,i)
            h_init(i) = ihess + 1
            do j = i+1, nomega
               if (abs(hrot(j,i)) .ge. hesscut) then
                  ihess = ihess + 1
                  h_index(ihess) = j
                  h(ihess) = hrot(j,i)
               end if
            end do
            h_stop(i) = ihess
         end do
c
c     store only the Hessian matrix diagonal
c
      else if (mode .eq. 'diag') then
         do i = 1, nomega
            h_diag(i) = hrot(i,i)
         end do
      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 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)
      implicit none
      include 'argue.i'
      integer i,length
      character*(*) string
      logical exist
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) 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'files.i'
      include 'iounit.i'
      include 'nucleo.i'
      include 'titles.i'
      integer i,natom,mode
      integer izmt,ixyz,iseq
      integer freeunit,trimtext
      logical exist
      character*60 seqfile
      character*60,intfile
      character*60 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 (a60)
      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 (a60)
      ltitle = trimtext (title)
c
c     read the keyfile and force field parameter file
c
      call getkey
      call field
c
c     get the sequence, build a Z-matrix, convert to Cartesians
c
      call getseqn
      call nucchain
      call connect
      call molecule
      call makexyz
c
c     perform the alignment of the strands of a double helix
c
      if (dblhlx)  call watson
c
c     remove any dummy atoms from Cartesian coordinates,
c     then convert to internal and Cartesian coordinates 
c
      natom = n
      do i = natom, 1, -1
         if (type(i) .eq. 0)  call delete (i)
      end do
      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
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'nucleo.i'
      include 'resdue.i'
      include 'sequen.i'
      integer i,j,k,next
      integer start,stop
      integer length,trimtext
      logical done
      logical purine(maxres)
      character*1 answer
      character*3 name,resname
      character*80 record
      character*80 string
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 (a80)
      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 3 Letter Code,',
     &        /,' followed by Backbone Torsions (6F) and',
     &           ' Glycosidic Torsion (1F)',
     &        //,' Use Residue=MOL to Begin a New Strand,',
     &           ' Residue=<CR> to End Entry')
c
c     initially, assume that only a single strand is present
c
      nchain = 1
      ichain(1,nchain) = 1
      chnnam(nchain) = ' '
c
c     get the nucleotide sequence data and dihedral angle values
c
      i = 0
      done = .false.
      dowhile (.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 (a80)
         call upcase (record)
         next = 1
         call getword (record,name,next)
         length = trimtext (name)
         if (name .eq. 'MOL') then
            i = i - 1
            ichain(2,nchain) = i
            nchain = nchain + 1
            ichain(1,nchain) = i + 1
            chnnam(nchain) = ' '
         else
            string = record(next:80)
            read (string,*,err=60,end=60)  (bkbone(j,i),j=1,6),glyco(i)
   60       continue
            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 (a80)
         next = 1
         call gettext (record,answer,next)
         call upcase (answer)
         if (answer .eq. 'Y')  dblhlx = .true.
      end if
c
c     set the reverse-compliment sequence for the second strand
c
      if (dblhlx) then
         start = 1
         stop = nseq
         resname = nuclz(seqtyp(1))
         if (resname.eq.'MPO' .or. resname.eq.'DPO'
     &          .or. resname.eq.'TPO') then
            k = nseq + 1
            seq(k) = seq(1)
            seqtyp(k) = seqtyp(1)
            start = 2
         end if
         resname = nuclz(seqtyp(nseq))
         if (resname.eq.'MPO' .or. resname.eq.'DPO'
     &          .or. resname.eq.'TPO') 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. 'ADE') then
               resname = 'URA'
            else if (resname .eq. 'GUA') then
               resname = 'CYT'
            else if (resname .eq. 'CYT') then
               resname = 'GUA'
            else if (resname .eq. 'URA') then
               resname = 'ADE'
            else if (resname .eq. 'DAD') then
               resname = 'THY'
            else if (resname .eq. 'DGU') then
               resname = 'DCY'
            else if (resname .eq. 'DCY') then
               resname = 'DGU'
            else if (resname .eq. 'THY') then
               resname = 'DAD'
            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
         chnnam(nchain) = ' '
         nseq = 2 * nseq
         ichain(1,nchain) = nseq/2 + 1
         ichain(2,nchain) = nseq
      end if
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. 'ADE')  purine(i) = .true.
         if (resname .eq. 'GUA')  purine(i) = .true.
         if (resname .eq. 'DAD')  purine(i) = .true.
         if (resname .eq. 'DGU')  purine(i) = .true.
         deoxy(i) = .false.
         if (resname .eq. 'DAD')  deoxy(i) = .true.
         if (resname .eq. 'DGU')  deoxy(i) = .true.
         if (resname .eq. 'DCY')  deoxy(i) = .true.
         if (resname .eq. 'THY')  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) = -51.8d0
               bkbone(2,i) = 174.8d0
               bkbone(3,i) = 41.7d0
               bkbone(4,i) = 79.1d0
               bkbone(5,i) = -148.0d0
               bkbone(6,i) = -75.0d0
               glyco(i) = -157.2d0
               pucker(i) = 3
            else if (hlxform .eq. 'B') then
               bkbone(1,i) = -46.1d0
               bkbone(2,i) = -146.5d0
               bkbone(3,i) = 36.4d0
               bkbone(4,i) = 156.5d0
               bkbone(5,i) = 154.7d0
               bkbone(6,i) = -95.6d0
               glyco(i) = -97.8d0
               pucker(i) = 2
            else if (hlxform .eq. 'Z') then
               if (purine(i)) then
                  bkbone(1,i) = 48.0d0
                  bkbone(2,i) = 179.0d0
                  bkbone(3,i) = -170.0d0
                  bkbone(4,i) = 100.0d0
                  bkbone(5,i) = -104.0d0
                  bkbone(6,i) = -69.0d0
                  glyco(i) = 67.0d0
                  pucker(i) = 3
               else
                  bkbone(1,i) = -137.0d0
                  bkbone(2,i) = -139.0d0
                  bkbone(3,i) = 55.0d0
                  bkbone(4,i) = 138.0d0
                  bkbone(5,i) = -94.0d0
                  bkbone(6,i) = 80.0d0
                  glyco(i) = -159.0d0
                  pucker(i) = 1
               end if
            end if
         end if
      end do
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'nucleo.i'
      include 'resdue.i'
      include 'sequen.i'
      integer i,j,k,m
      integer poi,o2i,c1i
      integer c2i,c3i,c4i
      integer c5i,o3i,o4i,o5i
      integer ptyp,optyp,ostyp
      integer ottyp,httyp
      integer o5typ(maxnuc)
      logical single,cap3,cap5
      character*3 resname
c
c     biopolymer atom types for nucleotide backbone atoms
c
      data o5typ   / 1001, 1031, 1062, 1090, 1117, 1146, 1176, 1203,
     &                  0,    0,    0,    0 /
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.
         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.'MPO' .or. resname.eq.'DPO'
     &          .or. resname.eq.'TPO')  cap5 = .true.
         i = ichain(2,m)
         k = seqtyp(i)
         resname = nuclz(k)
         if (resname.eq.'MPO' .or. resname.eq.'DPO'
     &          .or. resname.eq.'TPO')  cap3 = .true.
c
c     build the first residue or a phosphate capping group
c
         i = ichain(1,m)
         k = seqtyp(i)
         j = o5typ(k)
         resname = nuclz(k)
         if (resname .eq. 'MPO') then
            if (deoxy(i+1)) then
               ostyp = 1246
               ptyp = 1247
               optyp = 1248
            else
               ostyp = 1234
               ptyp = 1235
               optyp = 1236
            end if
            if (m .eq. 1) then
               o3i = n
               call zatom (optyp,0.0d0,0.0d0,0.0d0,0,0,0,0)
               poi = n
               call zatom (ptyp,1.52d0,0.0d0,0.0d0,o3i,0,0,0)
               call zatom (optyp,1.52d0,113.0d0,0.0d0,poi,o3i,0,0)
            else
               o3i = n
               call zatom (optyp,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 (ptyp,1.52d0,150.0d0,180.0d0,o3i,n-2,n-3,0)
               call zatom (optyp,1.52d0,113.0d0,180.0d0,poi,o3i,n-3,0)
            end if
            call zatom (optyp,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. 'DPO') then
            continue
         else if (resname .eq. 'TPO') then
            continue
         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 (j+1,1.44d0,0.0d0,0.0d0,o5i,0,0,0)
               c4i = n
               call zatom (j+4,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 (j+1,1.44d0,119.0d0,180.0d0,o5i,n-2,n-3,0)
               c4i = n
               call zatom (j+4,1.52d0,110.1d0,180.0d0,c5i,o5i,n-3,0)
            end if
            o4i = n
            call zatom (j+6,1.46d0,108.9d0,bkbone(3,i)-120.0d0,
     &                     c4i,c5i,o5i,0)
            c1i = n
            if (pucker(i) .eq. 3) then
               call zatom (j+7,1.42d0,109.8d0,145.0d0,o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 2) then
               call zatom (j+7,1.42d0,109.8d0,107.0d0,o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 1) then
               call zatom (j+7,1.42d0,109.8d0,140.0d0,o4i,c4i,c5i,0)
            end if
            c3i = n
            call zatom (j+9,1.53d0,115.9d0,bkbone(3,i),c4i,c5i,o5i,0)
            c2i = n
            call zatom (j+11,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
                  ottyp = 1249
                  call zatom (ottyp,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               else
                  call zatom (j+14,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               end if
            else
               if (single) then
                  ottyp = 1237
                  call zatom (ottyp,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               else
                  call zatom (j+15,1.42d0,112.1 d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               end if
               o2i = n
               call zatom (j+13,1.43d0,109.5d0,109.5d0,c2i,c3i,c1i,1)
            end if
            if (deoxy(i)) then
               httyp = 1245
            else
               httyp = 1233
            end if
            call zatom (httyp,0.96d0,107.0d0,180.0d0,o5i,c5i,c4i,0)
            call zatom (j+2,1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,1)
            call zatom (j+3,1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,-1)
            call zatom (j+5,1.09d0,109.5d0,109.5d0,c4i,c5i,c3i,-1)
            if (pucker(i) .eq. 3) then
               call zatom (j+8,1.09d0,109.5d0,120.0d0,c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 2) then
               call zatom (j+8,1.09d0,109.5d0,115.0d0,c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 1) then
               call zatom (j+8,1.09d0,109.5d0,90.0d0,c1i,o4i,c2i,-1)
            end if
            call zatom (j+10,1.09d0,109.5d0,109.5d0,c3i,c4i,c2i,-1)
            call zatom (j+12,1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,-1)
            if (deoxy(i)) then
               call zatom (j+13,1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,1)
            else
               call zatom (j+14,0.96d0,107.0d0,180.0d0,o2i,c2i,c3i,0)
            end if
            if (single) then
               if (deoxy(i)) then
                  httyp = 1250
               else
                  httyp = 1238
               end if
               call zatom (httyp,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
            k = seqtyp(i)
            j = o5typ(k)
            resname = nuclz(k)
            if (cap5) then
               cap5 = .false.
            else
               if (deoxy(i)) then
                  ptyp = 1242
                  optyp = 1243
               else
                  ptyp = 1230
                  optyp = 1231
               end if
               poi = n
               call zatom (ptyp,1.60d0,119.0d0,bkbone(5,i-1),
     &                        o3i,c3i,c4i,0)
               call zatom (optyp,1.48d0,109.0d0,bkbone(6,i-1)+120.0d0,
     &                        poi,o3i,c3i,0)
               call zatom (optyp,1.48d0,109.0d0,bkbone(6,i-1)-120.0d0,
     &                        poi,o3i,c3i,0)
               o5i = n
               call zatom (j,1.60d0,101.8d0,bkbone(6,i-1),poi,o3i,c3i,0)
            end if
            c5i = n
            call zatom (j+1,1.44d0,119.0d0,bkbone(1,i),o5i,poi,o3i,0)
            c4i = n
            call zatom (j+4,1.52d0,110.1d0,bkbone(2,i),c5i,o5i,poi,0)
            o4i = n
            call zatom (j+6,1.46d0,108.9d0,bkbone(3,i)-120.0d0,
     &                     c4i,c5i,o5i,0)
            c1i = n
            if (pucker(i) .eq. 3) then
               call zatom (j+7,1.42d0,109.8d0,145.0d0,o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 2) then
               call zatom (j+7,1.42d0,109.8d0,107.0d0,o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 1) then
               call zatom (j+7,1.42d0,109.8d0,140.0d0,o4i,c4i,c5i,0)
            end if
            c3i = n
            call zatom (j+9,1.53d0,115.9d0,bkbone(3,i),c4i,c5i,o5i,0)
            c2i = n
            call zatom (j+11,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) then
                  call zatom (1251,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               else
                  call zatom (j+14,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               end if
            else
               if (cap3) then
                  call zatom (1239,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               else
                  call zatom (j+15,1.42d0,112.1d0,bkbone(4,i),
     &                           c3i,c4i,c5i,0)
               end if
               o2i = n
               call zatom (j+13,1.43d0,109.5d0,109.5d0,c2i,c3i,c1i,1)
            end if
            call zatom (j+2,1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,1)
            call zatom (j+3,1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,-1)
            call zatom (j+5,1.09d0,109.5d0,109.5d0,c4i,c5i,c3i,-1)
            if (pucker(i) .eq. 3) then
               call zatom (j+8,1.09d0,109.5d0,120.0d0,c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 2) then
               call zatom (j+8,1.09d0,109.5d0,115.0d0,c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 1) then
               call zatom (j+8,1.09d0,109.5d0,90.0d0,c1i,o4i,c2i,-1)
            end if
            call zatom (j+10,1.09d0,109.5d0,109.5d0,c3i,c4i,c2i,-1)
            call zatom (j+12,1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,-1)
            if (deoxy(i)) then
               call zatom (j+13,1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,1)
            else
               call zatom (j+14,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
         i = ichain(2,m)
         k = seqtyp(i)
         j = o5typ(k)
         resname = nuclz(k)
         if (single) then
            continue
         else if (resname .eq. 'MPO') then
            if (deoxy(i-1)) then
               ptyp = 1252
               optyp = 1253
            else
               ptyp = 1240
               optyp = 1241
            end if
            poi = n
            call zatom (ptyp,1.63d0,119.0d0,bkbone(5,i-1),o3i,c3i,c4i,0)
            call zatom (optyp,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0)
            call zatom (optyp,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0)
            call zatom (optyp,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0)
         else if (resname .eq. 'DPO') then
            continue
         else if (resname .eq. 'TPO') then
            continue
         else
            if (cap5) then
               cap5 = .false.
            else
               if (deoxy(i)) then
                  ptyp = 1242
                  optyp = 1243
               else
                  ptyp = 1230
                  optyp = 1231
               end if
               poi = n
               call zatom (ptyp,1.60d0,119.0d0,bkbone(5,i-1),
     &                        o3i,c3i,c4i,0)
               call zatom (optyp,1.48d0,109.0d0,bkbone(6,i-1)+120.0d0,
     &                        poi,o3i,c3i,0)
               call zatom (optyp,1.48d0,109.0d0,bkbone(6,i-1)-120.0d0,
     &                        poi,o3i,c3i,0)
               o5i = n
               call zatom (j,1.60d0,101.8d0,bkbone(6,i-1),poi,o3i,c3i,0)
            end if
            c5i = n
            call zatom (j+1,1.44d0,119.0d0,bkbone(1,i),o5i,poi,o3i,0)
            c4i = n
            call zatom (j+4,1.52d0,110.1d0,bkbone(2,i),c5i,o5i,poi,0)
            o4i = n
            call zatom (j+6,1.46d0,108.9d0,bkbone(3,i)-120.0d0,
     &                     c4i,c5i,o5i,0)
            c1i = n
            if (pucker(i) .eq. 3) then
               call zatom (j+7,1.42d0,109.8d0,145.0d0,o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 2) then
               call zatom (j+7,1.42d0,109.8d0,107.0d0,o4i,c4i,c5i,0)
            else if (pucker(i) .eq. 1) then
               call zatom (j+7,1.42d0,109.8d0,140.0d0,o4i,c4i,c5i,0)
            end if
            c3i = n
            call zatom (j+9,1.53d0,115.9d0,bkbone(3,i),c4i,c5i,o5i,0)
            c2i = n
            call zatom (j+11,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
               ottyp = 1249
               call zatom (ottyp,1.42d0,112.1d0,bkbone(4,i),
     &                        c3i,c4i,c5i,0)
            else
               ottyp = 1237
               call zatom (ottyp,1.42d0,112.1d0,bkbone(4,i),
     &                        c3i,c4i,c5i,0)
               o2i = n
               call zatom (j+13,1.43d0,109.5d0,109.5d0,c2i,c3i,c1i,1)
            end if
            call zatom (j+2,1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,1)
            call zatom (j+3,1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,-1)
            call zatom (j+5,1.09d0,109.5d0,109.5d0,c4i,c5i,c3i,-1)
            if (pucker(i) .eq. 3) then
               call zatom (j+8,1.09d0,109.5d0,120.0d0,c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 2) then
               call zatom (j+8,1.09d0,109.5d0,115.0d0,c1i,o4i,c2i,-1)
            else if (pucker(i) .eq. 1) then
               call zatom (j+8,1.09d0,109.5d0,90.0d0,c1i,o4i,c2i,-1)
            end if
            call zatom (j+10,1.09d0,109.5d0,109.5d0,c3i,c4i,c2i,-1)
            call zatom (j+12,1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,-1)
            if (deoxy(i)) then
               httyp = 1250
               call zatom (j+13,1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,1)
            else
               httyp = 1238
               call zatom (j+14,0.96d0,107.0d0,180.0d0,o2i,c2i,c3i,0)
            end if
            call zatom (httyp,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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'nucleo.i'
      integer i,c1i,o4i,c2i
      character*3 resname
c
c
c     adenine in adenosine residue  (ADE)
c
      if (resname .eq. 'ADE') 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  (GUA)
c
      else if (resname .eq. 'GUA') 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  (CYT)
c
      else if (resname .eq. 'CYT') 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  (URA)
c
      else if (resname .eq. 'URA') 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  (DAD)
c
      else if (resname .eq. 'DAD') 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  (DGU)
c
      else if (resname .eq. 'DGU') 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  (DCY)
c
      else if (resname .eq. 'DCY') 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  (THY)
c
      else if (resname .eq. 'THY') 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'group.i'
      include 'inform.i'
      include 'katoms.i'
      include 'kgeoms.i'
      include 'molcul.i'
      include 'nucleo.i'
      include 'output.i'
      include 'potent.i'
      include 'resdue.i'
      include 'rigid.i'
      include 'sequen.i'
      include 'usage.i'
      integer i,j,nvar
      integer ia,ib,kseq,nbase
      integer start,stop,offset
      integer nphos,iphos(maxres)
      integer root(maxres)
      integer list(2,maxres)
      real*8 minimum,grdmin
      real*8 watson1,dist
      real*8 xx(maxopt)
      character*3 resname
      external watson1,writeout
c
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
      use_basin = .false.
      use_wall = .false.
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(4,i)))
            if (ia.eq.8 .and. ib.eq.7) then
               nbase = nbase + 1
               j = i12(4,i)
               root(nbase) = j
               kseq = kseq + 1
               resname = nuclz(seqtyp(kseq))
               dowhile (resname.eq.'MPO' .or. resname.eq.'DPO'
     &                         .or. resname.eq.'TPO')
                  kseq = kseq + 1
                  resname = nuclz(seqtyp(kseq))
               end do
               if (resname.eq.'ADE' .or. resname.eq.'DAD') then
                  list(1,nbase) = j + 6
                  list(2,nbase) = j + 11
               else if (resname.eq.'GUA' .or. resname.eq.'DGU') then
                  list(1,nbase) = j + 12
                  list(2,nbase) = j + 5
               else if (resname.eq.'CYT' .or. resname.eq.'DCY') then
                  list(1,nbase) = j + 3
                  list(2,nbase) = j + 8
               else if (resname .eq. 'URA') then
                  list(1,nbase) = j + 8
                  list(2,nbase) = j + 5
               else if (resname .eq. 'THY') then
                  list(1,nbase) = j + 9
                  list(2,nbase) = j + 5
               end if
            end if
         end if
      end do
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) = 1.85d0
         dfix(2,ndfix) = 1.95d0
         dfix(3,ndfix) = 50.0d0
         ndfix = ndfix + 1
         idfix(1,ndfix) = list(2,i)
         idfix(2,ndfix) = list(2,j)
         dfix(1,ndfix) = 1.85d0
         dfix(2,ndfix) = 1.95d0
         dfix(3,ndfix) = 50.0d0
      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) = 180.0d0
         tfix(2,ntfix) = 180.0d0
         tfix(3,ntfix) = 2.5d0
         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) = 180.0d0
         tfix(2,ntfix) = 180.0d0
         tfix(3,ntfix) = 2.5d0
         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) = 180.0d0
         tfix(2,ntfix) = 180.0d0
         tfix(3,ntfix) = 2.5d0
         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) = 180.0d0
         tfix(2,ntfix) = 180.0d0
         tfix(3,ntfix) = 2.5d0
      end do
c
c     distance restraints between interstrand phosphates
c
      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. 'MPO')  start = start + 1
      if (resname .eq. 'DPO')  start = start + 2
      if (resname .eq. 'TPO')  start = start + 3
      resname = nuclz(seqtyp(nseq))
      if (resname .eq. 'MPO')  stop = stop - 1
      if (resname .eq. 'DPO')  stop = stop - 2
      if (resname .eq. 'TPO')  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) = dist
         dfix(2,ndfix) = dist
         dfix(3,ndfix) = 100.0d0
      end do
c
c     assign each strand to a separate molecule-based group
c
      use_group = .true.
      ngrp = nmol
      do i = 1, ngrp
         grpnum(i) = i
         igrp(1,i) = imol(1,i)
         igrp(2,i) = imol(2,i)
         do j = igrp(1,i), igrp(2,i)
            grplist(j) = i
            kgrp(j) = j
         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     transfer 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,writeout)
c
c     transfer 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
      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)
      implicit none
      include 'sizes.i'
      include 'group.i'
      include 'math.i'
      include 'rigid.i'
      integer i,j,nvar
      real*8 watson1,e
      real*8 xx(maxopt)
      real*8 g(maxopt)
      real*8 derivs(6,maxgrp)
c
c
c     translate 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     compute and store the energy and gradient
c
      call rigidxyz
      call gradrgd (e,derivs)
      watson1 = e
c
c     translate rigid body gradient to optimization gradient
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            g(nvar) = derivs(j,i)
         end do
      end do
      return
      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)
      implicit none
      include 'inform.i'
      include 'iounit.i'
      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,number,size
      integer multi,pos
      integer length,minsize,len
      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
      million = number / 1000000
      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 (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. 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-justify if desired, and pad with blanks
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
      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     "fvalue" with respect to Cartesian coordinates of the atoms
c     via a two-sided numerical differentiation
c
c
      subroutine numgrad (fvalue,g,eps)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i
      real*8 fvalue,eps
      real*8 f,f0,old
      real*8 g(3,maxatm)
      external fvalue
c
c
c     compute two-sided numerical gradient from function values
c
      do i = 1, n
         old = x(i)
         x(i) = x(i) - 0.5d0*eps
         f0 = fvalue ()
         x(i) = x(i) + eps
         f = fvalue ()
         x(i) = old
         g(1,i) = (f - f0) / eps
         old = y(i)
         y(i) = y(i) - 0.5d0*eps
         f0 = fvalue ()
         y(i) = y(i) + eps
         f = fvalue ()
         y(i) = old
         g(2,i) = (f - f0) / eps
         old = z(i)
         z(i) = z(i) - 0.5d0*eps
         f0 = fvalue ()
         z(i) = z(i) + eps
         f = fvalue ()
         z(i) = old
         g(3,i) = (f - f0) / eps
      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 ocvm  --  variable metric optimization method  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ocvm" is an optimally conditioned variable metric nonlinear
c     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     hguess    initial value for diagonal elements of the "h" matrix
c     eps       maximum length of vector considered infinitely small
c     grdmin    normal exit if rms gradient gets below this value
c     stpmax    maximum length of DeltaX vector in any one iteration
c     fctmin    lower bound on the desired minimum function value
c     maxiter   maximum number of iterations to be attempted
c     iprint    print iteration results every iprint iterations
c     iwrite    call user-supplied output every iwrite iterations
c     ncalls    total number of function/gradient evaluations
c     gnorm     returns with the final value of the gradient norm
c     scale     factor by which the actual function has been multiplied
c
c     required external routines:
c
c     fgvalue    function to evaluate function and gradient values
c     writeout   subroutine to write out info about current status
c
c
      subroutine ocvm (nvar,x0,f0,grdmin,fgvalue,writeout)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'linmin.i'
      include 'math.i'
      include 'minima.i'
      include 'output.i'
      include 'potent.i'
      include 'scales.i'
      integer i,j,nvar
      integer mvar,next
      integer niter,ncalls
      integer nbigang
      integer maxbigang
      real*8 fgvalue,eps
      real*8 grdmin,precise
      real*8 f,f0,f0old
      real*8 fprime,f0prime
      real*8 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 x(maxopt),x0(maxopt)
      real*8 x0old(maxopt)
      real*8 g(maxopt),search(maxopt)
      real*8 s(maxopt),w(maxopt)
      real*8 k(maxopt),k0(maxopt)
      real*8 m(maxopt),n(maxopt)
      real*8 p(maxopt),q(maxopt)
      real*8 u(maxopt),hq(maxopt)
      real*8 h(maxopt,maxopt)
      logical restart,done
      character*9 status
      character*20 keyword
      character*80 record
      save h
      external fgvalue,writeout
c
c
c     initialization and set-up for the optimization
c
      if (nvar .gt. maxopt) then
         write (iout,10)
   10    format (/,' OCVM  --  Too many Parameters,',
     &              ' Increase value of MAXOPT')
         return
      end if
      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
      maxbigang = 2
      eps = precise (2)
      restart = .true.
      done = .false.
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 = -1000000.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)
         if (keyword(1:7) .eq. 'FCTMIN ') then
            read (record(next:80),*,err=20)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (record(next:80),*,err=20)  maxiter
         else if (keyword(1:9) .eq. 'NEXTITER ') then
            read (record(next:80),*,err=20)  nextiter
         else if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (record(next:80),*,err=20)  iprint
         else if (keyword(1:9) .eq. 'WRITEOUT ') then
            read (record(next:80),*,err=20)  iwrite
         else if (keyword(1:7) .eq. 'HGUESS ') then
            read (record(next:80),*,err=20)  hguess
         else if (keyword(1:8) .eq. 'STEPMAX ') then
            read (record(next:80),*,err=20)  stpmax
         else if (keyword(1:7) .eq. 'ANGMAX ') then
            read (record(next:80),*,err=20)  angmax
         end if
   20    continue
      end do
c
c     get initial function and gradient values, then print header
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
      if (iprint .gt. 0) then
         write (iout,30)
   30    format (/,' Optimally Conditioned Variable Metric',
     &             ' Optimization :')
         write (iout,40)
   40    format (/,' VM Iter    F Value       G RMS     F Move',
     &              '    X Move      Angle   FG Call',/)
      end if
c
c     step 1:  selection of the search direction and step
c
c     set the "h" matrix to a diagonal matrix on first iteration or
c     if the angle between the "s" vector and the negative gradient
c     has been bigger than angmax for maxbigang straight iterations
c
      dowhile (.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.0d7 .and. f0.gt.-1.0d6 .and.
     &                    grms.lt.1.0d6) then
                  write (iout,50)  niter,f0,grms,ncalls
   50             format (i6,f13.4,f12.4,32x,i9)
               else
                  write (iout,60)  niter,f0,grms,ncalls
   60             format (i6,d13.4,d12.4,32x,i9)
               end if
            else if (mod(niter,iprint) .eq. 0) then
               if (f0.lt.1.0d7 .and. f0.gt.-1.0d6 .and.
     &             grms.lt.1.0d6 .and. fmove.lt.1.0d5) then
                  write (iout,70)  niter,f0,grms,fmove,
     &                             xmove,sgangle,ncalls
   70             format (i6,f13.4,f12.4,f11.4,f10.4,f11.4,i9)
               else
                  write (iout,80)  niter,f0,grms,fmove,
     &                             xmove,sgangle,ncalls
   80             format (i6,d13.4,d12.4,d11.4,f10.4,f11.4,i9)
               end if
            end if
         end if
         if (iwrite .gt. 0) then
            if (niter.ne.0 .and. mod(niter,iwrite).eq.0) then
               call writeout (x,niter)
            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 (iwrite .gt. 0) then
               if (mod(niter,iwrite) .ne. 0) then
                  call writeout (x,niter)
               end if
            end if
            if (iprint .gt. 0) then
               if (niter.ne.0 .and. mod(niter,iprint).ne.0) then
                  if (f0.lt.1.0d7 .and. f0.gt.-1.0d6 .and.
     &                grms.lt.1.0d6 .and. fmove.lt.1.0d5) then
                     write (iout,90)  niter,f0,grms,fmove,
     &                                xmove,sgangle,ncalls
   90                format (i6,f13.4,f12.4,f11.4,f10.4,f11.4,i9)
                  else
                     write (iout,100)  niter,f0,grms,fmove,
     &                                 xmove,sgangle,ncalls
  100                format (i6,d13.4,d12.4,d11.4,f10.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,110)  status
  110             format (/,' OCVM  --  Incomplete Convergence',
     &                       ' due to ',a9)
               else
                  write (iout,120)  status
  120             format (/,' OCVM  --  Normal Termination',
     &                       ' due to ',a9)
               end if
            end if
            done = .true.
            goto 170
         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
            nbigang = nbigang + 1
         else
            nbigang = 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
  130    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     check here to see if we should done without meeting
c     usual termination criteria; quit if -f0prime is too small
c
         if (-f0prime .lt. eps) then
            if (iwrite .gt. 0) then
               if (mod(niter,iwrite) .ne. 0) then
                  call writeout (x,niter)
               end if
            end if
            if (iprint .gt. 0) then
               if (niter.ne.0 .and. mod(niter,iprint).ne.0) then
                  if (f0.lt.1.0d7 .and. f0.gt.-1.0d6 .and.
     &                       grms.lt.1.0d6) then
                     write (iout,140)  niter,f0,grms,0.0,0.0,
     &                                 sgangle,ncalls
  140                format (i6,f13.4,f12.4,f11.4,f10.4,f11.4,i9)
                  else
                     write (iout,150)  niter,f0,grms,0.0,0.0,
     &                                 sgangle,ncalls
  150                format (i6,d13.4,d12.4,f11.4,f10.4,f11.4,i9)
                  end if
               end if
               status = 'SmallMove'
               write (iout,160)  status
  160          format (/,' OCVM  --  Incomplete Convergence',
     &                    ' due to ',a9)
            end if
            done = .true.
            goto 170
         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 130
         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
            do j = 1, mvar
               s(j) = s(j) * zeta
            end do
            f0prime = f0prime * zeta
            goto 130
         end if
c
c     check to see if we need to update
c
         if (nbigang .ge. maxbigang) then
            restart = .true.
            goto 170
         end if
         m2 = 0.0d0
         do j = 1, mvar
            m2 = m2 + m(j)**2
         end do
         if (m2 .lt. eps) then
            goto 170
         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
  170    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 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     note this routine is system dependent since the Fortran 90
c     standard is not supported by many Fortran 77 compilers; only
c     one of the various implementations below should be activated
c     by removing comment characters
c
c
      subroutine openend (iunit,name)
      implicit none
      integer iunit
      character*60 name
c
c
c     standard Fortran 90, unavailable in many Fortran 77 compilers
c
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     manually read to the end of file, slow but always correct
c
      open (unit=iunit,file=name,status='old')
      dowhile (.true.)
         read (iunit,10,err=20,end=20)
   10    format ()
      end do
   20 continue
      return
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'scales.i'
      include 'usage.i'
      integer i,j,imin
      integer nvar,freeunit
      real*8 optimiz1,minimum
      real*8 grdmin,gnorm,grms
      real*8 xx(maxopt)
      real*8 derivs(3,maxatm)
      character*60 minfile
      character*80 string
      logical exist
      external optimiz1
      external writeout
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
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     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, n
         if (use(i)) then
            do j = 1, 3
               nvar = nvar + 1
               scale(nvar) = 12.0d0
            end do
         end if
      end do
c
c     check for too many parameters to be optimized
c
      if (nvar .gt. maxopt) then
         write (iout,40)
   40    format (/,' OPTIMIZE  --  Too many Parameters,',
     &              ' Increase value of MAXOPT')
         call fatal
      end if
c
c     scale the coordinates of each active atom
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            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 if
      end do
c
c     make the call to the optimization routine
c
      call ocvm (nvar,xx,minimum,grdmin,optimiz1,writeout)
c
c     unscale the final coordinates for active atoms
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     compute the final function and RMS gradient values
c
      call gradient (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, n
         if (use(i)) then
            do j = 1, 3
               gnorm = gnorm + derivs(j,i)**2
            end do
         end if
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / sqrt(dble(nvar/3))
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)  minimum,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)  minimum,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)  minimum,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)  minimum,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)  minimum,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)  minimum,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     ##  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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'scales.i'
      include 'usage.i'
      integer i,nvar
      real*8 optimiz1,e
      real*8 xx(maxopt)
      real*8 g(maxopt)
      real*8 derivs(3,maxatm)
c
c
c     translate 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     compute and store the energy and gradient
c
      call gradient (e,derivs)
      optimiz1 = e
c
c     store atom gradients as optimization gradient, also
c     translate the coordinates of each active atom; the
c     latter may be needed when using periodic boundaries
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            xx(nvar) = x(i) * scale(nvar)
            g(nvar) = derivs(1,i) / scale(nvar)
            nvar = nvar + 1
            xx(nvar) = y(i) * scale(nvar)
            g(nvar) = derivs(2,i) / scale(nvar)
            nvar = nvar + 1
            xx(nvar) = z(i) * scale(nvar)
            g(nvar) = derivs(3,i) / scale(nvar)
         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 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
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'omega.i'
      include 'scales.i'
      include 'zcoord.i'
      integer i,imin,freeunit
      real*8 optirot1,minimum
      real*8 grdmin,gnorm,grms
      real*8 xx(maxopt)
      real*8 derivs(maxrot)
      character*60 minfile
      character*80 string
      logical exist
      external optirot1
      external writeout
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getint
      call mechanic
      call initrot
c
c     check for too many parameters to be optimized
c
      if (nomega .gt. maxopt) then
         write (iout,10)
   10    format (/,' OPTIROT  --  Too many Parameters,',
     &              ' Increase value of MAXOPT')
         call fatal
      end if
c
c     get termination criterion as RMS torsional gradient
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 Torsion Criterion',
     &              ' [0.01] :  ',$)
         read (input,40)  grdmin
   40    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     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     get optimization parameters as scaled dihedral angles
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,writeout)
c
c     unscale the final dihedral angle values
c
      do i = 1, nomega
         dihed(i) = xx(i) / scale(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
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     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,50)  minimum,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)  minimum,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)  minimum,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)  minimum,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)  minimum,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)  minimum,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 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)
      implicit none
      include 'sizes.i'
      include 'math.i'
      include 'omega.i'
      include 'scales.i'
      include 'zcoord.i'
      integer i
      real*8 optirot1,e
      real*8 xx(maxopt)
      real*8 g(maxopt)
      real*8 derivs(maxrot)
c
c
c     translate optimization variables into dihedrals
c
      do i = 1, nomega
         dihed(i) = xx(i) / scale(i)
         ztors(zline(i)) = dihed(i) * radian
      end do
c
c     get coordinates, then compute energy and gradient
c
      call makexyz
      call gradrot (e,derivs)
      optirot1 = e
c
c     store angle gradients as optimization gradient
c
      do i = 1, nomega
         g(i) = derivs(i) / scale(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     ##  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
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'output.i'
      include 'rigid.i'
      integer i,j,nvar
      integer imin,freeunit
      real*8 optrigid1,minimum
      real*8 grdmin,grms,gnorm
      real*8 xx(maxopt)
      real*8 derivs(6,maxgrp)
      character*60 minfile
      character*80 string
      logical exist
      external optrigid1
      external writeout
c
c
c     set up the molecular mechanics calculation
c
      call initial
      call getxyz
      call mechanic
      call orient
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     transfer 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     check for too many parameters to be optimized
c
      if (nvar .gt. maxopt) then
         write (iout,40)
   40    format (/,' OPTRIGID  --  Too many Parameters,',
     &              ' Increase value of MAXOPT')
         call fatal
      end if
c
c     make the call to the optimization routine
c
      coordtype = 'rigidbody'
      call ocvm (nvar,xx,minimum,grdmin,optrigid1,writeout)
c
c     transfer 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     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     write out the final function and gradient values
c
      if (digits .ge. 8) then
         if (grms .gt. 1.0d-8) then
            write (iout,50)  minimum,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)  minimum,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)  minimum,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)  minimum,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)  minimum,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)  minimum,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     ##  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)
      implicit none
      include 'sizes.i'
      include 'group.i'
      include 'math.i'
      include 'rigid.i'
      integer i,j,nvar
      real*8 optrigid1,e
      real*8 xx(maxopt)
      real*8 g(maxopt)
      real*8 derivs(6,maxgrp)
c
c
c     translate 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     compute and store the energy and gradient
c
      call rigidxyz
      call gradrgd (e,derivs)
      call xyzrigid
      optrigid1 = e
c
c     translate rigid body variables to optimization arrays
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            xx(nvar) = rbc(j,i)
            g(nvar) = derivs(j,i)
         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 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 two
c     central atoms are both pisystem atoms
c
c
      subroutine orbital
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'iounit.i'
      include 'keys.i'
      include 'piorbs.i'
      include 'potent.i'
      include 'tors.i'
      integer i,j,k,m,ib,ic
      integer iorb,jorb,next
      integer piatoms(maxpi)
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     set the default values for the pisystem variables
c
      do i = 1, maxpi
         piatoms(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:80)
            read (string,*,err=10,end=10)  (piatoms(k),k=1,maxpi)
         end if
   10    continue
      end do
c
c     quit if no pisystem was found for consideration
c
      if (piatoms(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
      dowhile (piatoms(i) .ne. 0)
         if (piatoms(i) .gt. 0) then
            listpi(piatoms(i)) = .true.
            i = i + 1
         else
            do j = -piatoms(i), piatoms(i+1)
               listpi(j) = .true.
            end do
            i = i + 2
         end if
      end do
      norbit = 0
      do i = 1, n
         if (listpi(i)) then
            norbit = norbit + 1
            iorbit(norbit) = i
         end if
      end do
c
c     quit if the molecule contains too many piorbitals
c
      if (norbit .gt. maxpi) then
         write (iout,20)
   20    format (' ORBITAL  --  Too many Pi-Orbitals;',
     &           ' Increase MAXPI')
         call fatal
      end if
c
c     find three atoms which define a plane
c     perpendicular to each orbital
c
      call piplane
c
c     find and store the pisystem bonds
c
      npibond = 0
      do i = 1, norbit-1
         iorb = iorbit(i)
         do j = i, norbit
            jorb = iorbit(j)
            do k = 1, n12(iorb)
               if (i12(k,iorb) .eq. jorb) then
                  npibond = npibond + 1
                  do m = 1, nbond
                     if (iorb.eq.ibnd(1,m) .and.
     &                   jorb.eq.ibnd(2,m)) then
                        pibond(1,npibond) = m
                        pibond(2,npibond) = i
                        pibond(3,npibond) = j
                        goto 30
                     end if
                  end do
   30             continue
               end if
            end do
         end do
      end do
c
c     find and store the pisystem torsions
c
      npitors = 0
      do i = 1, ntors
         ib = itors(2,i)
         ic = itors(3,i)
         if (listpi(ib) .and. listpi(ic)) then
            do j = 1, npibond
               k = pibond(1,j)
               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
                  npitors = npitors + 1
                  pitors(1,npitors) = i
                  pitors(2,npitors) = j
                  goto 40
               end if
            end do
   40       continue
         end if
      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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      include 'piorbs.i'
      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 i = 1, norbit
         iorb = iorbit(i)
         attach = n12(iorb)
         atmnum = atomic(iorb)
         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,iorb)
            piperp(2,i) = i12(2,iorb)
            piperp(3,i) = i12(3,iorb)
            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) = iorb
            piperp(2,i) = i12(1,iorb)
            piperp(3,i) = i12(2,iorb)
            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) = iorb
            do j = 1, n12(iorb)
               trial = i12(j,iorb)
               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,iorb)
            beta = i12(1,alpha)
            if (beta .eq. iorb)  beta = i12(2,alpha)
            piperp(1,i) = iorb
            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,iorb)
            do j = 1, n12(alpha)
               trial = i12(j,alpha)
               if (trial.ne.iorb .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(3,i) = iorb
            piperp(3,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,iorb)
            if ((n12(alpha).eq.2 .and. atomic(alpha).eq.6) .or.
     &          (n12(alpha).eq.1 .and. atomic(alpha).eq.7))
     &         alpha = i12(2,iorb)
            do j = 1, n12(iorb)
               trial = i12(j,iorb)
               if (trial.ne.iorb .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.iorb .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.iorb .or. gamma.eq.alpha)  gamma = i12(2,beta)
            piperp(1,i) = iorb
            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)  iorb
   10       format(/,' PIPLANE  --  Failure to Define a',
     &                ' p-Orbital Plane for Atom',i6)
            call fatal
         end if
      end do
      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 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'group.i'
      include 'rigid.i'
      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     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     Herbert Goldstein, "Classical Mechanics, 2nd Edition",
c     Addison-Wesley, Reading, MA, 1980; see the Euler angle
c     xyz convention in Appendix B
c
c
      subroutine xyzrigid
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'atmtyp.i'
      include 'group.i'
      include 'rigid.i'
      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),vec(3,3)
      real*8 work1(3),work2(3)
      real*8 tensor(3,3),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 inertial 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,3,tensor,moment,vec,work1,work2)
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)
      implicit none
      include 'math.i'
      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 err(3)
c
c
c     set the tolerance for Euler angles and rotation elements
c
      eps = 1.0d-8
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
         err(i) = .false.
         if (abs(a(i,i)-b(i)) .gt. eps)  err(i) = .true.
      end do
c
c     alter Euler angles to get correct rotation matrix values
c
      if (err(1) .and. err(2))  phi = phi - sign(pi,phi)
      if (err(1) .and. err(3))  theta = -theta + sign(pi,theta)
      if (err(2) .and. err(3))  psi = psi - sign(pi,psi)
      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     Herbert Goldstein, "Classical Mechanics, 2nd Edition",
c     Addison-Wesley, Reading, MA, 1980; see the Euler angle
c     xyz convention in Appendix B
c
c
      subroutine rigidxyz
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'group.i'
      include 'rigid.i'
      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 logical dimension of matrix to orthogonalize
c     mp    first physical dimension of matrix storage area
c     n     second logical dimension of matrix to orthogonalize
c     a     matrix to orthogonalize; contains result on exit
c
c
      subroutine orthog (m,mp,n,a)
      implicit none
      integer i,j,k
      integer m,n,mp
      real*8 rkk,rkj
      real*8 a(mp,*)
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)  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)
      implicit none
      include 'units.i'
      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     this version is adapted from the code provided 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,nn,max,maxx
      integer novi,ia(200),ib(200),idsga(5),idsgb(5)
      integer icosa(2),icosb(2),isina(4),isinb(4)
      real*8 s(3),r,za,zb,fact(15),cjkm
      real*8 a(20),b(20),c(200),cbase(20),theta(6)
      real*8 cosa(2),cosb(2),sinab(4),dsiga(5),dsigb(5)
      real*8 an,ana,anb,anr,rhalf,coef,p,pt
      logical done
      save icosa,icosb,cosa,cosb
      save idsga,idsgb,dsiga,dsigb
      save isina,isinb,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
      dowhile (.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
      subroutine polyp (c,ia,ib,max,d,iaa,ibb,n)
      implicit none
      integer i,j,k,m,max,n
      integer ia(200),ib(200),iaa(n),ibb(n)
      real*8 c(200),d(n)
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
      function cjkm (j,k,m)
      implicit none
      integer i,j,k,m,min,max,id,idd,ip1
      real*8 cjkm,fact(15),b1,b2,sum
      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
      subroutine aset (alpha,n,a)
      implicit none
      integer i,n
      real*8 alpha,a(20),alp
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
      subroutine bset (beta,n,b)
      implicit none
      real*8 eps
      parameter (eps=0.000001d0)
      integer i,j,n
      real*8 beta,b(20),bmax
      real*8 betam,d1,d2
      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
      function bmax (beta,n)
      implicit none
      real*8 eps
      parameter (eps=0.0000001d0)
      integer n
      real*8 bmax,beta,b,top,bot
      real*8 sum,fi,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
      dowhile (.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) 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
      implicit none
      include 'sizes.i'
      include 'align.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'linmin.i'
      include 'minima.i'
      include 'output.i'
      include 'paths.i'
      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
      real*8 path1
      real*8 grdmin,potnrg
      real*8 g(maxvar)
      real*8 p(maxvar)
      real*8 ge(maxvar)
      real*8 temp(maxvar,7)
      real*8 xtmp(maxatm)
      real*8 ytmp(maxatm)
      real*8 ztmp(maxatm)
      logical exist
      character*80 string
      external path1
      external writeout
c
c
c     initialize some constants and variables
c
      call initial
c
c     get and store the initial structure coordinates
c
      call getxyz
      do i = 1, n
         p0(3*i-2) = x(i)
         p0(3*i-1) = y(i)
         p0(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
      nvar = 3 * n
      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     store the coordinates for the superimposed product
c
      do i = 1, n
         p1(3*i-2) = x(i)
         p1(3*i-1) = y(i)
         p1(3*i) = z(i)
      end do
c
c     write out the starting potential energy values
c
      epot0 = potnrg (p0,g)
      epot1 = potnrg (p1,g)
      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) = p1(i) - p0(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) * p0(iz)
         gc(iz,5) = -mass(i) * p0(iy)
         gc(ix,6) = -mass(i) * p0(iz)
         gc(iy,6) = 0.0d0
         gc(iz,6) = mass(i) * p0(ix)
         gc(ix,7) = mass(i) * p0(iy)
         gc(iy,7) = -mass(i) * p0(ix)
         gc(iz,7) = 0.0d0
      end do
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,maxvar,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 the matrix inversion to get A matrix
c     which transforms C into sigma space
c
      call invert (7,7,acoeff)
c
c     set the current path point to be the reactant
c
      do i = 1, nvar
         p(i) = p0(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) = p0(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,writeout)
c        call ocvm (nvar,p,etot,grdmin,path1,writeout)
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 writeout (p,ipath)
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 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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'paths.i'
      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(maxvar)
      real*8 gt(maxvar)
      real*8 ge(maxvar)
c
c
c     get the value of the potential energy
c
      nvar = 3 * n
      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)-p0(ix))
         cnst(3) = cnst(3) + mass(i) * (p(iy)-p0(iy))
         cnst(4) = cnst(4) + mass(i) * (p(iz)-p0(iz))
         cnst(5) = cnst(5) + mass(i) * (p(iy)*p0(iz)-p(iz)*p0(iy))
         cnst(6) = cnst(6) + mass(i) * (p(iz)*p0(ix)-p(ix)*p0(iz))
         cnst(7) = cnst(7) + mass(i) * (p(ix)*p0(iy)-p(iy)*p0(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
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  function potnrg  --  potential energy and gradient  ##
c     ##                                                      ##
c     ##########################################################
c
c
      function potnrg (xx,g)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'paths.i'
      integer i
      real*8 energy
      real*8 potnrg
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 deriv(3,maxatm)
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     compute potential energy and Cartesian derivatives
c
      call gradient (energy,deriv)
c
c     set the energy value and gradient vector
c
      potnrg = energy
      do i = 1, n
         g(3*i-2) = deriv(1,i)
         g(3*i-1) = deriv(2,i)
         g(3*i) = deriv(3,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     ##  program pdbxyz  --  Protein Data Bank to XYZ coordinates  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "pdbxyz" takes as input a Protein Data Bank file and then
c     converts to and writes out a Cartesian coordinates file and,
c     for polypeptides, a sequence file
c
c
      program pdbxyz
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'files.i'
      include 'katoms.i'
      include 'pdb.i'
      include 'resdue.i'
      integer i,j,it
      integer ixyz,next
      integer last,freeunit
      integer size(maxatm)
      real*8 xi,yi,zi,rij
      real*8 rcut,rmax(0:9)
      logical peptide,nucacid
      character*1 letter
      character*3 resname
      character*3 reslast
      character*60 coordfile
c
c
c     get the Protein Data Bank file and a parameter set
c
      call initial
      call getpdb
      call field
c
c     decide whether the system contains only polypeptides
c
      peptide = .false.
      reslast = '***'
      do i = 1, npdb
         if (pdbtyp(i) .eq. 'ATOM  ') then
            resname = resnam(i)
            if (resname .ne. reslast) then
               reslast = resname
               do j = 1, maxamino
                  if (resname .eq. amino(j)) then
                     peptide = .true.
                     goto 10
                  end if
               end do
               peptide = .false.
               goto 20
   10          continue
            end if
         end if
      end do
   20 continue
c
c     decide whether the system contains only nucleic acids
c
      nucacid = .false.
      reslast = '***'
      do i = 1, npdb
         if (pdbtyp(i) .eq. 'ATOM  ') then
            resname = resnam(i)
            if (resname .ne. reslast) then
               reslast = resname
               do j = 1, maxnuc
                  if (resname .eq. nuclz(j)) then
                     nucacid = .true.
                     goto 30
                  end if
               end do
               nucacid = .false.
               goto 40
   30          continue
            end if
         end if
      end do
   40 continue
c
c     special translation mechanism used for polypeptides
c
      if (peptide) then
         call ribosome
         last = n
         do i = last, 1, -1
            if (type(i) .eq. 0)  call delete (i)
         end do
c
c     special translation mechanism used for nucleic acids
c
      else if (nucacid) then
         call ligase
         last = n
         do i = last, 1, -1
            if (type(i) .eq. 0)  call delete (i)
         end do
c
c     get general atom properties for distance-based connectivity
c
      else
         n = npdb
         do i = 1, n
            x(i) = xpdb(i)
            y(i) = ypdb(i)
            z(i) = zpdb(i)
            name(i) = atmnam(i)(2:4)
            n12(i) = 0
            next = 1
            call getnumb (resnam(i),type(i),next)
            it = type(i)
            if (it .eq. 0) then
               letter = name(i)(1:1)
               call upcase (letter)
               if (letter .eq. 'H') then
                  size(i) = 1
               else if (letter .eq. 'C') then
                  size(i) = 2
               else if (letter .eq. 'N') then
                  size(i) = 2
               else if (letter .eq. 'O') then
                  size(i) = 2
               else if (letter .eq. 'P') then
                  size(i) = 3
               else if (letter .eq. 'S') then
                  size(i) = 3
               else
                  size(i) = 0
               end if
            else if (ligand(it) .eq. 0) then
               size(i) = 0
            else if (atmnum(it) .le. 2) then
               size(i) = 1
            else if (atmnum(it) .le. 10) then
               size(i) = 2
            else
               size(i) = 3
            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(6) = 2.0d0
         rmax(9) = 2.2d0
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(size(i)*size(j))
               rij = sqrt((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
      end if
c
c     sort the attached atom lists into ascending order
c
      do i = 1, n
         call sort (n12(i),i12(1,i))
      end do
c
c     check for atom pairs with identical coordinates
c
      call chkxyz
c
c     write out the coordinates file
c
      ixyz = freeunit ()
      coordfile = filename(1:leng)//'.xyz'
      call version (coordfile,'new')
      open (unit=ixyz,file=coordfile,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 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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'fields.i'
      include 'iounit.i'
      include 'katoms.i'
      include 'sequen.i'
      include 'pdb.i'
      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) .ne. 0) then
               name(n) = symbol(type(n))
            else
               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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'fields.i'
      include 'katoms.i'
      include 'pdb.i'
      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) .ne. 0) then
            name(n) = symbol(type(n))
         else
            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)
      implicit none
      include 'sizes.i'
      include 'couple.i'
      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)
      implicit none
      include 'sizes.i'
      include 'pdb.i'
      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 (atmnam(i) .eq. name) then
            ipdb = i
            goto 10
         end if
      end do
   10 continue
      return
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'iounit.i'
      include 'pdb.i'
      include 'resdue.i'
      include 'sequen.i'
      integer i,j,k,nres
      integer iseq,ityp
      integer start,stop
      integer freeunit
      integer cyxtyp
      integer ncys,ndisulf
      integer resatm(2,maxres)
      integer ni(maxres),cai(maxres)
      integer ci(maxres),oi(maxres)
      integer icys(maxres),idisulf(2,maxres)
      integer ntyp(maxamino),catyp(maxamino)
      integer ctyp(maxamino),hntyp(maxamino)
      integer otyp(maxamino),hatyp(maxamino)
      integer nntyp(maxamino),cantyp(maxamino)
      integer cntyp(maxamino),hnntyp(maxamino)
      integer ontyp(maxamino),hantyp(maxamino)
      integer nctyp(maxamino),cactyp(maxamino)
      integer cctyp(maxamino),hnctyp(maxamino)
      integer octyp(maxamino),hactyp(maxamino)
      real*8 rik,xcys(maxres)
      real*8 ycys(maxres)
      real*8 zcys(maxres)
      logical newchain
      logical midchain
      logical endchain
      character*3 resname
      character*4 atmname
      character*60 seqfile
c
c     biopolymer atom types for amino acid backbone atoms
c
      data ntyp    /   1,   7,  15,  27,  41,  55,  65,  77,  87,
     &                96, 107, 122, 138, 161, 178, 194, 210, 220,
     &               232, 244, 258, 271, 287, 304, 318, 325,   0,
     &                 0,   0,   0,   1 /
      data catyp   /   2,   8,  16,  28,  42,  56,  66,  78,  88,
     &                97, 108, 123, 139, 162, 179, 195, 211, 221,
     &               233, 245, 259, 272, 288, 305, 319, 326,   0,
     &                 0,   0,   0,   2 /
      data ctyp    /   3,   9,  17,  29,  43,  57,  67,  79,  89,
     &                98, 109, 124, 140, 163, 180, 196, 212, 222,
     &               234, 246, 260, 273, 289, 306, 320, 327,   0,
     &                 0,   0,   0,   3 /
      data hntyp   /   4,  10,  18,  30,  44,  58,  68,  80,  90,
     &                 0, 110, 125, 141, 164, 181, 197, 213, 223,
     &               235, 247, 261, 274, 290, 307, 321, 328,   0,
     &                 0,   0,   0,   4 /
      data otyp    /   5,  11,  19,  31,  45,  59,  69,  81,  91,
     &                99, 111, 126, 142, 165, 182, 198, 214, 224,
     &               236, 248, 262, 275, 291, 308, 322, 329,   0,
     &                 0,   0,   0,   5 /
      data hatyp   /   6,  12,  20,  32,  46,  60,  70,  82,  92,
     &               100, 112, 127, 143, 166, 183, 199, 215, 225,
     &               237, 249, 263, 276, 292, 309,   0, 330,   0,
     &                 0,   0,   0,   6 /
c
c     biopolymer atom types for N-terminal backbone atoms
c
      data nntyp   / 350, 356, 362, 368, 374, 380, 386, 392, 398,
     &               404, 412, 418, 424, 430, 436, 442, 448, 454,
     &               460, 466, 472, 478, 484, 490, 496, 325,   0,
     &                 0,   0,   0, 350 /
      data cantyp  / 351, 357, 363, 369, 375, 381, 387, 393, 399,
     &               405, 413, 419, 425, 431, 437, 443, 449, 455,
     &               461, 467, 473, 479, 485, 491, 497, 326,   0,
     &               340,   0,   0, 351 /
      data cntyp   / 352, 358, 364, 370, 376, 382, 388, 394, 400,
     &               406, 414, 420, 426, 432, 438, 444, 450, 456,
     &               462, 468, 474, 480, 486, 492, 498, 327, 337,
     &               342,   0,   0, 352 /
      data hnntyp  / 353, 359, 365, 371, 377, 383, 389, 395, 401,
     &               407, 415, 421, 427, 433, 439, 445, 451, 457,
     &               463, 469, 475, 481, 487, 493, 499, 328,   0,
     &                 0,   0,   0, 353 /
      data ontyp   / 354, 360, 366, 372, 378, 384, 390, 396, 402,
     &               408, 416, 422, 428, 434, 440, 446, 452, 458,
     &               464, 470, 476, 482, 488, 494, 500, 329, 339,
     &               343,   0,   0, 354 /
      data hantyp  / 355, 361, 367, 373, 379, 385, 391, 397, 403,
     &               409, 417, 423, 429, 435, 441, 447, 453, 459,
     &               465, 471, 477, 483, 489, 495,   0, 330, 338,
     &               341,   0,   0, 355 /
c
c     biopolymer atom types for C-terminal backbone atoms
c
      data nctyp   / 501, 507, 513, 519, 525, 531, 537, 543, 549,
     &               555, 560, 566, 572, 578, 584, 590, 596, 602,
     &               608, 614, 620, 626, 632, 638, 644,   0,   0,
     &                 0, 344, 346, 501 /
      data cactyp  / 502, 508, 514, 520, 526, 532, 538, 544, 550,
     &               556, 561, 567, 573, 579, 585, 591, 597, 603,
     &               609, 615, 621, 627, 633, 639, 645,   0,   0,
     &                 0,   0, 348, 502 /
      data cctyp   / 503, 509, 515, 521, 527, 533, 539, 545, 551,
     &               557, 562, 568, 574, 580, 586, 592, 598, 604,
     &               610, 616, 622, 628, 634, 640, 646,   0,   0,
     &                 0,   0,   0, 503 /
      data hnctyp  / 504, 510, 516, 522, 528, 534, 540, 546, 552,
     &                 0, 563, 569, 575, 581, 587, 593, 599, 605,
     &               611, 617, 623, 629, 635, 641, 647,   0,   0,
     &                 0, 345, 347, 504 /
      data octyp   / 505, 511, 517, 523, 529, 535, 541, 547, 553,
     &               558, 564, 570, 576, 582, 588, 594, 600, 606,
     &               612, 618, 624, 630, 636, 642, 648,   0,   0,
     &                 0,   0,   0, 505 /
      data hactyp  / 506, 512, 518, 524, 530, 536, 542, 548, 554,
     &               559, 565, 571, 577, 583, 589, 595, 601, 607,
     &               613, 619, 625, 631, 637, 643,   0,   0,   0,
     &                 0,   0, 349, 506 /
c
c
c     set a pointer to the first and last atom of each residue
c
      nres = 0
      k = 0
      do i = 1, npdb
         if (pdbtyp(i) .eq. 'ATOM  ') then
            if (resnum(i) .ne. k) then
               k = resnum(i)
               if (nres .ne. 0)  resatm(2,nres) = i - 1
               nres = nres + 1
               resatm(1,nres) = i
            end if
         end if
      end do
      if (nres .ne. 0)  resatm(2,nres) = npdb
c
c     get the three-letter sequence and code for each residue
c
      nseq = nres
      do i = 1, nres
         start = resatm(1,i)
         resname = resnam(start)
         seq(i) = 'UNK'
         seqtyp(i) = maxamino
         do k = 1, maxamino
            if (resname .eq. amino(k)) then
               seq(i) = amino(k)
               seqtyp(i) = k
               goto 10
            end if
         end do
   10    continue
      end do
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 = resnam(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
            rik = sqrt((xcys(i)-xcys(k))**2 + (ycys(i)-ycys(k))**2
     &                         + (zcys(i)-zcys(k))**2)
            if (rik .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, nres
         icys(i) = 0
      end do
      do i = 1, ndisulf
         icys(idisulf(1,i)) = 1
         icys(idisulf(2,i)) = 1
      end do
c
c     set the current atom to be the first atom
c
      n = 1
      newchain = .true.
c
c     locate and assign the atoms that make up each residue
c
      do i = 1, nres
         ityp = seqtyp(i)
         start = resatm(1,i)
         stop = resatm(2,i)
         resname = resnam(start)
c
c     check that the maximum allowed atoms is not exceeded
c
         if (n+25 .gt. maxatm) then
            write (iout,20)  maxatm
   20       format (/,' RIBOSOME  --  The Maximum of',i6,' Atoms',
     &                 ' has been Exceeded')
            call fatal
         end if
c
c     check for a cysteine that should be changed to cystine
c
         if (icys(i) .eq. 1) then
            resname = 'CYX'
            seqtyp(i) = cyxtyp
            ityp = cyxtyp
         end if
c
c     test for the final residue of a peptide chain
c
         endchain = .false.
         do k = 1, nchain
            if (i .eq. ichain(2,k))  endchain = .true.
         end do
c
c     residue not at start or end of chain is in the middle
c
         if (newchain .or. endchain) then
            midchain = .false.
         else
            midchain = .true.
         end if
c
c     build the amide nitrogen of the current residue
c
         call findatm (' N  ',start,stop,k)
         if (k .ne. 0)  ni(i) = n
         if (midchain) then
            j = ntyp(ityp)
            call oldatm (k,j,ci(i-1),i)
         else if (newchain) then
            j = nntyp(ityp)
            call oldatm (k,j,0,i)
         else if (endchain) then
            j = nctyp(ityp)
            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 = ' CH3'
         call findatm (atmname,start,stop,k)
         if (k .ne. 0)  cai(i) = n
         if (midchain .or. nres.eq.1) then
            j = catyp(ityp)
            call oldatm (k,j,ni(i),i)
         else if (newchain) then
            j = cantyp(ityp)
            call oldatm (k,j,ni(i),i)
         else if (endchain) 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 (midchain) then
            j = ctyp(ityp)
            call oldatm (k,j,cai(i),i)
         else if (newchain) then
            j = cntyp(ityp)
            call oldatm (k,j,cai(i),i)
         else if (endchain) then
            j = cctyp(ityp)
            call oldatm (k,j,cai(i),i)
         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 (midchain) then
            j = otyp(ityp)
            call oldatm (k,j,ci(i),i)
         else if (newchain) then
            j = ontyp(ityp)
            call oldatm (k,j,ci(i),i)
         else if (endchain) then
            j = octyp(ityp)
            call oldatm (k,j,ci(i),i)
         end if
c
c     build the amide hydrogens of the current residue
c
         if (midchain) 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 (newchain) then
            j = hnntyp(ityp)
            if (resname .eq. 'PRO') then
               call findatm ('1H  ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0,
     &                         ci(i),0.0d0,0)
               call findatm ('2H  ',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 ('1H  ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0,
     &                         ci(i),180.0d0,0)
               call findatm ('2H  ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0,
     &                         ci(i),60.0d0,0)
               call findatm ('3H  ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0,
     &                         ci(i),-60.0d0,0)
            end if
         else if (endchain) then
            j = hnctyp(ityp)
            if (resname .eq. 'NH2') then
               call findatm ('1H  ',start,stop,k)
               call newatm (k,j,ni(i),1.01d0,ci(i-1),120.9d0,
     &                         cai(i-1),0.0d0,0)
               call findatm ('2H  ',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 ('1HA ',start,stop,k)
         else
            call findatm (' HA ',start,stop,k)
         end if
         if (midchain) then
            j = hatyp(ityp)
            call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0,
     &                      ci(i),109.5d0,-1)
         else if (newchain) 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 ('1H  ',start,stop,k)
               call newatm (k,j,cai(i),1.10d0,ci(i),109.5d0,
     &                         oi(i),180.0d0,0)
               call findatm ('2H  ',start,stop,k)
               call newatm (k,j,cai(i),1.10d0,ci(i),109.5d0,
     &                         oi(i),60.0d0,0)
               call findatm ('3H  ',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 (endchain) then
            j = hactyp(ityp)
            if (resname .eq. 'NME') then
               call findatm ('1H  ',start,stop,k)
               call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0,
     &                         ci(i-1),180.0d0,0)
               call findatm ('2H  ',start,stop,k)
               call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0,
     &                         ci(i-1),60.0d0,0)
               call findatm ('3H  ',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,start,stop,cai(i),ni(i),ci(i),icys(i))
c
c     build the terminal oxygen at the end of a peptide chain
c
         if (endchain) 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
c
c     next residue starts a new chain if current one just ended
c
         if (endchain) then
            newchain = .true.
         else
            newchain = .false.
         end if
      end do
c
c     connect the sulfur atoms involved in disulfide bonds
c
      do i = 1, ndisulf
         call addbond (icys(idisulf(1,i)),icys(idisulf(2,i)))
         if (i .eq. 1) then
            write (iout,30)
   30       format ()
         end if
         write (iout,40)  idisulf(1,i),idisulf(2,i)
   40    format (' Disulfide Bond formed between Residues :  ',2i5)
      end do
c
c     total number of atoms is one less than the current atom
c
      n = n - 1
c
c     write out the 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)
      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
      subroutine addside (resname,ires,start,stop,cai,ni,ci,cystype)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'sequen.i'
      integer i,ires
      integer start,stop
      integer cai,ni,ci
      integer cystype
      character*3 resname
c
c
c     glycine residue  (GLY)
c
      if (resname .eq. 'GLY') then
         call findatm ('2HA ',start,stop,i)
         if (ires .eq. 1) then
            call newatm (i,355,cai,1.10d0,ni,109.5d0,ci,109.5d0,1)
         else if (ires .eq. nseq) then
            call newatm (i,506,cai,1.10d0,ni,109.5d0,ci,109.5d0,1)
         else
            call newatm (i,6,cai,1.10d0,ni,109.5d0,ci,109.5d0,1)
         end if
c
c     alanine residue  (ALA)
c
      else if (resname .eq. 'ALA') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,13,cai,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,14,n-1,1.10d0,cai,110.2d0,ni,180.0d0,0)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,14,n-2,1.10d0,cai,110.2d0,ni,60.0d0,0)
         call findatm ('3HB ',start,stop,i)
         call newatm (i,14,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,21,cai,ires)
         call findatm (' CG1',start,stop,i)
         call oldatm (i,23,n-1,ires)
         call findatm (' CG2',start,stop,i)
         call oldatm (i,25,n-2,ires)
         call findatm (' HB ',start,stop,i)
         call newatm (i,22,n-3,1.10d0,cai,107.0d0,n-2,108.2d0,1)
         call findatm ('1HG1',start,stop,i)
         call newatm (i,24,n-3,1.10d0,n-4,111.6d0,cai,180.0d0,0)
         call findatm ('2HG1',start,stop,i)
         call newatm (i,24,n-4,1.10d0,n-5,111.6d0,cai,60.0d0,0)
         call findatm ('3HG1',start,stop,i)
         call newatm (i,24,n-5,1.10d0,n-6,111.6d0,cai,-60.0d0,0)
         call findatm ('1HG2',start,stop,i)
         call newatm (i,26,n-5,1.10d0,n-7,111.6d0,cai,180.0d0,0)
         call findatm ('2HG2',start,stop,i)
         call newatm (i,26,n-6,1.10d0,n-8,111.6d0,cai,60.0d0,0)
         call findatm ('3HG2',start,stop,i)
         call newatm (i,26,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,33,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,35,n-1,ires)
         call findatm (' CD1',start,stop,i)
         call oldatm (i,37,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,39,n-2,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,34,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,34,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
         call findatm (' HG ',start,stop,i)
         call newatm (i,36,n-5,1.10d0,n-6,107.0d0,n-4,108.2d0,1)
         call findatm ('1HD1',start,stop,i)
         call newatm (i,38,n-5,1.10d0,n-6,111.6d0,n-7,180.0d0,0)
         call findatm ('2HD1',start,stop,i)
         call newatm (i,38,n-6,1.10d0,n-7,111.6d0,n-8,60.0d0,0)
         call findatm ('3HD1',start,stop,i)
         call newatm (i,38,n-7,1.10d0,n-8,111.6d0,n-9,-60.0d0,0)
         call findatm ('1HD2',start,stop,i)
         call newatm (i,40,n-7,1.10d0,n-9,111.6d0,n-10,180.0d0,0)
         call findatm ('2HD2',start,stop,i)
         call newatm (i,40,n-8,1.10d0,n-10,111.6d0,n-11,60.0d0,0)
         call findatm ('3HD2',start,stop,i)
         call newatm (i,40,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,47,cai,ires)
         call findatm (' CG1',start,stop,i)
         call oldatm (i,49,n-1,ires)
         call findatm (' CG2',start,stop,i)
         call oldatm (i,51,n-2,ires)
         call findatm (' CD1',start,stop,i)
         if (i .eq. 0)  call findatm (' CD ',start,stop,i)
         call oldatm (i,53,n-2,ires)
         call findatm (' HB ',start,stop,i)
         call newatm (i,48,n-4,1.10d0,cai,107.0d0,n-3,108.2d0,-1)
         call findatm ('1HG1',start,stop,i)
         call newatm (i,50,n-4,1.10d0,n-5,109.5d0,n-2,109.5d0,1)
         call findatm ('2HG1',start,stop,i)
         call newatm (i,50,n-5,1.10d0,n-6,109.5d0,n-3,109.5d0,-1)
         call findatm ('1HG2',start,stop,i)
         call newatm (i,52,n-5,1.10d0,n-7,111.6d0,cai,180.0d0,0)
         call findatm ('2HG2',start,stop,i)
         call newatm (i,52,n-6,1.10d0,n-8,111.6d0,cai,60.0d0,0)
         call findatm ('3HG2',start,stop,i)
         call newatm (i,52,n-7,1.10d0,n-9,111.6d0,cai,-60.0d0,0)
         call findatm ('1HD1',start,stop,i)
         call newatm (i,54,n-7,1.10d0,n-9,111.6d0,n-10,180.0d0,0)
         call findatm ('2HD1',start,stop,i)
         call newatm (i,54,n-8,1.10d0,n-10,111.6d0,n-11,60.0d0,0)
         call findatm ('3HD1',start,stop,i)
         call newatm (i,54,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,61,cai,ires)
         call findatm (' OG ',start,stop,i)
         call oldatm (i,63,n-1,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,62,n-2,1.10d0,cai,109.2d0,n-1,109.5d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,62,n-3,1.10d0,cai,109.2d0,n-2,109.5d0,-1)
         call findatm (' HG ',start,stop,i)
         call newatm (i,64,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,71,cai,ires)
         call findatm (' OG1',start,stop,i)
         call oldatm (i,73,n-1,ires)
         call findatm (' CG2',start,stop,i)
         call oldatm (i,75,n-2,ires)
         call findatm (' HB ',start,stop,i)
         call newatm (i,72,n-3,1.10d0,cai,107.0d0,n-2,108.2d0,-1)
         call findatm (' HG1',start,stop,i)
         call newatm (i,74,n-3,0.94d0,n-4,106.9d0,cai,180.0d0,0)
         call findatm ('1HG2',start,stop,i)
         call newatm (i,76,n-3,1.10d0,n-5,111.6d0,cai,180.0d0,0)
         call findatm ('2HG2',start,stop,i)
         call newatm (i,76,n-4,1.10d0,n-6,111.6d0,cai,60.0d0,0)
         call findatm ('3HG2',start,stop,i)
         call newatm (i,76,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,83,cai,ires)
         call findatm (' SG ',start,stop,i)
         call oldatm (i,85,n-1,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,84,n-2,1.10d0,cai,109.5d0,n-1,107.5d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,84,n-3,1.10d0,cai,109.5d0,n-2,107.5d0,-1)
         call findatm (' HG ',start,stop,i)
         call newatm (i,86,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,93,cai,ires)
         call findatm (' SG ',start,stop,i)
         cystype = n
         call oldatm (i,95,n-1,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,94,n-2,1.10d0,cai,109.5d0,n-1,107.5d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,94,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,101,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,103,n-1,ires)
         call findatm (' CD ',start,stop,i)
         if (ires .eq. 1) then
            call oldatm (i,410,n-1,ires)
         else
            call oldatm (i,105,n-1,ires)
         end if
         call addbond (n-1,ni)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,102,n-3,1.10d0,cai,111.2d0,n-2,111.2d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,102,n-4,1.10d0,cai,111.2d0,n-3,111.2d0,-1)
         call findatm ('1HG ',start,stop,i)
         call newatm (i,104,n-4,1.10d0,n-5,111.2d0,n-3,111.2d0,1)
         call findatm ('2HG ',start,stop,i)
         call newatm (i,104,n-5,1.10d0,n-6,111.2d0,n-4,111.2d0,-1)
         if (ires .eq. 1) then
            call findatm ('1HD ',start,stop,i)
            call newatm (i,411,n-5,1.10d0,n-6,111.2d0,ni,111.2d0,1)
            call findatm ('2HD ',start,stop,i)
            call newatm (i,411,n-6,1.10d0,n-7,111.2d0,ni,111.2d0,-1)
         else
            call findatm ('1HD ',start,stop,i)
            call newatm (i,106,n-5,1.10d0,n-6,111.2d0,ni,111.2d0,1)
            call findatm ('2HD ',start,stop,i)
            call newatm (i,106,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,113,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,115,n-1,ires)
         call findatm (' CD1',start,stop,i)
         call oldatm (i,116,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,116,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,118,n-2,ires)
         call findatm (' CE2',start,stop,i)
         call oldatm (i,118,n-2,ires)
         call findatm (' CZ ',start,stop,i)
         call oldatm (i,120,n-1,ires)
         call addbond (n-1,n-3)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,114,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,114,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,117,n-7,1.09d0,n-8,120.0d0,n-9,0.0d0,0)
         call findatm (' HD2',start,stop,i)
         call newatm (i,117,n-7,1.09d0,n-9,120.0d0,n-10,0.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,119,n-7,1.09d0,n-9,120.0d0,n-10,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,119,n-7,1.09d0,n-9,120.0d0,n-11,180.0d0,0)
         call findatm (' HZ ',start,stop,i)
         call newatm (i,121,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,128,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,130,n-1,ires)
         call findatm (' CD1',start,stop,i)
         call oldatm (i,131,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,131,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,133,n-2,ires)
         call findatm (' CE2',start,stop,i)
         call oldatm (i,133,n-2,ires)
         call findatm (' CZ ',start,stop,i)
         call oldatm (i,135,n-1,ires)
         call addbond (n-1,n-3)
         call findatm (' OH ',start,stop,i)
         call oldatm (i,136,n-1,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,129,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,129,n-9,1.10d0,cai,107.9d0,n-8,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,132,n-8,1.09d0,n-9,120.0d0,n-10,0.0d0,0)
         call findatm (' HD2',start,stop,i)
         call newatm (i,132,n-8,1.09d0,n-10,120.0d0,n-11,0.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,134,n-8,1.09d0,n-10,120.0d0,n-11,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,134,n-8,1.09d0,n-10,120.0d0,n-12,180.0d0,0)
         call findatm (' HH ',start,stop,i)
         call newatm (i,137,n-7,0.97d0,n-8,108.0d0,n-9,0.0d0,0)
c
c     tryptophan residue  (TRP)
c
      else if (resname .eq. 'TRP') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,144,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,146,n-1,ires)
         call findatm (' CD1',start,stop,i)
         call oldatm (i,147,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,149,n-2,ires)
         call findatm (' NE1',start,stop,i)
         call oldatm (i,150,n-2,ires)
         call findatm (' CE2',start,stop,i)
         call oldatm (i,152,n-1,ires)
         call addbond (n-1,n-3)
         call findatm (' CE3',start,stop,i)
         call oldatm (i,153,n-3,ires)
         call findatm (' CZ2',start,stop,i)
         call oldatm (i,155,n-2,ires)
         call findatm (' CZ3',start,stop,i)
         call oldatm (i,157,n-2,ires)
         call findatm (' CH2',start,stop,i)
         call oldatm (i,159,n-1,ires)
         call addbond (n-1,n-3)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,145,n-10,1.10d0,cai,107.9d0,n-9,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,145,n-11,1.10d0,cai,107.9d0,n-10,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,148,n-10,1.09d0,n-11,126.0d0,n-12,0.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,151,n-9,1.01d0,n-11,126.3d0,n-12,180.0d0,0)
         call findatm (' HE3',start,stop,i)
         call newatm (i,154,n-8,1.09d0,n-6,120.0d0,n-5,180.0d0,0)
         call findatm (' HZ2',start,stop,i)
         call newatm (i,156,n-8,1.09d0,n-6,120.0d0,n-7,180.0d0,0)
         call findatm (' HZ3',start,stop,i)
         call newatm (i,158,n-8,1.09d0,n-7,120.0d0,n-9,180.0d0,0)
         call findatm (' HH2',start,stop,i)
         call newatm (i,160,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,167,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,169,n-1,ires)
         call findatm (' ND1',start,stop,i)
         call oldatm (i,170,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,172,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,174,n-2,ires)
         call findatm (' NE2',start,stop,i)
         call oldatm (i,176,n-1,ires)
         call addbond (n-1,n-3)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,168,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,168,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,171,n-6,1.02d0,n-4,126.0d0,n-3,180.0d0,0)
         call findatm (' HD2',start,stop,i)
         call newatm (i,173,n-6,1.09d0,n-4,126.0d0,n-5,180.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,175,n-6,1.09d0,n-5,126.0d0,n-7,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,177,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,184,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,186,n-1,ires)
         call findatm (' ND1',start,stop,i)
         call oldatm (i,187,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,189,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,191,n-2,ires)
         call findatm (' NE2',start,stop,i)
         call oldatm (i,193,n-1,ires)
         call addbond (n-1,n-3)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,185,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,185,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,-1)
         call findatm (' HD1',start,stop,i)
         call newatm (i,188,n-6,1.02d0,n-4,126.0d0,n-3,180.0d0,0)
         call findatm (' HD2',start,stop,i)
         call newatm (i,190,n-6,1.09d0,n-4,126.0d0,n-5,180.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,192,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,200,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,202,n-1,ires)
         call findatm (' ND1',start,stop,i)
         call oldatm (i,203,n-1,ires)
         call findatm (' CD2',start,stop,i)
         call oldatm (i,204,n-2,ires)
         call findatm (' CE1',start,stop,i)
         call oldatm (i,206,n-2,ires)
         call findatm (' NE2',start,stop,i)
         call oldatm (i,208,n-1,ires)
         call addbond (n-1,n-3)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,201,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,201,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,-1)
         call findatm (' HD2',start,stop,i)
         call newatm (i,205,n-5,1.09d0,n-3,126.0d0,n-4,180.0d0,0)
         call findatm (' HE1',start,stop,i)
         call newatm (i,207,n-5,1.09d0,n-4,126.0d0,n-6,180.0d0,0)
         call findatm (' HE2',start,stop,i)
         call newatm (i,209,n-5,1.02d0,n-6,126.0d0,n-8,180.0d0,0)
c
c     aspartic acid residue  (ASP)
c
      else if (resname .eq. 'ASP') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,216,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,218,n-1,ires)
         call findatm (' OD1',start,stop,i)
         call oldatm (i,219,n-1,ires)
         call findatm (' OD2',start,stop,i)
         call oldatm (i,219,n-2,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,217,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,217,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
c
c     asparagine residue  (ASN)
c
      else if (resname .eq. 'ASN') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,226,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,228,n-1,ires)
         call findatm (' OD1',start,stop,i)
         call oldatm (i,229,n-1,ires)
         call findatm (' ND2',start,stop,i)
         call oldatm (i,230,n-2,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,227,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,227,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
         call findatm ('1HD2',start,stop,i)
         call newatm (i,231,n-3,1.01d0,n-5,120.9d0,n-6,0.0d0,0)
         call findatm ('2HD2',start,stop,i)
         call newatm (i,231,n-4,1.01d0,n-6,120.3d0,n-7,180.0d0,0)
c
c     glutamic acid residue  (GLU)
c
      else if (resname .eq. 'GLU') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,238,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,240,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,242,n-1,ires)
         call findatm (' OE1',start,stop,i)
         call oldatm (i,243,n-1,ires)
         call findatm (' OE2',start,stop,i)
         call oldatm (i,243,n-2,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,239,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,239,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1)
         call findatm ('1HG ',start,stop,i)
         call newatm (i,241,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1)
         call findatm ('2HG ',start,stop,i)
         call newatm (i,241,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1)
c
c     glutamine residue  (GLN)
c
      else if (resname .eq. 'GLN') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,250,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,252,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,254,n-1,ires)
         call findatm (' OE1',start,stop,i)
         call oldatm (i,255,n-1,ires)
         call findatm (' NE2',start,stop,i)
         call oldatm (i,256,n-2,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,251,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,251,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1)
         call findatm ('1HG ',start,stop,i)
         call newatm (i,253,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1)
         call findatm ('2HG ',start,stop,i)
         call newatm (i,253,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1)
         call findatm ('1HE2',start,stop,i)
         call newatm (i,257,n-5,1.01d0,n-7,120.9d0,n-8,0.0d0,0)
         call findatm ('2HE2',start,stop,i)
         call newatm (i,257,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,264,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,266,n-1,ires)
         call findatm (' SD ',start,stop,i)
         call oldatm (i,268,n-1,ires)
         call findatm (' CE ',start,stop,i)
         call oldatm (i,269,n-1,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,265,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,265,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
         call findatm ('1HG ',start,stop,i)
         call newatm (i,267,n-5,1.10d0,n-6,109.5d0,n-4,109.5d0,1)
         call findatm ('2HG ',start,stop,i)
         call newatm (i,267,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,-1)
         call findatm ('1HE ',start,stop,i)
         call newatm (i,270,n-5,1.10d0,n-6,110.2d0,n-7,180.0d0,0)
         call findatm ('2HE ',start,stop,i)
         call newatm (i,270,n-6,1.10d0,n-7,110.2d0,n-8,60.0d0,0)
         call findatm ('3HE ',start,stop,i)
         call newatm (i,270,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,277,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,279,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,281,n-1,ires)
         call findatm (' CE ',start,stop,i)
         call oldatm (i,283,n-1,ires)
         call findatm (' NZ ',start,stop,i)
         call oldatm (i,285,n-1,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,278,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,278,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1)
         call findatm ('1HG ',start,stop,i)
         call newatm (i,280,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1)
         call findatm ('2HG ',start,stop,i)
         call newatm (i,280,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1)
         call findatm ('1HD ',start,stop,i)
         call newatm (i,282,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,1)
         call findatm ('2HD ',start,stop,i)
         call newatm (i,282,n-8,1.10d0,n-9,109.5d0,n-7,109.5d0,-1)
         call findatm ('1HE ',start,stop,i)
         call newatm (i,284,n-8,1.10d0,n-9,110.9d0,n-7,107.3d0,1)
         call findatm ('2HE ',start,stop,i)
         call newatm (i,284,n-9,1.10d0,n-10,110.9d0,n-8,107.3d0,-1)
         call findatm ('1HZ ',start,stop,i)
         call newatm (i,286,n-9,1.04d0,n-10,110.5d0,n-11,180.0d0,0)
         call findatm ('2HZ ',start,stop,i)
         call newatm (i,286,n-10,1.04d0,n-11,110.5d0,n-12,60.0d0,0)
         call findatm ('3HZ ',start,stop,i)
         call newatm (i,286,n-11,1.04d0,n-12,110.5d0,n-13,-60.0d0,0)
c
c     arginine residue  (ARG)
c
      else if (resname .eq. 'ARG') then
         call findatm (' CB ',start,stop,i)
         call oldatm (i,293,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,295,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,297,n-1,ires)
         call findatm (' NE ',start,stop,i)
         call oldatm (i,299,n-1,ires)
         call findatm (' CZ ',start,stop,i)
         call oldatm (i,301,n-1,ires)
         call findatm (' NH1',start,stop,i)
         call oldatm (i,302,n-1,ires)
         call findatm (' NH2',start,stop,i)
         call oldatm (i,302,n-2,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,294,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,294,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,-1)
         call findatm ('1HG ',start,stop,i)
         call newatm (i,296,n-8,1.10d0,n-9,109.5d0,n-7,109.5d0,1)
         call findatm ('2HG ',start,stop,i)
         call newatm (i,296,n-9,1.10d0,n-10,109.5d0,n-8,109.5d0,-1)
         call findatm ('1HD ',start,stop,i)
         call newatm (i,298,n-9,1.10d0,n-10,109.5d0,n-8,109.5d0,1)
         call findatm ('2HD ',start,stop,i)
         call newatm (i,298,n-10,1.10d0,n-11,109.5d0,n-9,109.5d0,-1)
         call findatm (' HE ',start,stop,i)
         call newatm (i,300,n-10,1.01d0,n-11,118.5d0,n-9,120.0d0,1)
         call findatm ('1HH1',start,stop,i)
         call newatm (i,303,n-9,1.01d0,n-10,122.5d0,n-11,0.0d0,0)
         call findatm ('2HH1',start,stop,i)
         call newatm (i,303,n-10,1.01d0,n-11,118.8d0,n-12,180.0d0,0)
         call findatm ('1HH2',start,stop,i)
         call newatm (i,303,n-10,1.01d0,n-12,122.5d0,n-13,0.0d0,0)
         call findatm ('2HH2',start,stop,i)
         call newatm (i,303,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,310,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,312,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,314,n-1,ires)
         call findatm (' NE ',start,stop,i)
         call oldatm (i,316,n-1,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,311,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,311,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1)
         call findatm ('1HG ',start,stop,i)
         call newatm (i,313,n-5,1.10d0,n-7,109.5d0,n-4,109.5d0,1)
         call findatm ('2HG ',start,stop,i)
         call newatm (i,313,n-6,1.10d0,n-8,109.5d0,n-5,109.5d0,-1)
         call findatm ('1HD ',start,stop,i)
         call newatm (i,315,n-6,1.10d0,n-8,109.5d0,n-5,109.5d0,1)
         call findatm ('2HD ',start,stop,i)
         call newatm (i,315,n-7,1.10d0,n-9,109.5d0,n-6,109.5d0,-1)
         call findatm ('1HE ',start,stop,i)
         call newatm (i,317,n-7,1.04d0,n-8,110.5d0,n-9,180.0d0,0)
         call findatm ('2HE ',start,stop,i)
         call newatm (i,317,n-8,1.04d0,n-9,110.5d0,n-10,60.0d0,0)
         call findatm ('3HE ',start,stop,i)
         call newatm (i,317,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,323,cai,ires)
         call findatm (' CB2',start,stop,i)
         call oldatm (i,323,cai,ires)
         call findatm ('1HB1',start,stop,i)
         call newatm (i,324,n-2,1.10d0,cai,110.2d0,ni,180.0d0,0)
         call findatm ('2HB1',start,stop,i)
         call newatm (i,324,n-3,1.10d0,cai,110.2d0,ni,60.0d0,0)
         call findatm ('3HB1',start,stop,i)
         call newatm (i,324,n-4,1.10d0,cai,110.2d0,ni,-60.0d0,0)
         call findatm ('1HB2',start,stop,i)
         call newatm (i,324,n-4,1.10d0,cai,110.2d0,ni,180.0d0,0)
         call findatm ('2HB2',start,stop,i)
         call newatm (i,324,n-5,1.10d0,cai,110.2d0,ni,60.0d0,0)
         call findatm ('3HB2',start,stop,i)
         call newatm (i,324,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,331,cai,ires)
         call findatm (' CG ',start,stop,i)
         call oldatm (i,333,n-1,ires)
         call findatm (' CD ',start,stop,i)
         call oldatm (i,335,n-1,ires)
         call addbond (n-1,ni)
         call findatm (' OE ',start,stop,i)
         call oldatm (i,336,n-1,ires)
         call findatm ('1HB ',start,stop,i)
         call newatm (i,332,n-4,1.10d0,cai,111.2d0,n-3,111.2d0,1)
         call findatm ('2HB ',start,stop,i)
         call newatm (i,332,n-5,1.10d0,cai,111.2d0,n-4,111.2d0,-1)
         call findatm ('1HG ',start,stop,i)
         call newatm (i,334,n-5,1.10d0,n-6,111.2d0,n-4,111.2d0,1)
         call findatm ('2HG ',start,stop,i)
         call newatm (i,334,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
         if (ires .eq. 1) then
            call newatm (0,355,cai,1.10d0,ni,109.5d0,ci,109.5d0,1)
         else if (ires .eq. nseq) then
            call newatm (0,506,cai,1.10d0,ni,109.5d0,ci,109.5d0,1)
         else
            call newatm (0,6,cai,1.10d0,ni,109.5d0,ci,109.5d0,1)
         end if
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'iounit.i'
      include 'pdb.i'
      include 'resdue.i'
      include 'sequen.i'
      integer i,j,k,nres
      integer iseq,ityp
      integer start,stop
      integer freeunit
      integer poi,o5i,c5i
      integer c4i,o4i,c1i
      integer c3i,c2i,o3i,o2i
      integer resatm(2,maxres)
      integer o5typ(maxnuc),c5typ(maxnuc)
      integer h51typ(maxnuc),h52typ(maxnuc)
      integer c4typ(maxnuc),h4typ(maxnuc)
      integer o4typ(maxnuc),c1typ(maxnuc)
      integer h1typ(maxnuc),c3typ(maxnuc)
      integer h3typ(maxnuc),c2typ(maxnuc)
      integer o3typ(maxnuc),o2typ(maxnuc)
      integer h21typ(maxnuc),h22typ(maxnuc)
      integer ptyp(maxnuc),optyp(maxnuc)
      integer h5ttyp(maxnuc),h3ttyp(maxnuc)
      logical newchain,endchain
      logical deoxy(maxres)
      character*3 resname
      character*60 seqfile
c
c     biopolymer atom types for nucleic acid backbone atoms
c
      data o5typ   / 1001, 1031, 1062, 1090, 1117, 1146, 1176, 1203,
     &                  0,    0,    0,    0 /
      data c5typ   / 1002, 1032, 1063, 1091, 1118, 1147, 1177, 1204,
     &                  0,    0,    0,    0 /
      data h51typ  / 1003, 1033, 1064, 1092, 1119, 1148, 1178, 1205,
     &                  0,    0,    0,    0 /
      data h52typ  / 1004, 1034, 1065, 1093, 1120, 1149, 1179, 1206,
     &                  0,    0,    0,    0 /
      data c4typ   / 1005, 1035, 1066, 1094, 1121, 1150, 1180, 1207,
     &                  0,    0,    0,    0 /
      data h4typ   / 1006, 1036, 1067, 1095, 1122, 1151, 1181, 1208,
     &                  0,    0,    0,    0 /
      data o4typ   / 1007, 1037, 1068, 1096, 1123, 1152, 1182, 1209,
     &                  0,    0,    0,    0 /
      data c1typ   / 1008, 1038, 1069, 1097, 1124, 1153, 1183, 1210,
     &                  0,    0,    0,    0 /
      data h1typ   / 1009, 1039, 1070, 1098, 1125, 1154, 1184, 1211,
     &                  0,    0,    0,    0 /
      data c3typ   / 1010, 1040, 1071, 1099, 1126, 1155, 1185, 1212,
     &                  0,    0,    0,    0 /
      data h3typ   / 1011, 1041, 1072, 1100, 1127, 1156, 1186, 1213,
     &                  0,    0,    0,    0 /
      data c2typ   / 1012, 1042, 1073, 1101, 1128, 1157, 1187, 1214,
     &                  0,    0,    0,    0 /
      data h21typ  / 1013, 1043, 1074, 1102, 1129, 1158, 1188, 1215,
     &                  0,    0,    0,    0 /
      data h22typ  / 1015, 1045, 1076, 1104, 1130, 1159, 1189, 1216,
     &                  0,    0,    0,    0 /
      data o3typ   / 1016, 1046, 1077, 1105, 1131, 1160, 1190, 1217,
     &                  0,    0,    0,    0 /
      data o2typ   / 1014, 1044, 1075, 1103,    0,    0,    0,    0,
     &                  0,    0,    0,    0 /
      data ptyp    / 1230, 1230, 1230, 1230, 1242, 1242, 1242, 1242,
     &                  0,    0,    0,    0 /
      data optyp   / 1231, 1231, 1231, 1231, 1243, 1243, 1243, 1243,
     &                  0,    0,    0,    0 /
      data h5ttyp  / 1233, 1233, 1233, 1233, 1245, 1245, 1245, 1245,
     &                  0,    0,    0,    0 /
      data h3ttyp  / 1238, 1238, 1238, 1238, 1250, 1250, 1250, 1250,
     &                  0,    0,    0,    0 /
c
c
c     set a pointer to the first and last atom of each residue
c
      nres = 0
      k = 0
      do i = 1, npdb
         if (pdbtyp(i) .eq. 'ATOM  ') then
            if (resnum(i) .ne. k) then
               k = resnum(i)
               if (nres .ne. 0)  resatm(2,nres) = i - 1
               nres = nres + 1
               resatm(1,nres) = i
            end if
         end if
      end do
      if (nres .ne. 0)  resatm(2,nres) = npdb
c
c     check for deoxyribose and change residue name if necessary
c
      do i = 1, nres
         deoxy(i) = .false.
         start = resatm(1,i)
         stop = resatm(2,i)
         resname = resnam(start)
         call findatm (' O2*',start,stop,k)
         if (k .eq. 0) then
            deoxy(i) = .true.
            do j = start, stop
               if (resname .eq. 'ADE')  resnam(j) = 'DAD'
               if (resname .eq. 'GUA')  resnam(j) = 'DGU'
               if (resname .eq. 'CYT')  resnam(j) = 'DCY'
            end do
         end if
      end do
c
c     get the three-letter sequence and code for each residue
c
      nseq = nres
      do i = 1, nres
         start = resatm(1,i)
         resname = resnam(start)
         seq(i) = 'UNK'
         seqtyp(i) = maxnuc
         do k = 1, maxnuc
            if (resname .eq. nuclz(k)) then
               seq(i) = nuclz(k)
               seqtyp(i) = k
               goto 10
            end if
         end do
   10    continue
      end do
c
c     set the current atom to be the first atom
c
      n = 1
c
c     locate and assign the atoms that make up each residue
c
      do i = 1, nres
         ityp = seqtyp(i)
         start = resatm(1,i)
         stop = resatm(2,i)
         resname = resnam(start)
c
c     check that the maximum allowed atoms is not exceeded
c
         if (n+25 .gt. maxatm) then
            write (iout,20)  maxatm
   20       format (/,' LIGASE  --  The Maximum of',i6,' Atoms',
     &                 ' has been Exceeded')
            call fatal
         end if
c
c     test for initial or final residue of a nucleotide chain
c
         newchain = .false.
         endchain = .false.
         do j = 1, nchain
            if (i .eq. ichain(1,j)) then
               newchain = .true.
               poi = 0
               o3i = 0
            end if
            if (i .eq. ichain(2,j))  endchain = .true.
         end do
c
c     build the phosphate atoms of the current residue
c
         if (resname .eq. 'TPO') then

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

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

         else if (.not. newchain) then
            call findatm (' P  ',start,stop,k)
            if (k .ne. 0)  poi = n
            j = ptyp(ityp)
            call oldatm (k,j,o3i,i)
            call findatm (' O1P',start,stop,k)
            j = optyp(ityp)
            call oldatm (k,j,n-1,i)
            call findatm (' O2P',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 (newchain) 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 (endchain) 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 (newchain) then
            call findatm (' H5T',start,stop,k)
            j = h5ttyp(ityp)
            call newatm (k,j,o5i,1.00d0,c5i,109.5d0,c4i,180.0d0,0)
         end if
         call findatm ('1H5*',start,stop,k)
         j = h51typ(ityp)
         call newatm (k,j,c5i,1.09d0,o5i,109.5d0,c4i,109.5d0,1)
         call findatm ('2H5*',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 ('1H2*',start,stop,k)
            j = h21typ(ityp)
            call newatm (k,j,c2i,1.09d0,c3i,109.5d0,c1i,109.5d0,-1)
            call findatm ('2H2*',start,stop,k)
            j = h22typ(ityp)
            call newatm (k,j,c2i,1.09d0,c3i,109.5d0,c1i,109.5d0,1)
         else
            call findatm ('1H2*',start,stop,k)
            j = h21typ(ityp)
            call newatm (k,j,c2i,1.09d0,c3i,109.5d0,c1i,109.5d0,-1)
            call findatm ('2HO*',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 (endchain) then
            call findatm (' H3T',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     write out the 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)
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,ires
      integer start,stop
      integer c1i
      character*3 resname
c
c
c     adenine in adenosine residue  (ADE)
c
      if (resname .eq. 'ADE') 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 ('1H6 ',start,stop,i)
         call newatm (i,1028,n-6,1.00d0,n-7,120.0d0,n-8,180.0d0,0)
         call findatm ('2H6 ',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  (GUA)
c
      else if (resname .eq. 'GUA') 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 ('1H2 ',start,stop,i)
         call newatm (i,1058,n-5,1.00d0,n-6,120.0d0,n-7,0.0d0,0)
         call findatm ('2H2 ',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  (CYT)
c
      else if (resname .eq. 'CYT') 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 ('1H4 ',start,stop,i)
         call newatm (i,1086,n-3,1.00d0,n-4,120.0d0,n-5,0.0d0,0)
         call findatm ('2H4 ',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  (URA)
c
      else if (resname .eq. 'URA') 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  (DAD)
c
      else if (resname .eq. 'DAD') 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 ('1H6 ',start,stop,i)
         call newatm (i,1143,n-6,1.00d0,n-7,120.0d0,n-8,180.0d0,0)
         call findatm ('2H6 ',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  (DGU)
c
      else if (resname .eq. 'DGU') 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 ('1H2 ',start,stop,i)
         call newatm (i,1172,n-5,1.00d0,n-6,120.0d0,n-7,0.0d0,0)
         call findatm ('2H2 ',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  (DCY)
c
      else if (resname .eq. 'DCY') 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 ('1H4 ',start,stop,i)
         call newatm (i,1199,n-3,1.00d0,n-4,120.0d0,n-5,0.0d0,0)
         call findatm ('2H4 ',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  (THY)
c
      else if (resname .eq. 'THY') 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 (' C5M',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 ('1H5M',start,stop,i)
         call newatm (i,1228,n-3,1.09d0,n-4,109.5d0,n-6,0.0d0,0)
         call findatm ('2H5M',start,stop,i)
         call newatm (i,1228,n-4,1.09d0,n-5,109.5d0,n-1,109.5d0,1)
         call findatm ('3H5M',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     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine piscf  --  scf molecular orbital calculation  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "piscf" performs an scf molecular orbital calculation for
c     the pisystem using a modified Pariser-Parr-Pople method
c
c
      subroutine piscf
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'border.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'orbits.i'
      include 'piorbs.i'
      include 'units.i'
      integer i,j,k,m,ncalls
      integer iter,maxiter
      integer iatn,jatn,iorb,jorb
      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,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 povlap(maxpib)
      real*8 f(maxpi,maxpi)
      real*8 hc(maxpi,maxpi)
      real*8 v(maxpi,maxpi)
      real*8 en(maxpi),ip(maxpi)
      real*8 gamma(maxpi,maxpi)
      real*8 ed(maxpi,maxpi)
      real*8 work1(maxpi)
      real*8 work2(maxpi)
      logical initial
      character*6 mode
      data initial  / .true. /
      data ncalls  / 0 /
      save initial,ncalls,f
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     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   ionizaton 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     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
      do i = 1, norbit
         gamma(i,i) = em(i)
         ip(i) = w(i) + (1.0d0-q(i))*em(i)
      end do
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
               hcii = hcii - q(j)*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, npibond
         i = pibond(2,k)
         j = pibond(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 (q(i) .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 (q(j) .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     make an initial guess at the Fock matrix if needed
c
      if (initial) then
         initial = .false.
         do i = 1, norbit
            do j = 1, norbit
               f(j,i) = hc(j,i)
            end do
         end do
         do i = 1, norbit
            f(i,i) = 0.5d0 * ip(i)
         end do
      end if
c
c     now, do the scf-mo computation; note that it needs to
c     be done twice, initially for the planar analog of the
c     actual system; then for the nonplanar (actual) system
c
      dowhile (mode.eq.'Planar' .or. mode.eq.'Nonpln')
         if (mode .eq. 'Nonpln') then
            call pitilt (povlap)
            do k = 1, npibond
               i = pibond(2,k)
               j = pibond(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;
c     diagonalize the Fock matrix "f" to get the mo's,
c     then use mo's to form the next "f" matrix assuming
c     zero differential overlap except for one-center
c     exchange repulsions
c
         iter = 0
         delta = 2.0d0 * converge
         dowhile (delta.gt.converge .and. iter.lt.maxiter)
            iter = iter + 1
            call jacobi (norbit,maxpi,f,en,v,work1,work2)
            do i = 1, norbit
               do j = i, norbit
                  s1 = 0.0d0
                  s2 = 0.0d0
                  gij = gamma(i,j)
                  do k = 1, nfill
                     s2 = s2 - v(i,k)*v(j,k)*gij
                     if (i .eq. j) then
                        do m = 1, norbit
                           s1 = s1 + 2.0d0*gamma(i,m)*v(m,k)**2
                        end do
                     end if
                  end do
                  f(i,j) =  s1 + s2 + hc(i,j)
                  f(j,i) = f(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" is 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 = v(j,i)
                  do k = 1, norbit
                     vik = v(k,i)
                     gjk = gamma(j,k)
                     xi = xi + 2.0d0*vij*vik*hc(j,k)
                     do m = 1, nfill
                        vmj = v(j,m)
                        vmk = v(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
               qi = q(i)
               do j = i+1, norbit
                  xg = xg + qi*q(j)*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-MO Iteration has',
     &                 ' not reached Self-Consistency')
         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*v(i,k)*v(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 (/,' Pi-SCF-MO Calculation for Planar System :')
            else
               write (iout,30)
   30          format (/,' Pi-SCF-MO Calculation for Non-Planar',
     &                    ' System :')
            end if
            write (iout,40)  total,delta,iter
   40       format (/,' Total Energy',11x,f12.4,
     &              /,' 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)  (v(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)  (f(i,j),j=1,norbit)
  110          format (8f9.4)
            end do
            write (iout,120)
  120       format (/,' Electron Densities')
            write (iout,130)  (ed(i,i),i=1,norbit)
  130       format (8f9.4)
            write (iout,140)
  140       format (/,' Density Matrix')
            do i = 1, norbit
               write (iout,150)  (ed(i,j),j=1,norbit)
  150          format (8f9.4)
            end do
            write (iout,160)
  160       format (/,' H-Core Matrix')
            do i = 1, norbit
               write (iout,170)  (hc(i,j),j=1,norbit)
  170          format (8f9.4)
            end do
            write (iout,180)
  180       format (/,' Gamma Matrix')
            do i = 1, norbit
               write (iout,190)  (gamma(i,j),j=1,norbit)
  190          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,200)
  200       format (/,' Pi Bond Orders')
         end if
         do k = 1, npibond
            i = pibond(2,k)
            j = pibond(3,k)
            p = 0.0d0
            do m = 1, nfill
               p = p + 2.0d0*v(i,m)*v(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,pibond(1,k))
               j = ibnd(2,pibond(1,k))
               write (iout,210)  i,j,p
  210          format (4x,2i5,3x,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     alter torsional and bond constants for pisystem
c
      call pialter
      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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'piorbs.i'
      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(maxpib)
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, npibond
         i = pibond(2,k)
         j = pibond(3,k)
         iorb = iorbit(i)
         jorb = iorbit(j)
         list(1) = iorb
         list(2) = jorb
         do m = 1, 3
            list(m+2) = piperp(m,i)
            list(m+5) = piperp(m,j)
         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  --  translate/rotate bond vector  ##
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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      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
c     for atom 1 (ie, make all these atoms have unit length to
c     atom 1) so that the orbital makes equal angles with the
c     atoms rather than simply being perpendicular to the common
c     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 constants for pisystem  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "pialter" first modifies bond lengths and force constants
c     according to the standard bond slope parameters and the
c     bond order values stored in "pnpl"; also alters some 2-fold
c     torsional parameters based on the bond-order * beta matrix
c
c
      subroutine pialter
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'bond.i'
      include 'border.i'
      include 'inform.i'
      include 'iounit.i'
      include 'piorbs.i'
      include 'pistuf.i'
      include 'tors.i'
      integer i,j,k
      integer ia,ib,ic,id
c
c
c     modify the stretching constants and natural bond lengths
c
      if (debug .and. npibond.ne.0) then
         write (iout,10)
   10    format (/,' Altered Bond Stretching Parameters',
     &              ' for Pi-System :',
     &           //,' Type',13x,'Atom Names',15x,'Initial',
     &              16x,'Final',/)
      end if
      do i = 1, npibond
         k = pibond(1,i)
         ia = ibnd(1,k)
         ib = ibnd(2,k)
         bk(k) = bkpi(i) - kslope(i) * (1.0d0-pnpl(i))
         bl(k) = blpi(i) + lslope(i) * (1.0d0-pnpl(i))
         if (debug) then
            write (iout,20)  ia,name(ia),ib,name(ib),bkpi(i),
     &                       blpi(i),bk(k),bl(k)
   20       format (' Bond',7x,i5,'-',a3,1x,i5,'-',a3,
     &                 5x,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. npitors.ne.0) then
         write (iout,30)
   30    format (/,' Altered 2-Fold Torsional Parameters',
     &              ' for Pi-System :',
     &           //,' Type',23x,'Atom Names',17x,'Initial',
     &              8x,'Final',/)
      end if
      do i = 1, npitors
         j = pitors(1,i)
         k = pitors(2,i)
         ia = itors(1,j)
         ib = itors(2,j)
         ic = itors(3,j)
         id = itors(4,j)
         tors2(1,j) = pbpl(k) * torspi(i)
         if (debug) then
            write (iout,40)  ia,name(ia),ib,name(ib),ic,name(ic),
     &                       id,name(id),torspi(i),tors2(1,j)
   40       format (' Torsion',4x,i5,'-',a3,3(1x,i5,'-',a3),
     &                 3x,f8.3,2x,'-->',f8.3)
         end if
      end do
      return
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polpot.i'
      include 'potent.i'
      integer i
      real*8 addu,malpha
      real*8 exfield(3)
      real*8 umol(3),dalpha(3)
      real*8 work1(3),work2(3)
      real*8 alpha(3,3)
      real*8 valpha(3,3)
c
c
c     sum atomic polarizabilities to get additive molecular value
c
      call initial
      call getxyz
      call mechanic
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 i = 1, npole
         addu = polarity(i) + addu
      end do
      write (iout,20)  addu
   20 format (/,' Additive Molecular Polarizability :',f15.4)
c
c     compute each column of the polarizability tensor
c
      do i = 1, 3
         exfield(i) = 0.0d0
      end do
      exfield(1) = 0.001d0
      call moluind (exfield,umol)
      alpha(1,1) = umol(1) / exfield(1)
      alpha(2,1) = umol(2) / exfield(1)
      alpha(3,1) = umol(3) / exfield(1)
      do i = 1, 3
         exfield(i) = 0.0d0
      end do
      exfield(2) = 0.001d0
      call moluind (exfield,umol)
      alpha(1,2) = umol(1) / exfield(2)
      alpha(2,2) = umol(2) / exfield(2)
      alpha(3,2) = umol(3) / exfield(2)
      do i = 1, 3
         exfield(i) = 0.0d0
      end do
      exfield(3) = 0.001d0
      call moluind (exfield,umol)
      alpha(1,3) = umol(1) / exfield(3)
      alpha(2,3) = umol(2) / exfield(3)
      alpha(3,3) = umol(3) / exfield(3)
c
c     print out the full polarizability tensor
c
      write (iout,30)
   30 format (/,' Molecular Polarizability Tensor :',/)
      write (iout,40)  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)
   40 format (15x,3f12.4,/,15x,3f12.4,/,15x,3f12.4)
c
c     diagonlize the tensor and get molecular polarizability
c
      call jacobi (3,3,alpha,dalpha,valpha,work1,work2)
      malpha = (dalpha(1)+dalpha(2)+dalpha(3)) / 3.0d0
      write (iout,50)  malpha
   50 format (/,' Interactive Molecular Polarizability :',f12.4,/)
      write (iout,60)  dalpha(1)
   60 format (32x,'a(xx) :',f12.4)
      write (iout,70)  dalpha(2)
   70 format (32x,'a(yy) :',f12.4)
      write (iout,80)  dalpha(3)
   80 format (32x,'a(zz) :',f12.4)
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polpot.i'
      include 'units.i'
      integer i,j,iter
      integer maxiter
      real*8 eps,epsold
      real*8 umol(3)
      real*8 exfield(3)
      real*8 udir(3,maxatm)
      real*8 uold(3,maxatm)
      real*8 field(3,maxatm)
      logical done
c
c
c     zero out the atomic and molecular induced dipole components
c
      do i = 1, npole
         do j = 1, 3
            uind(j,i) = 0.0d0
         end do
      end do
      do j = 1, 3
         umol(j) = 0.0d0
      end do
c
c     compute induced dipoles as polarizability times external field
c
      do i = 1, npole
         do j = 1, 3
            uind(j,i) = polarity(i) * exfield(j)
         end do
      end do
c
c     set tolerances for computation of mutual induced dipoles
c
      if (poltyp .eq. 'MUTUAL') then
         done = .false.
         maxiter = 500
         iter = 0
         eps = 1.0d0
         do i = 1, npole
            do j = 1, 3
               udir(j,i) = uind(j,i)
            end do
         end do
c
c     compute mutual induced dipole moments by an iterative method
c
         dowhile (.not. done)
            do i = 1, npole
               do j = 1, 3
                  field(j,i) = 0.0d0
               end do
            end do
            call ufield (field)
c
c     check to see if the mutual induced dipoles have converged
c
            iter = iter + 1
            epsold = eps
            eps = 0.0d0
            do i = 1, npole
               do j = 1, 3
                  uold(j,i) = uind(j,i)
                  uind(j,i) = udir(j,i) + polarity(i)*field(j,i)
                  uind(j,i) = uold(j,i) + polsor*(uind(j,i)-uold(j,i))
                  eps = eps + (uind(j,i)-uold(j,i))**2
               end do
            end do
            eps = debye * sqrt(eps/dble(npolar))
            if (debug) then
               if (iter .eq. 1) then
                  write (iout,10)
   10             format (/,' Determination of Induced Dipole',
     &                       ' Moments :',
     &                    //,4x,'Iter',8x,'RMS Change (Debyes)',/)
               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. maxiter)  done = .true.
         end do
c
c     sum up the total molecular induced dipole components
c
         do i = 1, npole
            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 a warning if induced dipoles failed to converge
c
         if (eps .gt. poleps) then
            write (iout,30)
   30       format (/,' INDUCE  --  Warning, Induced Dipoles',
     &                 ' are not Converged')
         end if
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ufield  --  electric field from induced dipoles  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ufield" finds the field at each polarizable site due to the
c     induced dipoles at the other sites using Thole's method to
c     damp the field at close range
c
c     
      subroutine ufield (field)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'mpole.i'
      include 'polar.i'
      include 'polgrp.i'
      include 'polpot.i'
      integer i,j,k
      integer ii,kk
      real*8 r,r2,xr,yr,zr
      real*8 rr3,rr5,uir,ukr
      real*8 uix,uiy,uiz
      real*8 ukx,uky,ukz
      real*8 damp,scale3,scale5
      real*8 fi(3),fk(3)
      real*8 pscale(maxatm)
      real*8 field(3,maxatm)
c
c
c     loop over pairs of sites incrementing the electric field
c
      do i = 1, npole-1
         ii = ipole(i)
         uix = uind(1,i)
         uiy = uind(2,i)
         uiz = uind(3,i)
         do j = i+1, npole
            pscale(ipole(j)) = 1.0d0
         end do
         do j = 1, np11(ii)
            pscale(ip11(j,ii)) = u1scale
         end do
         do j = 1, np12(ii)
            pscale(ip12(j,ii)) = u2scale
         end do
         do j = 1, np13(ii)
            pscale(ip13(j,ii)) = u3scale
         end do
         do j = 1, np14(ii)
            pscale(ip14(j,ii)) = u4scale
         end do
         do k = i+1, npole
            kk = ipole(k)
            xr = x(kk) - x(ii)
            yr = y(kk) - y(ii)
            zr = z(kk) - z(ii)
            r2 = xr*xr + yr* yr + zr*zr
            ukx = uind(1,k)
            uky = uind(2,k)
            ukz = uind(3,k)
            r = sqrt(r2)
            rr3 = 1.0d0 / (r*r2)
            rr5 = 3.0d0 * rr3 / r2
            uir = xr*uix + yr*uiy + zr*uiz
            ukr = xr*ukx + yr*uky + zr*ukz
c
c     adjust the field to account for polarization damping
c
            scale3 = 1.0d0
            scale5 = 1.0d0
            damp = pdamp(i) * pdamp(k)
            if (damp .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)
               end if
            end if
            fi(1) = -rr3*ukx*scale3 + rr5*ukr*xr*scale5
            fi(2) = -rr3*uky*scale3 + rr5*ukr*yr*scale5
            fi(3) = -rr3*ukz*scale3 + rr5*ukr*zr*scale5
            fk(1) = -rr3*uix*scale3 + rr5*uir*xr*scale5
            fk(2) = -rr3*uiy*scale3 + rr5*uir*yr*scale5
            fk(3) = -rr3*uiz*scale3 + rr5*uir*zr*scale5
            do j = 1, 3
               fi(j) = fi(j) * pscale(kk)
               fk(j) = fk(j) * pscale(kk)
            end do
c
c     increment the field at each site due to this interaction
c
            do j = 1, 3
               field(j,i) = field(j,i) + fi(j)
               field(j,k) = field(j,k) + fk(j)
            end do
         end do
      end do
      return
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'boxes.i'
      include 'iounit.i'
      include 'keys.i'
      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*80 record
      character*80 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:80)
            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_image) 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,0)
            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
         end if
         maximage = min(xlimit,ylimit,zlimit)
c
c     check for too large or small of a 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)  1996  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine power  --  largest eigenvalues by power method  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "power" uses the power method with deflation to compute the
c     few largest eigenvalues and eigenvectors of a symmetric matrix
c
c     n     logical dimension of the matrix to be diagonalized
c     np    physical dimension of the matrix storage area
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  temporary work vector
c
c
      subroutine power (n,np,nv,a,ev,vec,work)
      implicit none
      include 'iounit.i'
      integer i,j,k,n,np,nv
      integer iter,maxiter
      real*8 random,eps
      real*8 dot1,dot2,ratio
      real*8 ev(nv),vec(np,nv)
      real*8 a(np,np),work(np)
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     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 (/,' POWER  --  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
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #########################################################
c     ##                                                     ##
c     ##  function precise  --  determine machine precision  ##
c     ##                                                     ##
c     #########################################################
c
c
c     "precise" finds a machine precision value as selected by
c     the input argument: (1) the smallest positive floating
c     point value, (2) the smallest relative floating point
c     spacing, (3) the largest relative floating point spacing
c
c
      function precise (i)
      implicit none
      integer i
      real*8 precise,value
      real*8 zero,one,delta
c
c
c     set values for zero, one and multiplicative factor
c
      zero = 0.0d0
      one = 1.0d0
      delta = 1.1d0
      precise = one
c
c     find the smallest positive floating point value;
c     minimum of 0.24x10-307 is a patch for some SGI's,
c     for Sparc cpu's under Linux, etc.
c
      if (i .eq. 1) then
c        dowhile (precise .ne. zero)
         dowhile (precise .ge. 0.24d-307)
            value = precise
            precise = precise / delta
         end do
         precise = value
c
c     find the smallest relative floating point spacing
c
      else if (i .eq. 2) then
         dowhile (one+precise .ne. one)
            value = precise
            precise = precise / delta
         end do
         precise = value
c
c     find the largest relative floating point spacing
c
      else if (i .eq. 3) then
         dowhile (one+precise .ne. precise)
           value = precise
           precise = precise * delta
         end do
         precise = value
      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 pressure  --  constant pressure via coupling  ##
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     by scaling the coordinates via coupling to an external
c     constant pressure bath
c
c     literature reference :
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
      subroutine pressure (dt,pres,ekin)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bath.i'
      include 'boxes.i'
      include 'units.i'
      include 'usage.i'
      include 'virial.i'
      integer i
      real*8 dt,pres
      real*8 ekin,virial
      real*8 third,scale
c
c
c     compute the value of the internal virial and pressure
c
      virial = virx + viry + virz
      pres = (2.0d0*ekin - virial) / (3.0d0*volbox)
      pres = pres * prescon
c
c     find the scale factor to maintain constant pressure
c
      third = 1.0d0 / 3.0d0
      scale = (1.0d0 + (dt*compress/taupres)*(pres-atmsph))**third
c
c     alter the size of the periodic box dimensions
c
      xbox = scale * xbox
      ybox = scale * ybox
      zbox = scale * zbox
c
c     update the lattice parameters for the periodic box
c
      call lattice
c
c     couple to external pressure bath via atom scaling
c
      do i = 1, n
         if (use(i)) then
            x(i) = scale * x(i)
            y(i) = scale * y(i)
            z(i) = scale * z(i)
         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     "field" parses a text string to extract keywords related to
c     force field potential energy functional forms and constants
c
c
      subroutine prmkey (text)
      implicit none
      include 'sizes.i'
      include 'angpot.i'
      include 'bndpot.i'
      include 'chgpot.i'
      include 'fields.i'
      include 'mplpot.i'
      include 'polpot.i'
      include 'potent.i'
      include 'rxnpot.i'
      include 'torpot.i'
      include 'urypot.i'
      include 'vdwpot.i'
      integer next
      character*4 value
      character*20 keyword
      character*80 text
      character*80 record
      character*80 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)
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:9) .eq. 'UREYTERM ') 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:12) .eq. 'IMPTORSTERM ') 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. '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. '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: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:10) .eq. 'MPOLETERM ') 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: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.
      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
         string = record(next:80)
         read (string,*,err=10,end=10)  bndunit
      else if (keyword(1:11) .eq. 'BOND-CUBIC ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  cbnd
      else if (keyword(1:13) .eq. 'BOND-QUARTIC ') then
         string = record(next:80)
         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
         string = record(next:80)
         read (string,*,err=10,end=10)  angunit
      else if (keyword(1:12) .eq. 'ANGLE-CUBIC ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  cang
      else if (keyword(1:14) .eq. 'ANGLE-QUARTIC ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  qang
      else if (keyword(1:13) .eq. 'ANGLE-PENTIC ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  pang
      else if (keyword(1:13) .eq. 'ANGLE-SEXTIC ') then
         string = record(next:80)
         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
         string = record(next:80)
         read (string,*,err=10,end=10)  stbnunit
      else if (keyword(1:11) .eq. 'MM2-STRBND ') then
         mm2stbn = .true.
c
c     set control parameters for Urey-Bradley potentials
c
      else if (keyword(1:9) .eq. 'UREYUNIT ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  ureyunit
      else if (keyword(1:11) .eq. 'UREY-CUBIC ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  cury
      else if (keyword(1:13) .eq. 'UREY-QUARTIC ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  qury
c
c     set control parameters for other local geometry potentials
c
      else if (keyword(1:11) .eq. 'ANGANGUNIT ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  aaunit
      else if (keyword(1:11) .eq. 'OPBENDUNIT ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  opbunit
      else if (keyword(1:11) .eq. 'OPDISTUNIT ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  opdunit
      else if (keyword(1:11) .eq. 'IMPROPUNIT ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  idihunit
      else if (keyword(1:11) .eq. 'IMPTORUNIT ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  itorunit
      else if (keyword(1:12) .eq. 'TORSIONUNIT ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  torsunit
      else if (keyword(1:11) .eq. 'STRTORUNIT ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  storunit
c
c     set control parameters for van der Waals potentials
c
      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
         string = record(next:80)
         read (string,*,err=10,end=10)  abuck
      else if (keyword(1:10) .eq. 'B-EXPTERM ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  bbuck
      else if (keyword(1:10) .eq. 'C-EXPTERM ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  cbuck
      else if (keyword(1:14) .eq. 'GAMMA-HALGREN ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  ghal
      else if (keyword(1:14) .eq. 'DELTA-HALGREN ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  dhal
      else if (keyword(1:13) .eq. 'VDW-12-SCALE ') then
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         read (string,*,err=10,end=10)  v5scale
         if (v5scale .gt. 1.0d0)  v5scale = 1.0d0 / v5scale
c
c     set control parameters for charge-charge potentials
c
      else if (keyword(1:11) .eq. 'DIELECTRIC ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  dielec
      else if (keyword(1:15) .eq. 'NEUTRAL-GROUPS ') then
         neutcut = .true.
      else if (keyword(1:16) .eq. 'NEIGHBOR-GROUPS ') then
         neutnbr = .true.
      else if (keyword(1:13) .eq. 'CHG-12-SCALE ') then
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         read (string,*,err=10,end=10)  c5scale
         if (c5scale .gt. 1.0d0)  c5scale = 1.0d0 / c5scale
c
c     set control parameters for atomic multipole potentials
c
      else if (keyword(1:15) .eq. 'MPOLE-12-SCALE ') then
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         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:10) .eq. 'POLAR-EPS ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  poleps
      else if (keyword(1:10) .eq. 'POLAR-SOR ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  polsor
      else if (keyword(1:11) .eq. 'POLAR-DAMP ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  pgamma
      else if (keyword(1:15) .eq. 'POLAR-15-SCALE ') then
         string = record(next:80)
         read (string,*,err=10,end=10)  p5scale
         if (p5scale .gt. 1.0d0)  p5scale = 1.0d0 / p5scale
      else if (keyword(1:15) .eq. 'POLAR-12-SCALE ') then
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         read (string,*,err=10,end=10)  p4scale
         if (p4scale .gt. 1.0d0)  p4scale = 1.0d0 / p4scale
      else if (keyword(1:16) .eq. 'DIRECT-11-SCALE ') then
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         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
         string = record(next:80)
         read (string,*,err=10,end=10)  u4scale
         if (u4scale .gt. 1.0d0)  u4scale = 1.0d0 / u4scale
c
c     set control parameters for reaction field potentials
c
      else if (keyword(1:14) .eq. 'REACTIONFIELD ') then
         string = record(next:80)
         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
      implicit none
      include 'potent.i'
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_strtor = .false.
      use_tortor = .false.
      use_vdw = .false.
      use_charge = .false.
      use_chgdpl = .false.
      use_dipole = .false.
      use_mpole = .false.
      use_polar = .false.
      use_rxnfld = .false.
      use_solv = .false.
      use_metal = .false.
      use_geom = .false.
      use_extra = .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  --  copywrite notice and version info  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "promo" writes a short message containing information
c     about the TINKER version number and the copyright notice
c
c
      subroutine promo
      implicit none
      include 'iounit.i'
c
c
c     print out the informational header message
c
      write (iout,10)
   10 format (/,' ',78('#'),
     &        /,' ',78('#'),
     &        /,' ##',74x,'##',
     &        /,' ##',13x,'TINKER  ---  Software Tools for',
     &           ' Molecular Design',13x,'##',
     &        /,' ##',74x,'##',
     &        /,' ##',26x,'Version 3.9  June 2001',26x,'##',
     &        /,' ##',74x,'##',
     &        /,' ##',15x,'Copyright (c)  Jay William Ponder',
     &           '  1990-2001',15x,'##',
     &        /,' ##',28x,'All Rights Reserved',27x,'##',
     &        /,' ##',74x,'##',
     &        /,' ',78('#'),
     &        /,' ',78('#'),/)
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'iounit.i'
      include 'titles.i'
      integer i,izmt
      integer ixyz,iseq
      integer natom,mode
      integer freeunit,trimtext
      logical exist
      character*60 seqfile
      character*60 intfile
      character*60 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 (a60)
      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 (a60)
      ltitle = trimtext (title)
c
c     read the keyfile and force field parameter file
c
      call getkey
      call field
c
c     get the sequence, build a Z-matrix, convert to Cartesians
c
      call getseq
      call prochain
      call connect
      call makexyz
c
c     remove any dummy atoms from Cartesian coordinates,
c     then convert to internal and Cartesian coordinates 
c
      natom = n
      do i = natom, 1, -1
         if (type(i) .eq. 0)  call delete (i)
      end do
      mode = 0
      call makeint (mode)
      call makexyz
      call chkxyz
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
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'phipsi.i'
      include 'resdue.i'
      include 'sequen.i'
      integer i,j,next
      integer length,trimtext
      logical done
      character*1 chir(maxres)
      character*3 name
      character*80 record
      character*80 string
c
c
c     provide a header to explain the method of sequence input
c
      write (iout,10)
   10 format (/,' Enter One Residue per Line, Free Format: ',
     &           ' 1 or 3 Letter Code, then',
     &        /,' Phi/Psi/Omega (3F), Chi Angles (4F), then',
     &           ' Disulfide Partner if a',
     &        /,' CYS (I) and D/L Chirality as desired (A1), <CR>',
     &           ' ends Residue entry',
     &        //,' The allowed N-Cap Residues are Acetyl=ACE or',
     &           ' Formyl=FOR, and the',
     &        /,' possible C-Cap Residues are N-MethylAmide=NME',
     &           ' or Amide=NH2')
c
c     get the amino acid sequence data and dihedral angle values
c
      i = 0
      done = .false.
      dowhile (.not. done)
         i = i + 1
         phi(i) = 0.0d0
         psi(i) = 0.0d0
         omega(i) = 0.0d0
         do j = 1, 4
            chi(j,i) = 0.0d0
         end do
         disulf(i) = 0
         chir(i) = ' '
         write (iout,20)  i
   20    format (/,' Enter Residue',i4,' :  ',$)
         read (input,30)  record
   30    format (a80)
         call upcase (record)
         next = 1
         call getword (record,name,next)
         string = record(next:80)
         read (string,*,err=40,end=40)  phi(i),psi(i),omega(i),
     &                                  (chi(j,i),j=1,4),disulf(i)
   40    continue
         call getword (record,chir(i),next)
c
c     get length of amino acid name and handle special names
c
         length = trimtext (name)
         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     process and store the current amino acid residue type
c
         if (length .eq. 1) then
            seq(i) = amino(maxamino)
            seqtyp(i) = maxamino
            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
            seq(i) = amino(maxamino)
            seqtyp(i) = maxamino
            do j = 1, maxamino
               if (name .eq. amino(j)) then
                  seq(i) = amino(j)
                  seqtyp(i) = j
               end if
            end do
         else
            done = .true.
            nseq = i - 1
         end if
      end do
c
c     all residues are assumed to be part of a single chain
c
      nchain = 1
      ichain(1,1) = 1
      ichain(2,1) = nseq
      chnnam(1) = ' '
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
            psi(i) = 135.0d0
         end if
         if (omega(i) .eq. 0.0d0) then
            omega(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. 'PHE')  chi(2,i) = 90.0d0
            if (seq(i) .eq. 'TYR')  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,50)  i
   50          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,60)  i,disulf(i)
   60          format (' GETSEQ  --  Error in Disulfide Bond',
     &                    ' at Residue',i5,' or',i5)
            end if
         end if
c
c     check the D/L chirality of the residues
c
         if (chir(i) .eq. 'D') then
            chiral(i) = -1
         else
            chiral(i) = 1
         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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'phipsi.i'
      include 'resdue.i'
      include 'sequen.i'
      integer i,k,next
      integer ntyp(maxamino),catyp(maxamino)
      integer ctyp(maxamino),hntyp(maxamino)
      integer otyp(maxamino),hatyp(maxamino)
      integer nntyp(maxamino),cantyp(maxamino)
      integer cntyp(maxamino),hnntyp(maxamino)
      integer ontyp(maxamino),hantyp(maxamino)
      integer nctyp(maxamino),cactyp(maxamino)
      integer cctyp(maxamino),hnctyp(maxamino)
      integer octyp(maxamino),hactyp(maxamino)
      integer ni(maxres),cai(maxres),ci(maxres)
      logical cyclic
      character*1 answer
      character*3 resname
      character*80 record
c
c     biopolymer atom types for amino acid backbone atoms
c
      data ntyp    /   1,   7,  15,  27,  41,  55,  65,  77,  87,
     &                96, 107, 122, 138, 161, 178, 194, 210, 220,
     &               232, 244, 258, 271, 287, 304, 318, 325,   0,
     &                 0,   0,   0,   1 /
      data catyp   /   2,   8,  16,  28,  42,  56,  66,  78,  88,
     &                97, 108, 123, 139, 162, 179, 195, 211, 221,
     &               233, 245, 259, 272, 288, 305, 319, 326,   0,
     &                 0,   0,   0,   2 /
      data ctyp    /   3,   9,  17,  29,  43,  57,  67,  79,  89,
     &                98, 109, 124, 140, 163, 180, 196, 212, 222,
     &               234, 246, 260, 273, 289, 306, 320, 327,   0,
     &                 0,   0,   0,   3 /
      data hntyp   /   4,  10,  18,  30,  44,  58,  68,  80,  90,
     &                 0, 110, 125, 141, 164, 181, 197, 213, 223,
     &               235, 247, 261, 274, 290, 307, 321, 328,   0,
     &                 0,   0,   0,   4 /
      data otyp    /   5,  11,  19,  31,  45,  59,  69,  81,  91,
     &                99, 111, 126, 142, 165, 182, 198, 214, 224,
     &               236, 248, 262, 275, 291, 308, 322, 329,   0,
     &                 0,   0,   0,   5 /
      data hatyp   /   6,  12,  20,  32,  46,  60,  70,  82,  92,
     &               100, 112, 127, 143, 166, 183, 199, 215, 225,
     &               237, 249, 263, 276, 292, 309,   0, 330,   0,
     &                 0,   0,   0,   6 /
c
c     biopolymer atom types for N-terminal backbone atoms
c
      data nntyp   / 350, 356, 362, 368, 374, 380, 386, 392, 398,
     &               404, 412, 418, 424, 430, 436, 442, 448, 454,
     &               460, 466, 472, 478, 484, 490, 496, 325,   0,
     &                 0,   0,   0, 350 /
      data cantyp  / 351, 357, 363, 369, 375, 381, 387, 393, 399,
     &               405, 413, 419, 425, 431, 437, 443, 449, 455,
     &               461, 467, 473, 479, 485, 491, 497, 326,   0,
     &               340,   0,   0, 351 /
      data cntyp   / 352, 358, 364, 370, 376, 382, 388, 394, 400,
     &               406, 414, 420, 426, 432, 438, 444, 450, 456,
     &               462, 468, 474, 480, 486, 492, 498, 327, 337,
     &               342,   0,   0, 352 /
      data hnntyp  / 353, 359, 365, 371, 377, 383, 389, 395, 401,
     &               407, 415, 421, 427, 433, 439, 445, 451, 457,
     &               463, 469, 475, 481, 487, 493, 499, 328,   0,
     &                 0,   0,   0, 353 /
      data ontyp   / 354, 360, 366, 372, 378, 384, 390, 396, 402,
     &               408, 416, 422, 428, 434, 440, 446, 452, 458,
     &               464, 470, 476, 482, 488, 494, 500, 329, 339,
     &               343,   0,   0, 354 /
      data hantyp  / 355, 361, 367, 373, 379, 385, 391, 397, 403,
     &               409, 417, 423, 429, 435, 441, 447, 453, 459,
     &               465, 471, 477, 483, 489, 495,   0, 330, 338,
     &               341,   0,   0, 355 /
c
c     biopolymer atom types for C-terminal backbone atoms
c
      data nctyp   / 501, 507, 513, 519, 525, 531, 537, 543, 549,
     &               555, 560, 566, 572, 578, 584, 590, 596, 602,
     &               608, 614, 620, 626, 632, 638, 644,   0,   0,
     &                 0, 344, 346, 501 /
      data cactyp  / 502, 508, 514, 520, 526, 532, 538, 544, 550,
     &               556, 561, 567, 573, 579, 585, 591, 597, 603,
     &               609, 615, 621, 627, 633, 639, 645,   0,   0,
     &                 0,   0, 348, 502 /
      data cctyp   / 503, 509, 515, 521, 527, 533, 539, 545, 551,
     &               557, 562, 568, 574, 580, 586, 592, 598, 604,
     &               610, 616, 622, 628, 634, 640, 646,   0,   0,
     &                 0,   0,   0, 503 /
      data hnctyp  / 504, 510, 516, 522, 528, 534, 540, 546, 552,
     &                 0, 563, 569, 575, 581, 587, 593, 599, 605,
     &               611, 617, 623, 629, 635, 641, 647,   0,   0,
     &                 0, 345, 347, 504 /
      data octyp   / 505, 511, 517, 523, 529, 535, 541, 547, 553,
     &               558, 564, 570, 576, 582, 588, 594, 600, 606,
     &               612, 618, 624, 630, 636, 642, 648,   0,   0,
     &                 0,   0,   0, 505 /
      data hactyp  / 506, 512, 518, 524, 530, 536, 542, 548, 554,
     &               559, 565, 571, 577, 583, 589, 595, 601, 607,
     &               613, 619, 625, 631, 637, 643,   0,   0,   0,
     &                 0,   0, 349, 506 /
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 (a80)
      next = 1
      call gettext (record,answer,next)
      call upcase (answer)
      if (answer .eq. 'Y')  cyclic = .true.
c
c     set atom counter and the first residue number and type
c
      n = 1
      i = 1
      k = seqtyp(i)
      resname = amino(k)
c
c     build the first residue for a cyclic peptide
c
      if (cyclic) 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.d00,ni(i),0,0,0)
         ci(i) = n
         call zatom (ctyp(k),1.51d0,110.7d0,0.0d0,cai(i),ni(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 first residue as an N-terminal formyl group
c
      else if (resname .eq. 'FOR') 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)
         psi(i) = 180.0d0
c
c     build the first residue as an N-terminal acetyl group
c
      else if (resname .eq. 'ACE') 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)
         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
         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 (nseq .ne. 1) then
            call zatom (cntyp(k),1.51d0,110.7d0,0.0d0,cai(i),ni(i),0,0)
            call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
         else
            call zatom (cctyp(k),1.51d0,111.6d0,0.0d0,cai(i),ni(i),0,0)
            call zatom (octyp(k),1.25d0,117.0d0,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
         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 (nseq .ne. 1) then
            call zatom (cntyp(k),1.51d0,110.7d0,0.0d0,cai(i),ni(i),0,0)
            call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
         else
            call zatom (cctyp(k),1.51d0,111.6d0,0.0d0,cai(i),ni(i),0,0)
            call zatom (octyp(k),1.25d0,117.0d0,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 all other standard amino acids
c
      else
         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 (nseq .ne. 1) then
            call zatom (cntyp(k),1.51d0,110.7d0,0.0d0,cai(i),ni(i),0,0)
            call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0,
     &                     ci(i),cai(i),ni(i),0)
         else
            call zatom (cctyp(k),1.51d0,111.6d0,0.0d0,cai(i),ni(i),0,0)
            call zatom (octyp(k),1.25d0,117.0d0,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 i = 2, nseq-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,omega(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 = nseq
      k = seqtyp(nseq)
      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,omega(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 for all other standard amino acids
c
      else
         if (nseq .gt. 1) 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,omega(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
c
c     finally, set the total number of atoms in the polypeptide
c
      n = n - 1
      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
      subroutine proside (resname,i,cai,ni,ci)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'phipsi.i'
      include 'sequen.i'
      integer i,cai,ni,ci
      character*3 resname
c
c
c     glycine residue  (GLY)
c
      if (resname .eq. 'GLY') then
         if (i .eq. 1) then
            call zatom (355,1.11d0,109.5d0,107.9d0,cai,ni,ci,chiral(i))
         else if (i .eq. nseq) then
            call zatom (506,1.11d0,109.5d0,107.9d0,cai,ni,ci,chiral(i))
         else
            call zatom (6,1.11d0,109.5d0,107.9d0,cai,ni,ci,chiral(i))
         end if
c
c     alanine residue  (ALA)
c
      else if (resname .eq. 'ALA') then
         call zatom (13,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (14,1.11d0,109.4d0,chi(1,i),n-1,cai,ni,0)
         call zatom (14,1.11d0,109.4d0,109.4d0,n-2,cai,n-1,1)
         call zatom (14,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 (21,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (23,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (25,1.54d0,109.5d0,109.5d0,n-2,cai,n-1,-1)
         call zatom (22,1.11d0,109.4d0,109.4d0,n-3,cai,n-2,1)
         call zatom (24,1.11d0,109.4d0,180.0d0,n-3,n-4,cai,0)
         call zatom (24,1.11d0,109.4d0,109.4d0,n-4,n-5,n-1,1)
         call zatom (24,1.11d0,109.4d0,109.4d0,n-5,n-6,n-2,-1)
         call zatom (26,1.11d0,109.4d0,180.0d0,n-5,n-7,cai,0)
         call zatom (26,1.11d0,109.4d0,109.4d0,n-6,n-8,n-1,1)
         call zatom (26,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 (33,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (35,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (37,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (39,1.54d0,109.5d0,109.4d0,n-2,n-3,n-1,-1)
         call zatom (34,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1)
         call zatom (34,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1)
         call zatom (36,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,1)
         call zatom (38,1.11d0,109.4d0,180.0d0,n-5,n-6,n-7,0)
         call zatom (38,1.11d0,109.4d0,109.4d0,n-6,n-7,n-1,1)
         call zatom (38,1.11d0,109.4d0,109.4d0,n-7,n-8,n-2,-1)
         call zatom (40,1.11d0,109.4d0,180.0d0,n-7,n-9,n-10,0)
         call zatom (40,1.11d0,109.4d0,109.4d0,n-8,n-10,n-1,1)
         call zatom (40,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 (47,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (49,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (51,1.54d0,109.5d0,109.5d0,n-2,cai,n-1,1)
         call zatom (53,1.54d0,109.5d0,chi(2,i),n-2,n-3,cai,0)
         call zatom (48,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,-1)
         call zatom (50,1.11d0,109.4d0,109.4d0,n-4,n-5,n-2,1)
         call zatom (50,1.11d0,109.4d0,109.4d0,n-5,n-6,n-3,-1)
         call zatom (52,1.11d0,110.0d0,180.0d0,n-5,n-7,n-6,0)
         call zatom (52,1.11d0,110.0d0,109.0d0,n-6,n-8,n-1,1)
         call zatom (52,1.11d0,110.0d0,109.0d0,n-7,n-9,n-2,-1)
         call zatom (54,1.11d0,110.0d0,180.0d0,n-7,n-9,n-10,0)
         call zatom (54,1.11d0,110.0d0,109.0d0,n-8,n-10,n-1,1)
         call zatom (54,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 (61,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (63,1.41d0,107.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (62,1.11d0,109.4d0,106.7d0,n-2,cai,n-1,1)
         call zatom (62,1.11d0,109.4d0,106.7d0,n-3,cai,n-2,-1)
         call zatom (64,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 (71,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (73,1.41d0,107.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (75,1.54d0,109.5d0,107.7d0,n-2,cai,n-1,1)
         call zatom (72,1.11d0,109.4d0,106.7d0,n-3,cai,n-2,-1)
         call zatom (74,0.94d0,106.9d0,chi(2,i),n-3,n-4,cai,0)
         call zatom (76,1.11d0,110.0d0,180.0d0,n-3,n-5,cai,0)
         call zatom (76,1.11d0,110.0d0,109.0d0,n-4,n-6,n-1,1)
         call zatom (76,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 (83,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (85,1.82d0,109.0d0,chi(1,i),n-1,cai,ni,0)
         call zatom (84,1.11d0,109.4d0,112.0d0,n-2,cai,n-1,1)
         call zatom (84,1.11d0,109.4d0,112.0d0,n-3,cai,n-2,-1)
         call zatom (86,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
         if (disulf(i) .gt. i) then
            call zatom (93,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
            call zatom (95,1.82d0,109.0d0,chi(1,i),n-1,cai,ni,0)
            call zatom (94,1.11d0,109.4d0,112.0d0,n-2,cai,n-1,1)
            call zatom (94,1.11d0,109.4d0,112.0d0,n-3,cai,n-2,-1)
            disulf(i) = n - 3
         else if (disulf(i) .lt. i) then
            call zatom (93,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
            call zatom (95,1.82d0,109.0d0,chi(1,i),n-1,cai,ni,0)
            call zatom (94,1.11d0,109.4d0,112.0d0,n-2,cai,n-1,1)
            call zatom (94,1.11d0,109.4d0,112.0d0,n-3,cai,n-2,-1)
            call zatom (-1,0.0d0,0.0d0,0.0d0,disulf(disulf(i)),n-3,0,0)
         end if
c
c     proline residue  (PRO)
c
      else if (resname .eq. 'PRO') then
         call zatom (101,1.54d0,107.0d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (103,1.54d0,107.0d0,chi(1,i),n-1,cai,ni,0)
         if (i .eq. 1) then
            call zatom (410,1.54d0,107.0d0,chi(2,i),n-1,n-2,cai,0)
         else
            call zatom (105,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 (102,1.11d0,109.4d0,109.4d0,n-3,cai,n-2,1)
         call zatom (102,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,-1)
         call zatom (104,1.11d0,109.4d0,109.4d0,n-4,n-5,n-3,1)
         call zatom (104,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,-1)
         if (i .eq. 1) then
            call zatom (411,1.11d0,109.4d0,109.4d0,n-5,n-6,ni,1)
            call zatom (411,1.11d0,109.4d0,109.4d0,n-6,n-7,ni,-1)
         else
            call zatom (106,1.11d0,109.4d0,109.4d0,n-5,n-6,ni,1)
            call zatom (106,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 (113,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (115,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (116,1.39d0,120.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (116,1.39d0,120.0d0,120.0d0,n-2,n-3,n-1,1)
         call zatom (118,1.39d0,120.0d0,180.0d0,n-2,n-3,n-4,0)
         call zatom (118,1.39d0,120.0d0,180.0d0,n-2,n-4,n-5,0)
         call zatom (120,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 (114,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,1)
         call zatom (114,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,-1)
         call zatom (117,1.10d0,120.0d0,120.0d0,n-7,n-8,n-5,1)
         call zatom (117,1.10d0,120.0d0,120.0d0,n-7,n-9,n-5,1)
         call zatom (119,1.10d0,120.0d0,120.0d0,n-7,n-9,n-5,1)
         call zatom (119,1.10d0,120.0d0,120.0d0,n-7,n-9,n-6,1)
         call zatom (121,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 (128,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (130,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (131,1.39d0,120.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (131,1.39d0,120.0d0,120.0d0,n-2,n-3,n-1,1)
         call zatom (133,1.39d0,120.0d0,180.0d0,n-2,n-3,n-4,0)
         call zatom (133,1.39d0,120.0d0,180.0d0,n-2,n-4,n-5,0)
         call zatom (135,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 (136,1.36d0,120.0d0,120.0d0,n-1,n-2,n-3,1)
         call zatom (129,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,1)
         call zatom (129,1.11d0,109.4d0,109.4d0,n-9,cai,n-8,-1)
         call zatom (132,1.10d0,120.0d0,120.0d0,n-8,n-9,n-6,1)
         call zatom (132,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1)
         call zatom (134,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1)
         call zatom (134,1.10d0,120.0d0,120.0d0,n-8,n-10,n-7,1)
         call zatom (137,0.97d0,108.0d0,0.0d0,n-7,n-8,n-9,0)
c
c     tryptophan residue  (TRP)
c
      else if (resname .eq. 'TRP') then
         call zatom (144,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (146,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (147,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (149,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1)
         call zatom (150,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0)
         call zatom (152,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 (153,1.35d0,120.0d0,180.0d0,n-3,n-1,n-2,0)
         call zatom (155,1.35d0,120.0d0,0.0d0,n-2,n-4,n-1,0)
         call zatom (157,1.35d0,120.0d0,0.0d0,n-2,n-5,n-3,0)
         call zatom (159,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 (145,1.11d0,109.4d0,109.4d0,n-10,cai,n-9,1)
         call zatom (145,1.11d0,109.4d0,109.4d0,n-11,cai,n-10,-1)
         call zatom (148,1.10d0,124.0d0,124.0d0,n-10,n-11,n-8,1)
         call zatom (151,1.05d0,124.0d0,124.0d0,n-9,n-11,n-8,1)
         call zatom (154,1.10d0,120.0d0,120.0d0,n-8,n-11,n-6,1)
         call zatom (156,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1)
         call zatom (158,1.10d0,120.0d0,120.0d0,n-8,n-10,n-7,1)
         call zatom (160,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 (167,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (169,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (170,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (172,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1)
         call zatom (174,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0)
         call zatom (176,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 (168,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,1)
         call zatom (168,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,-1)
         call zatom (171,1.02d0,126.0d0,0.0d0,n-6,n-7,n-8,0)
         call zatom (173,1.10d0,126.0d0,126.0d0,n-6,n-8,n-4,1)
         call zatom (175,1.10d0,126.0d0,126.0d0,n-6,n-8,n-5,1)
         call zatom (177,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 (184,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (186,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (187,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (189,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1)
         call zatom (191,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0)
         call zatom (193,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 (185,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,1)
         call zatom (185,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,-1)
         call zatom (188,1.02d0,126.0d0,0.0d0,n-6,n-7,n-8,0)
         call zatom (190,1.10d0,126.0d0,126.0d0,n-6,n-8,n-4,1)
         call zatom (192,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 (200,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (202,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (203,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (204,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1)
         call zatom (206,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0)
         call zatom (208,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 (201,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,1)
         call zatom (201,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,-1)
         call zatom (205,1.10d0,126.0d0,126.0d0,n-5,n-7,n-3,1)
         call zatom (207,1.10d0,126.0d0,126.0d0,n-5,n-7,n-4,1)
         call zatom (209,1.02d0,126.0d0,126.0d0,n-5,n-7,n-6,1)
c
c     aspartic acid residue  (ASP)
c
      else if (resname .eq. 'ASP') then
         call zatom (216,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (218,1.51d0,107.8d0,chi(1,i),n-1,cai,ni,0)
         call zatom (219,1.25d0,117.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (219,1.25d0,117.0d0,126.0d0,n-2,n-3,n-1,1)
         call zatom (217,1.11d0,109.4d0,107.9d0,n-4,cai,n-3,1)
         call zatom (217,1.11d0,109.4d0,107.9d0,n-5,cai,n-4,-1)
c
c     asparagine residue  (ASN)
c
      else if (resname .eq. 'ASN') then
         call zatom (226,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (228,1.51d0,107.8d0,chi(1,i),n-1,cai,ni,0)
         call zatom (229,1.22d0,122.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (230,1.34d0,112.7d0,124.0d0,n-2,n-3,n-1,1)
         call zatom (227,1.11d0,109.4d0,107.9d0,n-4,cai,n-3,1)
         call zatom (227,1.11d0,109.4d0,107.9d0,n-5,cai,n-4,-1)
         call zatom (231,1.02d0,119.0d0,0.0d0,n-3,n-5,n-6,0)
         call zatom (231,1.02d0,119.0d0,120.0d0,n-4,n-6,n-1,1)
c
c     glutamic acid residue  (GLU)
c
      else if (resname .eq. 'GLU') then
         call zatom (238,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (240,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (242,1.51d0,107.8d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (243,1.25d0,117.0d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (243,1.25d0,117.0d0,126.0d0,n-2,n-3,n-1,1)
         call zatom (239,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1)
         call zatom (239,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1)
         call zatom (241,1.11d0,109.4d0,107.9d0,n-6,n-7,n-5,1)
         call zatom (241,1.11d0,109.4d0,107.9d0,n-7,n-8,n-6,-1)
c
c     glutamine residue  (GLN)
c
      else if (resname .eq. 'GLN') then
         call zatom (250,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (252,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (254,1.51d0,107.8d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (255,1.22d0,122.5d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (256,1.34d0,112.7d0,124.0d0,n-2,n-3,n-1,1)
         call zatom (251,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1)
         call zatom (251,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1)
         call zatom (253,1.11d0,109.4d0,107.9d0,n-6,n-7,n-5,1)
         call zatom (253,1.11d0,109.4d0,107.9d0,n-7,n-8,n-6,-1)
         call zatom (257,1.02d0,119.0d0,0.0d0,n-5,n-7,n-8,0)
         call zatom (257,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 (264,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (266,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (268,1.82d0,109.0d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (269,1.82d0,96.3d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (265,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1)
         call zatom (265,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1)
         call zatom (267,1.11d0,109.4d0,112.0d0,n-5,n-6,n-4,1)
         call zatom (267,1.11d0,109.4d0,112.0d0,n-6,n-7,n-5,-1)
         call zatom (270,1.11d0,112.0d0,180.0d0,n-5,n-6,n-7,0)
         call zatom (270,1.11d0,112.0d0,109.4d0,n-6,n-7,n-1,1)
         call zatom (270,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 (277,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (279,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (281,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (283,1.54d0,109.5d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (285,1.50d0,109.5d0,chi(4,i),n-1,n-2,n-3,0)
         call zatom (278,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1)
         call zatom (278,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1)
         call zatom (280,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,1)
         call zatom (280,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,-1)
         call zatom (282,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,1)
         call zatom (282,1.11d0,109.4d0,109.4d0,n-8,n-9,n-7,-1)
         call zatom (284,1.11d0,109.4d0,108.8d0,n-8,n-9,n-7,1)
         call zatom (284,1.11d0,109.4d0,108.8d0,n-9,n-10,n-8,-1)
         call zatom (286,1.02d0,109.5d0,180.0d0,n-9,n-10,n-11,0)
         call zatom (286,1.02d0,109.5d0,109.5d0,n-10,n-11,n-1,1)
         call zatom (286,1.02d0,109.5d0,109.5d0,n-11,n-12,n-2,-1)
c
c     arginine residue  (ARG)
c
      else if (resname .eq. 'ARG') then
         call zatom (293,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (295,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (297,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (299,1.45d0,109.5d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (301,1.35d0,120.0d0,chi(4,i),n-1,n-2,n-3,0)
         call zatom (302,1.35d0,120.0d0,180.0d0,n-1,n-2,n-3,0)
         call zatom (302,1.35d0,120.0d0,120.0d0,n-2,n-3,n-1,1)
         call zatom (294,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,1)
         call zatom (294,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,-1)
         call zatom (296,1.11d0,109.4d0,109.4d0,n-8,n-9,n-7,1)
         call zatom (296,1.11d0,109.4d0,109.4d0,n-9,n-10,n-8,-1)
         call zatom (298,1.11d0,109.4d0,109.4d0,n-9,n-10,n-8,1)
         call zatom (298,1.11d0,109.4d0,109.4d0,n-10,n-11,n-9,-1)
         call zatom (300,1.02d0,120.0d0,120.0d0,n-10,n-11,n-9,1)
         call zatom (303,1.02d0,120.0d0,180.0d0,n-9,n-10,n-11,0)
         call zatom (303,1.02d0,120.0d0,120.0d0,n-10,n-11,n-1,1)
         call zatom (303,1.02d0,120.0d0,180.0d0,n-10,n-12,n-13,0)
         call zatom (303,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 (310,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (312,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0)
         call zatom (314,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0)
         call zatom (316,1.50d0,109.5d0,chi(3,i),n-1,n-2,n-3,0)
         call zatom (311,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1)
         call zatom (311,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1)
         call zatom (313,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,1)
         call zatom (313,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,-1)
         call zatom (315,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,1)
         call zatom (315,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,-1)
         call zatom (317,1.02d0,109.5d0,180.0d0,n-7,n-8,n-9,0)
         call zatom (317,1.02d0,109.5d0,109.5d0,n-8,n-9,n-1,1)
         call zatom (317,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 (323,1.54d0,109.5d0,107.8d0,cai,ni,ci,-chiral(i))
         call zatom (323,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i))
         call zatom (324,1.11d0,109.4d0,chi(1,i),n-2,cai,ni,0)
         call zatom (324,1.11d0,109.4d0,109.4d0,n-3,cai,n-2,1)
         call zatom (324,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,-1)
         call zatom (324,1.11d0,109.4d0,chi(1,i),n-4,cai,ni,0)
         call zatom (324,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1)
         call zatom (324,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1)
c
c     pyroglutamic acid residue  (PCA)
c
      else if (resname .eq. 'PCA') then
         call zatom (331,1.54d0,107.0d0,109.5d0,cai,ni,ci,chiral(i))
         call zatom (333,1.54d0,107.0d0,chi(1,i),n-1,cai,ni,0)
         call zatom (335,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 (336,1.22d0,126.0d0,126.0d0,n-1,ni,n-2,1)
         call zatom (332,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1)
         call zatom (332,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1)
         call zatom (334,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,1)
         call zatom (334,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
         if (i .eq. 1) then
            call zatom (355,1.11d0,109.5d0,107.9d0,cai,ni,ci,chiral(i))
         else if (i .eq. nseq) then
            call zatom (506,1.11d0,109.5d0,107.9d0,cai,ni,ci,chiral(i))
         else
            call zatom (6,1.11d0,109.5d0,107.9d0,cai,ni,ci,chiral(i))
         end if
      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 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 disk file
c
c
      subroutine prtdyn
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'files.i'
      include 'group.i'
      include 'mdstuf.i'
      include 'moldyn.i'
      include 'rgddyn.i'
      include 'titles.i'
      integer i,idyn
      integer freeunit
      logical exist
      character*60 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
      write (idyn,10)
   10 format (' Number of Atoms and Title :')
      if (ltitle .eq. 0) then
         write (idyn,20)  n
   20    format (i6)
      else
         write (idyn,30)  n,title(1:ltitle)
   30    format (i6,2x,a)
      end if
c
c     save the periodic box edge lengths and angles
c
      write (idyn,40)
   40 format (' Periodic Box Dimensions :')
      write (idyn,50)  xbox,ybox,zbox
   50 format (3d26.16)
      write (idyn,60)  alpha,beta,gamma
   60 format (3d26.16)
c
c     save rigid-body positions, translational and angular velocities
c
      if (integrate .eq. 'RIGIDBODY') then
         write (idyn,70)
   70    format (' Current Atomic Positions :')
         do i = 1, n
            write (idyn,80)  x(i),y(i),z(i)
   80       format (3d26.16)
         end do
         write (idyn,90)
   90    format (' Current Translational Velocities :')
         do i = 1, ngrp
            write (idyn,100)  vcm(1,i),vcm(2,i),vcm(3,i)
  100       format (3d26.16)
         end do
         write (idyn,110)
  110    format (' Current Angular Velocities :')
         do i = 1, ngrp
            write (idyn,120)  wcm(1,i),wcm(2,i),wcm(3,i)
  120       format (3d26.16)
         end do
         write (idyn,130)
  130    format (' Current Angular Momenta :')
         do i = 1, ngrp
            write (idyn,140)  lm(1,i),lm(2,i),lm(3,i)
  140       format (3d26.16)
         end do
c
c     save the atomic positions, velocities and accelerations
c
      else
         write (idyn,150)
  150    format (' Current Atomic Positions :')
         do i = 1, n
            write (idyn,160)  x(i),y(i),z(i)
  160       format (3d26.16)
         end do
         write (idyn,170)
  170    format (' Current Atomic Velocities :')
         do i = 1, n
            write (idyn,180)  v(1,i),v(2,i),v(3,i)
  180       format (3d26.16)
         end do
         write (idyn,190)
  190    format (' Current Atomic Accelerations :')
         do i = 1, n
            write (idyn,200)  a(1,i),a(2,i),a(3,i)
  200       format (3d26.16)
         end do
         write (idyn,210)
  210    format (' Previous Atomic Accelerations :')
         do i = 1, n
            write (idyn,220)  aold(1,i),aold(2,i),aold(3,i)
  220       format (3d26.16)
         end do
      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
      implicit none
      include 'files.i'
      include 'output.i'
      integer ierr,freeunit
      character*60 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)  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
c     coordinates to an external disk file
c
c
      subroutine prtint (izmt)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'titles.i'
      include 'zclose.i'
      include 'zcoord.i'
      integer i,k,izmt
      logical opened
      character*60 coordfile
c
c
c     open output unit if not already done
c
      inquire (unit=izmt,opened=opened)
      if (.not. opened) then
         coordfile = filename(1:leng)//'.int'
         call version (coordfile,'new')
         open (unit=izmt,file=coordfile,status='new')
      end if
c
c     write out the number of atoms and the title
c
      if (ltitle .eq. 0) then
         write (izmt,10)  n
   10    format (i6)
      else
         write (izmt,20)  n,title(1:ltitle)
   20    format (i6,2x,a)
      end if
c
c     output of first three atoms is handled separately
c
      if (n .ge. 1) then
         write (izmt,30)  1,name(1),type(1)
   30    format (i6,2x,a3,i6)
      end if
      if (n .ge. 2) then
         if (digits .le. 6) then
            write (izmt,40)  2,name(2),type(2),iz(1,2),zbond(2)
   40       format (i6,2x,a3,2i6,f10.5)
         else if (digits .le. 8) then
            write (izmt,50)  2,name(2),type(2),iz(1,2),zbond(2)
   50       format (i6,2x,a3,2i6,f12.7)
         else
            write (izmt,60)  2,name(2),type(2),iz(1,2),zbond(2)
   60       format (i6,2x,a3,2i6,f14.9)
         end if
      end if
      if (n .ge. 3) then
         if (digits .le. 6) then
            write (izmt,70)  3,name(3),type(3),iz(1,3),zbond(3),
     &                       iz(2,3),zang(3)
   70       format (i6,2x,a3,2i6,f10.5,i6,f10.4)
         else if (digits .le. 8) then
            write (izmt,80)  3,name(3),type(3),iz(1,3),zbond(3),
     &                       iz(2,3),zang(3)
   80       format (i6,2x,a3,2i6,f12.7,i6,f12.6)
         else
            write (izmt,90)  3,name(3),type(3),iz(1,3),zbond(3),
     &                       iz(2,3),zang(3)
   90       format (i6,2x,a3,2i6,f14.9,i6,f14.8)
         end if
      end if
c
c     convert the torsional angles to lie in standard range
c
      do i = 4, n
         if (iz(4,i) .eq. 0) then
            dowhile (ztors(i) .lt. -180.0d0)
               ztors(i) = ztors(i) + 360.0d0
            end do
            dowhile (ztors(i) .gt. 180.0d0)
               ztors(i) = ztors(i) - 360.0d0
            end do
         end if
      end do
c
c     now, output the fourth through final atoms
c
      if (digits .le. 6) then
         do i = 4, n
            write (izmt,100)  i,name(i),type(i),iz(1,i),zbond(i),
     &                        iz(2,i),zang(i),iz(3,i),ztors(i),iz(4,i)
  100       format (i6,2x,a3,2i6,f10.5,i6,f10.4,i6,f10.4,i6)
         end do
      else if (digits .le. 8) then
         do i = 4, n
            write (izmt,110)  i,name(i),type(i),iz(1,i),zbond(i),
     &                        iz(2,i),zang(i),iz(3,i),ztors(i),iz(4,i)
  110       format (i6,2x,a3,2i6,f12.7,i6,f12.6,i6,f12.6,i6)
         end do
      else
         do i = 4, n
            write (izmt,120)  i,name(i),type(i),iz(1,i),zbond(i),
     &                        iz(2,i),zang(i),iz(3,i),ztors(i),iz(4,i)
  120       format (i6,2x,a3,2i6,f14.9,i6,f14.8,i6,f14.8,i6)
         end do
      end if
c
c     finally, add or delete bonds as required
c
      if (nadd.ne.0 .or. ndel.ne.0)  write (izmt,130)
  130 format ()
      do i = 1, nadd
         write (izmt,140)  (iadd(k,i),k=1,2)
  140    format (2i6)
      end do
      if (ndel .ne. 0)  write (izmt,150)
  150 format ()
      do i = 1, ndel
         write (izmt,160)  (idel(k,i),k=1,2)
  160    format (2i6)
      end do
      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 of Sybyl MOL2 coordinate file  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "prtmol2" writes out a set of coordinates in Sybyl MOL2
c     format to an external disk file
c
c
      subroutine prtmol2 (isyb)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'files.i'
      include 'iounit.i'
      include 'titles.i'
      integer i,j,k,isyb
      integer thousand,hundred
      integer tens,ones
      logical opened
      character*1 digit(0:9)
      character*4 atmtyp,number
      character*7 atmnam
      character*60 sybylfile
      data digit / '0','1','2','3','4','5','6','7','8','9' /
c
c
c     open output unit if not already done
c
      inquire (unit=isyb,opened=opened)
      if (.not. opened) then
         sybylfile = filename(1:leng)//'.mol2'
         call version (sybylfile,'new')
         open (unit=isyb,file=sybylfile,status='new')
      end if
c
c     write the molecule record type indicator
c
      write (isyb,10)
   10 format ('@<TRIPOS>MOLECULE')
      if (ltitle .eq. 0) then
         write (isyb,20)
   20    format ('****')
      else
         write (isyb,30)  title(1:ltitle)
   30    format (a)
      end if
      write (isyb,40)  n,nbond,1
   40 format (3i8)
      write (isyb,50)
   50 format ('SMALL')
      write (isyb,60)
   60 format ('NO_CHARGES')
c
c     write the atom record type indicator
c
      write (isyb,70)
   70 format (/,'@<TRIPOS>ATOM')
      do i = 1, n
c
c     set the Sybyl atom_name for the atom
c
         thousand = i / 1000
         hundred = (i - 1000*thousand) / 100
         tens = (i - 1000*thousand - 100*hundred) / 10
         ones = i - 1000*thousand - 100*hundred - 10*tens
         number(1:1) = digit(thousand)
         number(2:2) = digit(hundred)
         number(3:3) = digit(tens)
         number(4:4) = digit(ones)
         if (number(1:1) .eq. '0')  number(1:1) = ' '
         if (number(2:2).eq.'0' .and. number(1:1).eq.' ') then
            number(2:2) = ' '
         end if
         if (number(3:3).eq.'0' .and. number(2:2).eq.' ') then
            number(3:3) = ' '
         end if
         atmnam = name(i)//number
         do j = 1, 6
            dowhile (atmnam(j:j) .eq. ' ')
               do k = j, 6
                  atmnam(k:k) = atmnam(k+1:k+1)
               end do
               atmnam(7:7) = '*'
            end do
         end do
         do j = 1, 7
            if (atmnam(j:j) .eq. '*')  atmnam(j:j) = ' '
         end do
c
c     set the Sybyl atom_type for the atom
c
         atmtyp = name(i)//' '
         if (atmtyp .eq. 'C  ') then
            if (n12(i) .eq. 4)  atmtyp = 'C.3 '
            if (n12(i) .eq. 3)  atmtyp = 'C.2 '
            if (n12(i) .eq. 2)  atmtyp = 'C.1 '
         else if (atmtyp .eq. 'N  ') then
            if (n12(i) .ge. 3)  atmtyp = 'N.3 '
            if (n12(i) .eq. 2)  atmtyp = 'N.2 '
            if (n12(i) .eq. 1)  atmtyp = 'N.1 '
         else if (atmtyp .eq. 'N+ ') then
            atmtyp = 'N.4 '
         else if (atmtyp .eq. 'O  ') then
            if (n12(i) .ge. 2)  atmtyp = 'O.3 '
            if (n12(i) .le. 1)  atmtyp = 'O.2 '
         else if (atmtyp .eq. 'O- ') then
            atmtyp = 'O.2 '
         else if (atmtyp .eq. 'S  ') then
            if (n12(i) .ge. 2)  atmtyp = 'S.3 '
            if (n12(i) .le. 1)  atmtyp = 'S.2 '
         else if (atmtyp .eq. 'P  ') then
            atmtyp = 'P.3 '
         else if (atmtyp .eq. 'Lp ') then
            atmtyp = 'LP  '
         end if
         write (isyb,80)  i,atmnam,x(i),y(i),z(i),atmtyp
   80    format (i8,3x,a7,2x,3f12.6,3x,a4)
      end do
c
c     write the bond record type indicator
c
      write (isyb,90)
   90 format (/,'@<TRIPOS>BOND')
      do i = 1, nbond
         write (isyb,100)  i,(ibnd(j,i),j=1,2),1
  100    format (4i8)
      end do
c
c     write the substructure record type indicator
c
      write (isyb,110)
  110 format (/,'@<TRIPOS>SUBSTRUCTURE')
      write (isyb,120)  1,'****',1
  120 format (i8,12x,a4,i8)
      if (.not. opened)  close (unit=isyb)
      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 Protein Data Bank
c     coordinates to an external disk file
c
c
      subroutine prtpdb (ipdb)
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'pdb.i'
      include 'sequen.i'
      include 'titles.i'
      integer i,k,ipdb
      integer start,stop,resnumb
      integer resid(maxres)
      logical opened
      character*1 chnname
      character*1 chain(maxres)
      character*60 pdbfile
c
c
c     open 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 (ltitle .eq. 0) then
         write (ipdb,10)
   10    format ('HEADER',/,'COMPND',/,'SOURCE')
      else
         write (ipdb,20)  title(1:ltitle)
   20    format ('HEADER',4x,a,/,'COMPND',/,'SOURCE')
      end if
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     next, write the coordinates for each PDB atom
c
      do i = 1, npdb
         if (pdbtyp(i) .eq. 'ATOM  ') then
            resnumb = resid(resnum(i))
            chnname = chain(resnum(i))
         else
            resnumb = resnum(i)
            chnname = ' '
         end if
         if (resnam(i) .eq. 'CYX')  resnam(i) = 'CYS'
         if (resnam(i) .eq. 'HIP')  resnam(i) = 'HIS'
         write (ipdb,30)  pdbtyp(i),i,atmnam(i),resnam(i),chnname,
     &                    resnumb,xpdb(i),ypdb(i),zpdb(i)
   30    format (a6,i5,1x,a4,1x,a3,1x,a1,i4,4x,3f8.3)
      end do
c
c     finally, write any connectivity records for PDB atoms
c
      do i = 1, npdb
         if (npdb12(i) .ne. 0) then
            write (ipdb,40)  i,(ipdb12(k,i),k=1,npdb12(i))
   40       format ('CONECT',5i5)
         end if
      end do
      write (ipdb,50)
   50 format ('END')
c     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)
      implicit none
      include 'sizes.i'
      include 'angpot.i'
      include 'bndpot.i'
      include 'chgpot.i'
      include 'fields.i'
      include 'kanang.i'
      include 'kangs.i'
      include 'katoms.i'
      include 'kbonds.i'
      include 'kchrge.i'
      include 'kdipol.i'
      include 'khbond.i'
      include 'kiprop.i'
      include 'kitors.i'
      include 'kmulti.i'
      include 'kopbnd.i'
      include 'kopdst.i'
      include 'korbs.i'
      include 'kpolr.i'
      include 'kstbnd.i'
      include 'ksttor.i'
      include 'ktorsn.i'
      include 'kurybr.i'
      include 'kvdws.i'
      include 'kvdwpr.i'
      include 'mplpot.i'
      include 'polpot.i'
      include 'urypot.i'
      include 'vdwpot.i'
      integer i,j,k,itxt
      integer number,npg
      integer k1,k2,k3,k4
      integer fold(6)
      real*8 ampli(6)
      real*8 phase(6)
      logical exist
      character*1 formfeed
c
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. '   ')  exist = .true.
      end do
      if (exist) then
         write (itxt,10)  forcefield
   10    format (//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,20)
   20    format (//,17x,'Force Field Atom Definitions',
     &           //,52x,'Atomic',4x,'Atomic',
     &           /,7x,'Type',3x,'Class',3x,'Symbol',3x,'Description',
     &              10x,'Number',4x,'Weight',3x,'Valence',/)
         do i = 1, maxtyp
            if (symbol(i) .ne. '   ') then
               write (itxt,30)  i,atmcls(i),symbol(i),describe(i),
     &                          atmnum(i),weight(i),ligand(i)
   30          format (5x,i5,3x,i5,5x,a3,5x,a20,i5,f12.3,i7)
            end if
         end do
      end if
c
c     van der Waals parameters for atom types
c
      exist = .false.
      do i = 1, maxclass
         if (rad(i) .ne. 0.0d0)  exist = .true.
      end do
      if (exist) then
         write (itxt,40)  formfeed,forcefield
   40    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,50)
   50    format (//,17x,'Van der Waals Parameters',
     &           ///,22x,'Class',7x,'Radius',6x,'Epsilon',
     &                 4x,'Reduction',/)
         k = 0
         do i = 1, maxclass
            if (rad(i) .ne. 0.0d0) then
               k = k + 1
               write (itxt,60)  k,i,rad(i),eps(i),reduct(i)
   60          format (13x,i5,5x,i3,2x,3f12.3)
            end if
         end do
c
c     van der Waals scaling parameters
c
         write (itxt,70)  v2scale,v3scale,v4scale,v5scale
   70    format (//,17x,'Van der Waals Scaling Factors',
     &           ///,23x,'1-2 Atoms',f17.3,/,23x,'1-3 Atoms',f17.3,
     &           /,23x,'1-4 Atoms',f17.3,/,23x,'1-5 Atoms',f17.3)
      end if
c
c     van der Waals 1-4 parameters for atom types
c
      exist = .false.
      do i = 1, maxclass
         if (rad4(i) .ne. 0.0d0)  exist = .true.
      end do
      if (exist) then
         write (itxt,80)
   80    format (//,17x,'Van der Waals Parameters for 1-4 Interactions',
     &           ///,22x,'Class',7x,'Radius',6x,'Epsilon',/)
         k = 0
         do i = 1, maxclass
            if (rad4(i) .ne. 0.0d0) then
               k = k + 1
               write (itxt,90)  k,i,rad4(i),eps4(i)
   90          format (13x,i5,5x,i3,2x,2f12.3)
            end if
         end do
      end if
c
c     van der Waals parameters for specific atom pairs
c
      if (kvpr(1) .ne. '      ') then
         write (itxt,100)
  100    format (//,17x,'Van der Waals Parameters for Atom Pairs',
     &           ///,23x,'Classes',7x,'Radii Sum',4x,'Epsilon',/)
         do i = 1, maxnvp
            if (kvpr(i) .eq. '      ')  goto 120
            k1 = number (kvpr(i)(1:3))
            k2 = number (kvpr(i)(4:6))
            write (itxt,110)  i,k1,k2,radpr(i),epspr(i)
  110       format (13x,i5,5x,i3,'-',i3,2x,2f12.3)
         end do
  120    continue
      end if
c
c     hydrogen bonding parameters for specific atom pairs
c
      if (khb(1) .ne. '      ') then
         write (itxt,130)
  130    format (//,17x,'Hydrogen Bonding Parameters for Atom Pairs',
     &           ///,23x,'Classes',7x,'Radii Sum',4x,'Epsilon',/)
         do i = 1, maxnhb
            if (khb(i) .eq. '      ')  goto 150
            k1 = number (khb(i)(1:3))
            k2 = number (khb(i)(4:6))
            write (itxt,140)  i,k1,k2,radhb(i),epshb(i)
  140       format (13x,i5,5x,i3,'-',i3,2x,2f12.3)
         end do
  150    continue
      end if
c
c     bond stretching parameters
c
      if (kb(1) .ne. '      ') then
         write (itxt,160)  formfeed,forcefield
  160    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,170)
  170    format (//,17x,'Bond Stretching Parameters',
     &           ///,23x,'Classes',15x,'KS',7x,'Length',/)
         do i = 1, maxnb
            if (kb(i) .eq. '      ')  goto 190
            k1 = number (kb(i)(1:3))
            k2 = number (kb(i)(4:6))
            write (itxt,180)  i,k1,k2,bcon(i),blen(i)
  180       format (13x,i5,5x,i3,'-',i3,6x,f12.3,f12.4)
         end do
  190    continue
      end if
c
c     bond stretching parameters for 5-membered rings
c
      if (kb5(1) .ne. '      ') then
         write (itxt,200)
  200    format (//,17x,'5-Membered Ring Stretch Parameters',
     &           ///,23x,'Classes',15x,'KS',7x,'Length',/)
         do i = 1, maxnb5
            if (kb5(i) .eq. '      ')  goto 220
            k1 = number (kb5(i)(1:3))
            k2 = number (kb5(i)(4:6))
            write (itxt,210)  i,k1,k2,bcon5(i),blen5(i)
  210       format (13x,i5,5x,i3,'-',i3,6x,f12.3,f12.4)
         end do
  220    continue
      end if
c
c     bond stretching parameters for 4-membered rings
c
      if (kb4(1) .ne. '      ') then
         write (itxt,230)
  230    format (//,17x,'4-Membered Ring Stretch Parameters',
     &           ///,23x,'Classes',15x,'KS',7x,'Length',/)
         do i = 1, maxnb4
            if (kb4(i) .eq. '      ')  goto 250
            k1 = number (kb4(i)(1:3))
            k2 = number (kb4(i)(4:6))
            write (itxt,270)  i,k1,k2,bcon4(i),blen4(i)
  240       format (13x,i5,5x,i3,'-',i3,6x,f12.3,f12.4)
         end do
  250    continue
      end if
c
c     bond stretching parameters for 3-membered rings
c
      if (kb3(1) .ne. '      ') then
         write (itxt,260)
  260    format (//,17x,'3-Membered Ring Stretch Parameters',
     &           ///,23x,'Classes',15x,'KS',7x,'Length',/)
         do i = 1, maxnb3
            if (kb3(i) .eq. '      ')  goto 280
            k1 = number (kb3(i)(1:3))
            k2 = number (kb3(i)(4:6))
            write (itxt,270)  i,k1,k2,bcon3(i),blen3(i)
  270       format (13x,i5,5x,i3,'-',i3,6x,f12.3,f12.4)
         end do
  280    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,290)  cbnd,qbnd
  290    format (//,17x,'Higher Order Stretching Constants',
     &           ///,23x,'Cubic',f17.3,/,23x,'Quartic',f15.3)
      end if
c
c     electronegativity bond length correction parameters
c
      if (kel(1) .ne. '         ') then
         write (itxt,300)
  300    format (//,17x,'Electronegativity Bond Length Parameters',
     &           ///,26x,'Classes',20x,'dLength',/)
         do i = 1, maxnel
            if (kel(i) .eq. '         ')  goto 320
            k1 = number (kel(i)(1:3))
            k2 = number (kel(i)(4:6))
            k3 = number (kel(i)(7:9))
            write (itxt,310)  i,k1,k2,k3,dlen(i)
  310       format (13x,i5,5x,i3,'-',i3,'-',i3,14x,f12.4)
         end do
  320    continue
      end if
c
c     bond angle bending parameters
c
      if (ka(1) .ne. '         ') then
         write (itxt,330)  formfeed,forcefield
  330    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,340)
  340    format (//,17x,'Angle Bending Parameters',
     &           ///,18x,'Classes',10x,'KB',6x,'Value 1',
     &              5x,'Value 2',5x,'Value 3',
     &           /,43x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/)
         do i = 1, maxna
            if (ka(i) .eq. '         ')  goto 370
            k1 = number (ka(i)(1:3))
            k2 = number (ka(i)(4:6))
            k3 = number (ka(i)(7:9))
            if (ang(2,i).eq.0.0d0 .and. ang(3,i).eq.0.0d0) then
               write (itxt,350)  i,k1,k2,k3,acon(i),ang(1,i)
  350          format (5x,i5,5x,i3,'-',i3,'-',i3,2f12.3)
            else
               write (itxt,360)  i,k1,k2,k3,acon(i),(ang(j,i),j=1,3)
  360          format (5x,i5,5x,i3,'-',i3,'-',i3,4f12.3)
            end if
         end do
  370    continue
      end if
c
c     bond angle bending parameters for 5-membered rings
c
      if (ka5(1) .ne. '         ') then
         write (itxt,380)
  380    format (//,17x,'5-Membered Ring Bend Parameters',
     &           ///,18x,'Classes',10x,'KB',6x,'Value 1',
     &              5x,'Value 2',5x,'Value 3',
     &           /,43x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/)
         do i = 1, maxna5
            if (ka5(i) .eq. '         ')  goto 410
            k1 = number (ka5(i)(1:3))
            k2 = number (ka5(i)(4:6))
            k3 = number (ka5(i)(7:9))
            if (ang5(2,i).eq.0.0d0 .and. ang5(3,i).eq.0.0d0) then
               write (itxt,390)  i,k1,k2,k3,acon5(i),ang5(1,i)
  390          format (5x,i5,5x,i3,'-',i3,'-',i3,2f12.3)
            else
               write (itxt,400)  i,k1,k2,k3,acon5(i),(ang5(j,i),j=1,3)
  400          format (5x,i5,5x,i3,'-',i3,'-',i3,4f12.3)
            end if
         end do
  410    continue
      end if
c
c     bond angle bending parameters for 4-membered rings
c
      if (ka4(1) .ne. '         ') then
         write (itxt,420)
  420    format (//,17x,'4-Membered Ring Bend Parameters',
     &           ///,18x,'Classes',10x,'KB',6x,'Value 1',
     &              5x,'Value 2',5x,'Value 3',
     &           /,43x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/)
         do i = 1, maxna4
            if (ka4(i) .eq. '         ')  goto 450
            k1 = number (ka4(i)(1:3))
            k2 = number (ka4(i)(4:6))
            k3 = number (ka4(i)(7:9))
            if (ang4(2,i).eq.0.0d0 .and. ang4(3,i).eq.0.0d0) then
               write (itxt,430)  i,k1,k2,k3,acon4(i),ang4(1,i)
  430          format (5x,i5,5x,i3,'-',i3,'-',i3,2f12.3)
            else
               write (itxt,440)  i,k1,k2,k3,acon4(i),(ang4(j,i),j=1,3)
  440          format (5x,i5,5x,i3,'-',i3,'-',i3,4f12.3)
            end if
         end do
  450    continue
      end if
c
c     bond angle bending parameters for 3-membered rings
c
      if (ka3(1) .ne. '         ') then
         write (itxt,460)
  460    format (//,17x,'3-Membered Ring Bend Parameters',
     &           ///,18x,'Classes',10x,'KB',6x,'Value 1',
     &              5x,'Value 2',5x,'Value 3',
     &           /,43x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/)
         do  i = 1, maxna3
            if (ka3(i) .eq. '         ')  goto 490
            k1 = number (ka3(i)(1:3))
            k2 = number (ka3(i)(4:6))
            k3 = number (ka3(i)(7:9))
            if (ang3(2,i).eq.0.0d0 .and. ang3(3,i).eq.0.0d0) then
               write (itxt,470)  i,k1,k2,k3,acon3(i),ang3(1,i)
  470          format (5x,i5,5x,i3,'-',i3,'-',i3,2f12.3)
            else
               write (itxt,480)  i,k1,k2,k3,acon3(i),(ang3(j,i),j=1,3)
  480          format (5x,i5,5x,i3,'-',i3,'-',i3,4f12.3)
            end if
         end do
  490    continue
      end if
c
c     Fourier bond angle bending parameters
c
      if (kaf(1) .ne. '         ') then
         write (itxt,500)
  500    format (//,17x,'Fourier Angle Bending Parameters',
     &           ///,18x,'Classes',10x,'KB',8x,'Shift',6x,'Period',/)
         do  i = 1, maxnaf
            if (kaf(i) .eq. '         ')  goto 520
            k1 = number (kaf(i)(1:3))
            k2 = number (kaf(i)(4:6))
            k3 = number (kaf(i)(7:9))
            write (itxt,510)  i,k1,k2,k3,aconf(i),(angf(j,i),j=1,2)
  510       format (5x,i5,5x,i3,'-',i3,'-',i3,3f12.3)
         end do
  520    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,530)  cang,qang,pang,sang
  530    format (//,17x,'Higher Order Bending Constants',
     &           ///,21x,'Cubic',d17.3,/,21x,'Quartic',d15.3,
     &           /,21x,'Pentic',d16.3,/,21x,'Sextic',d16.3)
      end if
c
c     stretch-bend parameters
c
      exist = .false.
      do i = 1, maxclass
         do k = 1, 3
            if (stbn(k,i) .ne. 0.0d0)  exist = .true.
         end do
      end do
      if (exist) then
         write (itxt,540)  formfeed,forcefield
  540    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,550)
  550    format (//,17x,'Stretch-Bend Parameters',
     &           ///,21x,'Class',9x,'KSB 1',7x,'KSB 2',7x,'KSB 3',
     &           /,34x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/)
         k = 0
         do i = 1, maxclass
            if (stbn(1,i).ne.0.0d0 .or. stbn(2,i).ne.0.0d0
     &               .or. stbn(3,i).ne.0.0d0) then
               k = k + 1
               write (itxt,560)  k,i,(stbn(j,i),j=1,3)
  560          format (10x,i5,7x,i3,3x,3f12.3)
            end if
         end do
      end if
c
c     Urey-Bradley parameters
c
      if (ku(1) .ne. '         ') then
         write (itxt,570)  formfeed,forcefield
  570    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,580)
  580    format (//,17x,'Urey-Bradley Parameters',
     &           ///,18x,'Classes',10x,'KB',6x,'Distance',/)
         do i = 1, maxnu
            if (ku(i) .eq. '         ')  goto 600
            k1 = number (ku(i)(1:3))
            k2 = number (ku(i)(4:6))
            k3 = number (ku(i)(7:9))
            write (itxt,590)  i,k1,k2,k3,ucon(i),dst13(i)
  590       format (5x,i5,5x,i3,'-',i3,'-',i3,f12.3,f12.4)
         end do
  600    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,610)  cury,qury
  610    format (//,17x,'Higher Order Urey-Bradley Constants',
     &           ///,23x,'Cubic',f17.3,/,23x,'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,620)  formfeed,forcefield
  620    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,630)
  630    format (//,17x,'Angle-Angle Parameters',
     &           ///,21x,'Class',9x,'KAA 1',7x,'KAA 2',7x,'KAA 3',
     &           /,34x,'(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,640)  k,i,(anan(j,i),j=1,3)
  640          format (10x,i5,7x,i3,3x,3f12.3)
            end if
         end do
      end if
c
c     out-of-plane bending parameters
c
      if (kaopb(1) .ne. '      ') then
         write (itxt,650)  formfeed,forcefield
  650    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,660)
  660    format (//,17x,'Out-of-Plane Bend Parameters',
     &           ///,23x,'Classes',8x,'KOPB',/)
         do i = 1, maxnopb
            if (kaopb(i) .eq. '      ')  goto 680
            k1 = number (kaopb(i)(1:3))
            k2 = number (kaopb(i)(4:6))
            write (itxt,670)  i,k1,k2,copb(i)
  670       format (10x,i5,8x,i3,'-',i3,f12.3)
         end do
  680    continue
      end if
c
c     out-of-plane distance parameters
c
      if (kaopd(1) .ne. '            ') then
         write (itxt,690)  formfeed,forcefield
  690    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,700)
  700    format (//,17x,'Out-of-Plane Distance Parameters',
     &           ///,25x,'Classes',10x,'KOPD',/)
         do i = 1, maxnopd
            if (kaopd(i) .eq. '            ')  goto 720
            k1 = number (kaopd(i)(1:3))
            k2 = number (kaopd(i)(4:6))
            k3 = number (kaopd(i)(7:9))
            k4 = number (kaopd(i)(10:12))
            write (itxt,710)  i,k1,k2,k3,k4,copd(i)
  710       format (10x,i5,5x,i3,'-',i3,'-',i3,'-',i3,f12.3)
         end do
  720    continue
      end if
c
c     improper dihedral parameters
c
      if (kdi(1) .ne. '            ') then
         write (itxt,730)  formfeed,forcefield
  730    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,740)
  740    format (//,17x,'Improper Dihedral Parameters',
     &           ///,20x,'Classes',11x,'KID',7x,'Target',/)
         do i = 1, maxndi
            if (kdi(i) .eq. '            ')  goto 760
            k1 = number (kdi(i)(1:3))
            k2 = number (kdi(i)(4:6))
            k3 = number (kdi(i)(7:9))
            k4 = number (kdi(i)(10:12))
            write (itxt,750)  i,k1,k2,k3,k4,dcon(i),tdi(i)
  750       format (5x,i5,5x,i3,'-',i3,'-',i3,'-',i3,f12.3,f12.4)
         end do
  760    continue
      end if
c
c     improper torsional parameters
c
      if (kti(1) .ne. '            ') then
         write (itxt,770)  formfeed,forcefield
  770    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,780)
  780    format (//,17x,'Improper Torsion Parameters',
     &           ///,18x,'Classes',15x,'KTI Values',/)
         do i = 1, maxnti
            if (kti(i) .eq. '            ')  goto 800
            k1 = number (kti(i)(1:3))
            k2 = number (kti(i)(4:6))
            k3 = number (kti(i)(7:9))
            k4 = number (kti(i)(10:12))
            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,790)  i,k1,k2,k3,k4,(ampli(k),
     &                        phase(k),fold(k),k=1,j)
  790       format (3x,i5,5x,i3,'-',i3,'-',i3,'-',i3,2x,3(f8.3,f6.1,i2))
         end do
  800    continue
      end if
c
c     torsional angle parameters
c
      if (kt(1) .ne. '            ') then
         write (itxt,810)  formfeed,forcefield
  810    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,820)
  820    format (//,17x,'Torsional Parameters',
     &           ///,18x,'Classes',15x,'KT Values',/)
         do i = 1, maxnt
            if (kt(i) .eq. '            ')  goto 840
            k1 = number (kt(i)(1:3))
            k2 = number (kt(i)(4:6))
            k3 = number (kt(i)(7:9))
            k4 = number (kt(i)(10:12))
            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,830)  i,k1,k2,k3,k4,(ampli(k),
     &                        phase(k),fold(k),k=1,j)
  830       format (3x,i5,5x,i3,'-',i3,'-',i3,'-',i3,2x,6(f8.3,f6.1,i2))
         end do
  840    continue
      end if
c
c     torsional angle parameters for 5-membered rings
c
      if (kt5(1) .ne. '            ') then
         write (itxt,850)
  850    format (//,17x,'5-Membered Ring Torsion Parameters',
     &           ///,18x,'Classes',15x,'KT Values',/)
         do i = 1, maxnt5
            if (kt5(i) .eq. '            ')  goto 870
            k1 = number (kt5(i)(1:3))
            k2 = number (kt5(i)(4:6))
            k3 = number (kt5(i)(7:9))
            k4 = number (kt5(i)(10:12))
            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,860)  i,k1,k2,k3,k4,(ampli(k),
     &                        phase(k),fold(k),k=1,j)
  860       format (3x,i5,5x,i3,'-',i3,'-',i3,'-',i3,2x,6(f8.3,f6.1,i2))
         end do
  870    continue
      end if
c
c     torsional angle parameters for 4-membered rings
c
      if (kt4(1) .ne. '            ') then
         write (itxt,880)
  880    format (//,17x,'4-Membered Ring Torsion Parameters',
     &           ///,18x,'Classes',15x,'KT Values',/)
         do i = 1, maxnt4
            if (kt4(i) .eq. '            ')  goto 900
            k1 = number (kt4(i)(1:3))
            k2 = number (kt4(i)(4:6))
            k3 = number (kt4(i)(7:9))
            k4 = number (kt4(i)(10:12))
            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,890)  i,k1,k2,k3,k4,(ampli(k),
     &                        phase(k),fold(k),k=1,j)
  890       format (3x,i5,5x,i3,'-',i3,'-',i3,'-',i3,2x,6(f8.3,f6.1,i2))
         end do
  900    continue
      end if
c
c     stretch-torsion parameters
c
      if (kbt(1) .ne. '      ') then
         write (itxt,910)  formfeed,forcefield
  910    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,920)
  920    format (//,17x,'Stretch-Torsion Parameters',
     &           ///,19x,'Classes',14x,'KST1',8x,'KST2',8x,'KST3',/)
         do i = 1, maxnbt
            if (kbt(i) .eq. '      ')  goto 940
            k1 = number (kbt(i)(1:3))
            k2 = number (kbt(i)(4:6))
            write (itxt,930)  i,k1,k2,(btcon(j,i),j=1,3)
  930       format (9x,i5,5x,i3,'-',i3,6x,3f12.3)
         end do
  940    continue
      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,950)  formfeed,forcefield
  950    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,960)
  960    format (//,17x,'Atomic Partial Charge Parameters',
     &           ///,28x,'Type',9x,'Partial Chg',/)
         k = 0
         do i = 1, maxtyp
            if (chg(i) .ne. 0.0d0) then
               k = k + 1
               write (itxt,970)  k,i,chg(i)
  970          format (16x,i5,7x,i3,6x,f12.3)
            end if
         end do
c
c     atomic partial charge scaling parameters
c
         write (itxt,980)  c2scale,c3scale,c4scale,c5scale
  980    format (//,17x,'Atomic Partial Charge Scaling Factors',
     &           ///,23x,'1-2 Atoms',f17.3,/,23x,'1-3 Atoms',f17.3,
     &           /,23x,'1-4 Atoms',f17.3,/,23x,'1-5 Atoms',f17.3)
      end if
c
c     bond dipole moment parameters
c
      if (kd(1) .ne. '      ') then
         write (itxt,990)  formfeed,forcefield
  990    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,1000)
 1000    format (//,17x,'Bond Dipole Moment Parameters',
     &           ///,26x,'Types',9x,'Bond Dipole',4x,'Position',/)
         do i = 1, maxnd
            if (kd(i) .eq. '      ')  goto 1020
            k1 = number (kd(i)(1:3))
            k2 = number (kd(i)(4:6))
            write (itxt,1010)  i,k1,k2,dpl(i),pos(i)
 1010       format (14x,i5,5x,i3,'-',i3,6x,2f12.3)
         end do
 1020    continue
      end if
c
c     bond dipole moment parameters for 5-membered rings
c
      if (kd5(1) .ne. '      ') then
         write (itxt,1030)
 1030    format (//,17x,'5-Membered Ring Bond Dipole Parameters',
     &           ///,26x,'Types',9x,'Bond Dipole',4x,'Position',/)
         do i = 1, maxnd5
            if (kd5(i) .eq. '      ')  goto 1050
            k1 = number (kd5(i)(1:3))
            k2 = number (kd5(i)(4:6))
            write (itxt,1040)  i,k1,k2,dpl5(i),pos5(i)
 1040       format (14x,i5,5x,i3,'-',i3,6x,2f12.3)
         end do
 1050    continue
      end if
c
c     bond dipole moment parameters for 4-membered rings
c
      if (kd4(1) .ne. '      ') then
         write (itxt,1060)
 1060    format (//,17x,'4-Membered Ring Bond Dipole Parameters',
     &           ///,26x,'Types',9x,'Bond Dipole',4x,'Position',/)
         do i = 1, maxnd4
            if (kd4(i) .eq. '      ')  goto 1080
            k1 = number (kd4(i)(1:3))
            k2 = number (kd4(i)(4:6))
            write (itxt,1070)  i,k1,k2,dpl4(i),pos4(i)
 1070       format (14x,i5,5x,i3,'-',i3,6x,2f12.3)
         end do
 1080    continue
      end if
c
c     bond dipole moment parameters for 3-membered rings
c
      if (kd3(1) .ne. '      ') then
         write (itxt,1090)
 1090    format (//,17x,'3-Membered Ring Bond Dipole Parameters',
     &           ///,26x,'Types',9x,'Bond Dipole',4x,'Position',/)
         do i = 1, maxnd3
            if (kd3(i) .eq. '      ')  goto 1110
            k1 = number (kd3(i)(1:3))
            k2 = number (kd3(i)(4:6))
            write (itxt,1100)  i,k1,k2,dpl3(i),pos3(i)
 1100       format (14x,i5,5x,i3,'-',i3,6x,2f12.3)
         end do
 1110    continue
      end if
c
c     atomic multipole electrostatic parameters
c
      if (kmp(1) .ne. '         ') then
         write (itxt,1120)  formfeed,forcefield
 1120    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,1130)
 1130    format (//,17x,'Atomic Multipole Parameters',
     &           ///,15x,'Type',3x,'Axis Types',6x,'Frame',
     &              9x,'Multipoles (M-D-Q)',/)
         do i = 1, maxnmp
            if (kmp(i) .eq. '         ')  goto 1150
            k1 = number (kmp(i)(1:3))
            k2 = number (kmp(i)(4:6))
            k3 = number (kmp(i)(7:9))
            write (itxt,1140)  i,k1,k2,k3,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)
 1140       format (3x,i5,7x,i3,5x,i3,2x,i3,5x,a8,1x,f10.5,
     &                 /,45x,3f10.5,/,45x,f10.5,
     &                 /,45x,2f10.5,/,45x,3f10.5)
         end do
 1150    continue
c
c     atomic multipole scaling parameters
c
         write (itxt,1160)  m2scale,m3scale,m4scale,m5scale
 1160    format (//,17x,'Atomic Multipole Scaling Factors',
     &           ///,23x,'1-2 Atoms',f17.3,/,23x,'1-3 Atoms',f17.3,
     &           /,23x,'1-4 Atoms',f17.3,/,23x,'1-5 Atoms',f17.3)
      end if
c
c     atomic dipole polarizability parameters
c
      exist = .false.
      do i = 1, maxtyp
         if (polr(i) .ne. 0.0d0)  exist = .true.
      end do
      if (exist) then
         write (itxt,1170)  formfeed,forcefield
 1170    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,1180)
 1180    format (//,17x,'Dipole Polarizability Parameters',
     &           ///,28x,'Type',9x,'Alpha',8x,'Group Atom Types',/)
         k = 0
         do i = 1, maxtyp
            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 (npg .eq. 0) then
                  write (itxt,1190)  k,i,polr(i)
 1190             format (16x,i5,7x,i3,3x,f12.3)
               else
                  write (itxt,1200)  k,i,polr(i),(pgrp(j,i),j=1,npg)
 1200             format (16x,i5,7x,i3,3x,f12.3,6x,6i5)
               end if
            end if
         end do
c
c     dipole polarizability scaling parameters
c
         write (itxt,1210)  p2scale,p3scale,p4scale,p5scale
 1210    format (//,17x,'Dipole Polarizability Scaling Factors',
     &           ///,23x,'1-2 Atoms',f15.3,/,23x,'1-3 Atoms',f16.3,
     &           /,23x,'1-4 Atoms',f16.3,/,23x,'1-5 Atoms',f16.3)
      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,1220)  formfeed,forcefield
 1220    format (a1,//,17x,'TINKER Force Field Parameters for ',a20)
         write (itxt,1230)
 1230    format (//,17x,'Conjugated Pisystem Atom Parameters',
     &           ///,21x,'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,1240)  k,i,electron(i),ionize(i),repulse(i)
 1240          format (10x,i5,7x,i3,f10.1,2x,2f12.3)
            end if
         end do
      end if
c
c     conjugated pisystem bond parameters
c
      if (kpi(1) .ne. '      ') then
         write (itxt,1250)
 1250    format (//,17x,'Conjugated Pisystem Bond Parameters',
     &           ///,20x,'Classes',8x,'d Force',4x,'d Length',/)
         do i = 1, maxnpi
            if (kpi(i) .eq. '      ')  goto 1270
            k1 = number (kpi(i)(1:3))
            k2 = number (kpi(i)(4:6))
            write (itxt,1260)  i,k1,k2,sslope(i),tslope(i)
 1260       format (10x,i5,5x,i3,'-',i3,3x,f12.3,f12.3)
         end do
 1270    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     disk file with 15 residues per line and distinct chains
c     separated by blank lines
c
c
      subroutine prtseq (iseq)
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'sequen.i'
      integer i,k,iseq
      integer smax,smin
      integer size,start,stop
      logical opened
      character*1 letter
      character*60 seqfile
c
c
c     open 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
         dowhile (smax .lt. size)
            smin = smax + 1
            smax = smax + 15
            smax = min(smax,size)
            if (i.ne.1 .and. smin.eq.1) then
               write (iseq,10)
   10          format ()
            end if
            write (iseq,20)  letter,smin,(seq(k+start-1),k=smin,smax)
   20       format (3x,a1,i6,1x,15(1x,a3))
         end do
      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 prtxyz  --  output of Cartesian coordinates  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "prtxyz" writes out a set of Cartesian coordinates
c     to an external disk file
c
c
      subroutine prtxyz (ixyz)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'files.i'
      include 'inform.i'
      include 'titles.i'
      integer i,k,ixyz
      logical opened
      character*60 coordfile
c
c
c     open output unit if not already done
c
      inquire (unit=ixyz,opened=opened)
      if (.not. opened) then
         coordfile = filename(1:leng)//'.xyz'
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,status='new')
      end if
c
c     write out the number of atoms and the title
c
      if (ltitle .eq. 0) then
         write (ixyz,10)  n
   10    format (i6)
      else
         write (ixyz,20)  n,title(1:ltitle)
   20    format (i6,2x,a)
      end if
c
c     finally, write the coordinates for each atom
c
      if (digits .le. 6) then
         do i = 1, n
            write (ixyz,30)  i,name(i),x(i),y(i),z(i),type(i),
     &                       (i12(k,i),k=1,n12(i))
   30       format (i6,2x,a3,3f12.6,9i6)
         end do
      else if (digits .le. 8) then
         do i = 1, n
            write (ixyz,40)  i,name(i),x(i),y(i),z(i),type(i),
     &                       (i12(k,i),k=1,n12(i))
   40       format (i6,2x,a3,3f14.8,9i6)
         end do
      else
         do i = 1, n
            write (ixyz,50)  i,name(i),x(i),y(i),z(i),type(i),
     &                       (i12(k,i),k=1,n12(i))
   50       format (i6,2x,a3,3f16.10,9i6)
         end do
      end if
      if (.not. opened)  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 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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'omega.i'
      include 'output.i'
      include 'refer.i'
      include 'tree.i'
      include 'warp.i'
      integer i,next,range
      integer start,stop
      real*8 minimum,grdmin
      real*8 ratio,sigmoid,rms
      logical exist,check
      logical use_forward
      logical use_cart
      logical use_tors
      character*1 answer
      character*1 formtyp
      character*80 record
      character*80 string
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
      coordtype = 'none'
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 (a80)
         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 (a80)
         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 (a80)
         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 (a80)
            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     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,130)
  130       format (/,' Restrict Local Search to Children of Input',
     &                 ' Structure [N] :  ',$)
            read (input,140)  record
  140       format (a80)
            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=150,end=150)  grdmin
  150 continue
      if (grdmin .le. 0.0d0) then
         write (iout,160)
  160    format (/,' Enter RMS Gradient per Atom Criterion',
     &              ' [0.0001] :  ',$)
         read (input,170)  grdmin
  170    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
            iprint = 1
            call localxyz (minimum,grdmin)
            call impose (n,xref,yref,zref,n,x,y,z,rms)
            call psswrite (i)
            write (iout,180)  minimum,deform
  180       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
         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. 5.0d0) 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,190)  minimum,deform
  190    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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,nvar
      real*8 pss1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(3,maxatm)
c
c
c     translate 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     compute and store the energy and gradient
c
      call gradient (e,derivs)
      pss1 = e
c
c     store atom gradients as optimization gradient, also
c     translate the coordinates of each atom; the latter
c     may be needed when using periodic boundaries
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         xx(nvar) = x(i)
         g(nvar) = derivs(1,i)
         nvar = nvar + 1
         xx(nvar) = y(i)
         g(nvar) = derivs(2,i)
         nvar = nvar + 1
         xx(nvar) = z(i)
         g(nvar) = derivs(3,i)
      end do
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,nvar
      integer hinit(maxvar)
      integer hstop(maxvar)
      integer hindex(maxhess)
      real*8 xx(maxvar)
      real*8 hdiag(maxvar)
      real*8 h(maxhess)
      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)
c
c     translate the coordinates of each atom; this
c     may be needed when using periodic boundaries
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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'omega.i'
      include 'refer.i'
      integer i,j,k
      integer start,stop
      integer niter,nsearch
      real*8 minimum,grdmin
      real*8 minref,minbest
      real*8 eps,rms,size
      real*8 step(3,maxvib)
      real*8 eigen(maxvib)
      real*8 vects(maxvib,maxvib)
      real*8 xbest(maxatm)
      real*8 ybest(maxatm)
      real*8 zbest(maxatm)
      logical done,check
c
c
c     store the current coordinates as the reference set
c
      call makeref
c
c     set parameters related to the local search procedure
c
      done = .false.
      eps = 0.0001d0
      minref = minimum
      minbest = minimum
      niter = 0
c
c     find local minimum along each of the steepest directions
c
      dowhile (.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
            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
            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
         else
            done = .true.
            minimum = minref
            call getref
         end if
      end do
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'omega.i'
      include 'refer.i'
      integer i,k,start,stop
      integer niter,nsearch
      real*8 minimum,grdmin
      real*8 minref,minbest
      real*8 eps,rms
      real*8 step(maxrot)
      real*8 eigen(maxrot)
      real*8 vects(maxrot,maxrot)
      real*8 xbest(maxatm)
      real*8 ybest(maxatm)
      real*8 zbest(maxatm)
      logical done,check
c
c
c     store the current coordinates as the reference set
c
      call makeref
c
c     set parameters related to the local search procedure
c
      done = .false.
      eps = 0.0001d0
      minref = minimum
      minbest = minimum
      niter = 0
c
c     find local minimum along each of the steepest directions
c
      dowhile (.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
         else
            done = .true.
            minimum = minref
            call getref
         end if
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eigenxyz  --  Cartesian Hessian eigenvectors  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine eigenxyz (eigen,vects)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'hescut.i'
      integer i,j,k,ihess,nfreq
      integer hinit(3,maxatm)
      integer hstop(3,maxatm)
      integer hindex(maxhess)
      real*8 h(maxhess)
      real*8 hdiag(3,maxatm)
      real*8 matrix((maxvib+1)*maxvib/2)
      real*8 eigen(maxvib)
      real*8 vects(maxvib,maxvib)
      real*8 a(maxvib+1),b(maxvib+1)
      real*8 p(maxvib+1),w(maxvib+1)
      real*8 ta(maxvib+1),tb(maxvib+1)
      real*8 ty(maxvib+1)
c
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
      nfreq = 3 * n
      call diagq (nfreq,maxvib,nfreq,matrix,eigen,vects,
     &                     a,b,p,w,ta,tb,ty)
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eigentor  --  torsional Hessian eigenvectors  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine eigentor (eigen,vects)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'omega.i'
      integer i,j,ihess
      real*8 hrot(maxrot,maxrot)
      real*8 matrix((maxrot+1)*maxrot/2)
      real*8 a(maxrot+1),b(maxrot+1)
      real*8 p(maxrot+1),ta(maxrot+1)
      real*8 w(maxrot+1),tb(maxrot+1)
      real*8 ty(maxrot+1)
      real*8 eigen(maxrot)
      real*8 vects(maxrot,maxrot)
c
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,maxrot,nomega,matrix,eigen,vects,
     &                     a,b,p,w,ta,tb,ty)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine climbxyz  --  Cartesian local search direction  ##
c     ##                                                             ##
c     #################################################################
c
c
      subroutine climbxyz (nsearch,minimum,step,grdmin,check)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'refer.i'
      include 'inform.i'
      include 'iounit.i'
      include 'warp.i'
      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,maxvib)
      real*8 estep(0:maxstep)
      logical done,check,keep
c
c
c     convert current reference coordinates to a Z-matrix
c
      call getref
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
      dowhile (.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)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'omega.i'
      include 'zcoord.i'
      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(maxrot)
      real*8 estep(0:maxstep)
      logical done,check,keep
c
c
c     convert current reference coordinates to a Z-matrix
c
      call getref
      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
      dowhile (.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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      integer i,nvar
      real*8 minimum
      real*8 grdmin
      real*8 pss1
      real*8 xx(maxvar)
      logical oldverb
      character*6 mode
      character*6 method
      external pss1,pss2
      external writeout
c
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,writeout)
      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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'tree.i'
      include 'warp.i'
      integer i
      real*8 parent,grdmin
      real*8 deform0,eps
      real*8 x0(maxatm)
      real*8 y0(maxatm)
      real*8 z0(maxatm)
      logical keep
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
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine psswrite  --  output structures on PSS path  ##
c     ##                                                          ##
c     ##############################################################
c
c
      subroutine psswrite (i)
      implicit none
      include 'files.i'
      integer i,ixyz
      integer lext,freeunit
      character*7 ext
      character*60 coordfile
c
c
c     write the coordinates of the current minimum to a file
c
      lext = 3
      call numeral (i,ext,lext)
      ixyz = freeunit ()
      coordfile = filename(1:leng)//'.'//ext(1:lext)
      call version (coordfile,'new')
      open (unit=ixyz,file=coordfile,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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'group.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'molcul.i'
      include 'output.i'
      include 'refer.i'
      include 'rigid.i'
      include 'warp.i'
      integer i,j,k,ixyz
      integer nvar,lext
      integer npoint,neigen
      integer next,freeunit
      real*8 minimum,grdmin,rms
      real*8 pssrgd1,deform0
      real*8 ratio,sigmoid
      real*8 xx(maxvar)
      logical exist
      logical use_local
      character*1 answer
      character*7 ext
      character*60 coordfile
      character*80 record
      character*80 string
      external pssrgd1
      external writeout
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     get rigid body coordinates and save the Cartesian coordinates
c
      call orient
      call makeref
c
c     set maximum deformation value and the coordinate type
c
      deform0 = deform
      coordtype = 'none'
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 (a80)
         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 termination criterion as RMS gradient per atom
c
      grdmin = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=90,end=90)  grdmin
   90 continue
      if (grdmin .le. 0.0d0) then
         write (iout,100)
  100    format (/,' Enter RMS Gradient per Rigid Body Criterion',
     &              ' [0.0001] :  ',$)
         read (input,110)  grdmin
  110    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.0001d0
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     transfer 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,writeout)
c
c     transfer 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.5.0d0 .and. k.ge.npoint)
     &         call rgdsrch (neigen,minimum,grdmin)
         end if
c
c     write out final energy function value and smoothing level
c
         write (iout,120)  minimum,deform
  120    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 ()
         coordfile = filename(1:leng)//'.'//ext(1:lext)
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,status='new')
         call prtxyz (ixyz)
         close (unit=ixyz)
      end do
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)
      implicit none
      include 'sizes.i'
      include 'group.i'
      include 'math.i'
      include 'rigid.i'
      integer i,j,nvar
      real*8 pssrgd1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(6,maxgrp)
c
c
c     translate optimization variables 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     compute and store the energy and gradient
c
      call rigidxyz
      call gradrgd (e,derivs)
      pssrgd1 = e
c
c     translate rigid body gradient to optimization gradient
c
      nvar = 0
      do i = 1, ngrp
         do j = 1, 6
            nvar = nvar + 1
            g(nvar) = derivs(j,i)
         end do
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine rgdsrch  --  local search for rigid body PSS  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine rgdsrch (neigen,minimum,grdmin)
      implicit none
      include 'sizes.i'
      include 'group.i'
      include 'iounit.i'
      include 'rigid.i'
      integer maxrgd
      parameter (maxrgd=6*maxgrp)
      integer i,j,k
      integer neigen,ndoi
      integer nvar,nsearch
      real*8 minimum,grdmin
      real*8 minref,minbest
      real*8 eps,step(maxrgd)
      real*8 rbref(6,maxgrp)
      real*8 rbbest(6,maxgrp)
      real*8 eigen(maxrgd)
      real*8 vects(maxrgd,maxrgd)
      logical done
c
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
            rbref(j,i) = rbc(j,i)
         end do
      end do
c
c     find local minimum along each of the steepest directions
c
      dowhile (.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) = rbref(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
                     rbbest(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) = rbref(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
                     rbbest(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
                  rbref(j,k) = rbbest(j,k)
               end do
            end do
         else
            done = .true.
            minimum = minref
            do k = 1, ngrp
               do j = 1, 6
                  rbc(j,k) = rbref(j,k)
               end do
            end do
         end if
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine eigenrgd  --  rigid body Hessian eigenvectors  ##
c     ##                                                            ##
c     ################################################################
c
c
      subroutine eigenrgd (eigen,vects)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'group.i'
      integer maxrgd
      parameter (maxrgd=6*maxgrp)
      integer i,j
      integer ihess,nvar
      real*8 vnorm
      real*8 hrigid(maxrgd,maxrgd)
      real*8 matrix((maxrgd+1)*maxrgd/2)
      real*8 a(maxrgd+1),b(maxrgd+1)
      real*8 p(maxrgd+1),ta(maxrgd+1)
      real*8 w(maxrgd+1),tb(maxrgd+1)
      real*8 ty(maxrgd+1)
      real*8 eigen(maxrgd)
      real*8 vects(maxrgd,maxrgd)
c
c
c     compute the Hessian for rigid body motion
c
      call hessrgd ('full',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,maxrgd,nvar,matrix,eigen,vects,
     &                     a,b,p,w,ta,tb,ty)
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
      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)
      implicit none
      include 'sizes.i'
      include 'group.i'
      include 'iounit.i'
      include 'math.i'
      include 'rigid.i'
      integer maxrgd,maxstep
      parameter (maxrgd=6*maxgrp)
      parameter (maxstep=500)
      integer i,j
      integer nvar,nsearch
      integer kstep,nstep
      real*8 minimum,grdmin
      real*8 big,energy,size
      real*8 step(maxrgd)
      real*8 estep(0:maxstep)
      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
      dowhile (.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)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'group.i'
      include 'minima.i'
      include 'rigid.i'
      integer i,j,nvar
      integer oldprt
      real*8 minimum
      real*8 grdmin
      real*8 pssrgd1
      real*8 xx(maxvar)
      logical oldverb
      external pssrgd1
      external writeout
c
c
c     transfer 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,writeout)
      verbose = oldverb
      iprint = oldprt
c
c     transfer 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
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'omega.i'
      include 'output.i'
      include 'refer.i'
      include 'warp.i'
      include 'zcoord.i'
      integer i,k
      integer ixyz,next
      integer npoint,neigen
      integer lext,freeunit
      real*8 minimum,grdmin
      real*8 pssrot1,rms
      real*8 modecut
      real*8 deform0,ratio
      real*8 xx(maxvar)
      logical exist
      logical use_local
      character*1 answer
      character*7 ext
      character*60 coordfile
      character*80 record
      character*80 string
      external pssrot1
      external writeout
c
c     set up the structure and mechanics calculation
c
      call initial
      call getint
      call mechanic
      call initrot
c
c     convert to Cartesian coordinates and save the initial set
c
      call makexyz
      call makeref
c
c     set maximum deformation value and disable coordinate dumps
c
      coordtype = 'none'
      deform0 = deform
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 (a80)
         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
c
c     get the maximal smoothing level for use of local search
c
         modecut = -1.0d0
         call nextarg (string,exist)
         if (exist)  read (string,*,err=90,end=90)  modecut
   90    continue
         if (modecut .le. 0.0d0) then
            write (iout,100)
  100       format (/,' Enter the Largest Smoothing Value for Local',
     &                 ' Search [5.0] :  ',$)
            read (input,110)  modecut
  110       format (f20.0)
            if (modecut .le. 0.0d0)  modecut = 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 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,writeout)
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.modecut)
     &         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 ()
         coordfile = filename(1:leng)//'.'//ext(1:lext)
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,status='new')
         call prtxyz (ixyz)
         close (unit=ixyz)
      end do
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)
      implicit none
      include 'sizes.i'
      include 'math.i'
      include 'omega.i'
      include 'zcoord.i'
      integer i
      real*8 pssrot1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(maxrot)
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     compute and store the energy and gradient
c
      call makexyz
      call gradrot (e,derivs)
      pssrot1 = e
c
c     store angle gradients as optimization gradient
c
      do i = 1, nomega
         g(i) = derivs(i)
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine moderot  --  torsional local search for PSS  ##
c     ##                                                          ##
c     ##############################################################
c
c
      subroutine moderot (neigen,minimum,grdmin)
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'math.i'
      include 'omega.i'
      include 'zcoord.i'
      integer i,k,neigen
      integer ndoi,nsearch
      real*8 minimum,grdmin
      real*8 minref,minbest
      real*8 eps,step(maxrot)
      real*8 zorig(maxrot)
      real*8 zbest(maxrot)
      real*8 eigen(maxrot)
      real*8 vects(maxrot,maxrot)
      logical done
c
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
      dowhile (.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
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eigenrot  --  torsional Hessian eigenvectors  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine eigenrot (eigen,vects)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'omega.i'
      integer i,j,ihess
      real*8 hrot(maxrot,maxrot)
      real*8 matrix((maxrot+1)*maxrot/2)
      real*8 a(maxrot+1),b(maxrot+1)
      real*8 p(maxrot+1),ta(maxrot+1)
      real*8 w(maxrot+1),tb(maxrot+1)
      real*8 ty(maxrot+1)
      real*8 eigen(maxrot)
      real*8 vects(maxrot,maxrot)
c
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,maxrot,nomega,matrix,eigen,vects,
     &                     a,b,p,w,ta,tb,ty)
      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)
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'math.i'
      include 'omega.i'
      include 'zcoord.i'
      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 step(maxrot)
      real*8 estep(0:maxstep)
      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
      dowhile (.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)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'minima.i'
      include 'math.i'
      include 'omega.i'
      include 'zcoord.i'
      integer i,oldprt
      real*8 minimum
      real*8 grdmin
      real*8 pssrot1
      real*8 xx(maxvar)
      logical oldverb
      external pssrot1
      external writeout
c
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,writeout)
      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
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine quatfit  --  quaternion superposition of coords  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "quatfit" uses a quaternion-based method to achieve the best
c     fit superposition of two sets of coordinates
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 David J. Heisterberg,
c     Ohio Supercomputer Center, Columbus, OH
c
c
      subroutine quatfit (n1,x1,y1,z1,n2,x2,y2,z2)
      implicit none
      include 'sizes.i'
      include 'align.i'
      integer i,i1,i2,n1,n2
      real*8 weight,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 work1(4),work2(4)
      real*8 rot(3,3)
      real*8 c(4,4),v(4,4)
      real*8 x1(maxatm),x2(maxatm)
      real*8 y1(maxatm),y2(maxatm)
      real*8 z1(maxatm),z2(maxatm)
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)
         weight = wfit(i)
         xxyx = xxyx + weight*x1(i1)*x2(i2)
         xxyy = xxyy + weight*y1(i1)*x2(i2)
         xxyz = xxyz + weight*z1(i1)*x2(i2)
         xyyx = xyyx + weight*x1(i1)*y2(i2)
         xyyy = xyyy + weight*y1(i1)*y2(i2)
         xyyz = xyyz + weight*z1(i1)*y2(i2)
         xzyx = xzyx + weight*x1(i1)*z2(i2)
         xzyy = xzyy + weight*y1(i1)*z2(i2)
         xzyz = xzyz + weight*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,4,c,d,v,work1,work2)
c
c     extract the desired quaternion
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 stored coordinate
c     frames from a liquid simulation
c
c
      program radial
      implicit none
      include 'sizes.i'
      include 'argue.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'cutoff.i'
      include 'files.i'
      include 'iounit.i'
      include 'math.i'
      include 'molcul.i'
      include 'potent.i'
      integer maxbin
      parameter (maxbin=10000)
      integer i,j,k,nframe
      integer ixyz,irdf
      integer freeunit
      integer trimtext
      integer molj,molk
      integer numj,numk
      integer lengj,lengk
      integer lext,next
      integer start,stop,step
      integer nbin,bin
      integer hist(maxbin)
      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 gr(maxbin)
      real*8 gs(maxbin)
      logical exist
      character*3 namej
      character*3 namek
      character*7 ext
      character*60 coordfile
      character*60 rdffile
      character*80 record
c
c
c     get the structure, unitcell parameters and molecules
c
      call initial
      call getxyz
      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 the numbers of the cycle files to be processed
c
      start = 0
      stop = 0
      step = 0
      write (iout,10)
   10 format (/,' Numbers of First & Last File and Step',
     &              ' Increment :  ',$)
      read (input,20)  record
   20 format (a80)
      read (record,*,err=30,end=30)  start,stop,step
   30 continue
      if (stop .eq. 0)  stop = start
      if (step .eq. 0)  step = 1
c
c     get the names of the atoms to be used in rdf computation
c
      write (iout,40)
   40 format (/,' Enter Names of First & Second Atoms :  ',$)
      read (input,50)  record
   50 format (a80)
      next = 1
      call getword (record,namej,next)
      call getword (record,namek,next)
c
c     get the desired width of the radial distance bins
c
      width = 0.0d0
      write (iout,60)
   60 format (/,' Enter Width of Distance Bins [0.05 Ang] :  ',$)
      read (input,70)  width
   70 format (f10.0)
      if (width .eq. 0.0d0)  width = 0.05d0
c
c     find largest bin based on minimum image convention
c
      if (octahedron) then
         rmax = (sqrt(3.0d0)/4.0d0) * xbox
      else
         rmax = min(xbox2*beta_sin*gamma_sin,ybox2*gamma_sin,
     &                         zbox2*beta_sin)
      end if
      nbin = int(rmax/width)
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     cycle over coordinate files to generate distance bins
c
      i = start
      nframe = 0
      dowhile (i.ge.start .and. i.le.stop)
         ixyz = freeunit ()
         lext = 3
         call numeral (i,ext,lext)
         coordfile = filename(1:leng)//'.'//ext(1:lext)
         call version (coordfile,'old')
         inquire (file=coordfile,exist=exist)
         if (exist) then
            nframe = nframe + 1
            open (unit=ixyz,file=coordfile,status='old')
            rewind (unit=ixyz)
            call readxyz (ixyz)
            close (unit=ixyz)
            do j = 1, n
               if (name(j) .eq. namej) then
                  xj = x(j)
                  yj = y(j)
                  zj = z(j)
                  molj = molcule(j)
                  do k = 1, n
                     if (name(k) .eq. namek) then
                        molk = molcule(k)
                        if (molj .ne. molk) then
                           dx = x(k) - xj
                           dy = y(k) - yj
                           dz = z(k) - zj
                           call image (dx,dy,dz,0)
                           rjk = sqrt(dx*dx + dy*dy + dz*dz)
                           bin = int(rjk/width) + 1
                           hist(bin) = hist(bin) + 1
                        end if
                     end if
                  end do
               end if
            end do
         end if
         i = i + step
      end do
      write (iout,80)  nframe
   80 format (/,' Number of Coordinate Frames Used :',i8)
c
c     count the number of occurences of each atom type
c
      numj = 0
      numk = 0
      do i = 1, n
         if (name(i) .eq. namej)  numj = numj + 1
         if (name(i) .eq. namek)  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
         pairs = dble(numj) * dble(numk) * dble(nframe)
         volume = xbox * ybox * zbox
         factor = (4.0d0/3.0d0) * pi * pairs / volume
         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     write the radial distribution function to a file
c
      irdf = freeunit ()
      lengj = trimtext (namej)
      lengk = trimtext (namek)
      rdffile = namej(1:lengj)//'_'//namek(1:lengk)//'.rdf'
      call version (rdffile,'new')
      open (unit=irdf,file=rdffile,status='new')
      do i = 1, nbin
         write (irdf,90)  i,hist(i),(dble(i)-0.5d0)*width,gr(i),gs(i)
   90    format (i8,i15,3x,f12.4,3x,2f12.4)
      end do
      close (unit=irdf)
      write (iout,100)  rdffile(1:trimtext(rdffile))
  100 format (/,' Radial Distribution Function Output to:  ',a)
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 ()
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      integer im1,ia1,iq1,ir1
      integer im2,ia2,iq2,ir2
      integer big,ntable
      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 (ntable=32)
      parameter (imm1=im1-1)
      parameter (ndiv=1+imm1/ntable)
      parameter (factor=1.0d0/im1)
      integer i,k,next
      integer seed,seed2
      integer year,month,day
      integer hour,minute,second
      integer iy,itable(ntable)
      real*8 random
      logical initial
      character*20 keyword
      character*80 record
      character*80 string
      save initial
      save seed,seed2
      save iy,itable
      data initial  / .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 (initial) then
         initial = .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:80)
               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  --  Initialized with SEED of',i12)
         end if
c
c     warm up and then load the shuffling table
c
         seed2 = seed
         do i = ntable+8, 1, -1
            k = seed / iq1
            seed = ia1 * (seed-k*iq1) - k*ir1
            if (seed .lt. 0)  seed = seed + im1
            if (i .le. ntable)  itable(i) = seed
         end do
         iy = itable(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 = itable(i) - seed2
      itable(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  --  The 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 ()
      implicit none
      include 'inform.i'
      include 'iounit.i'
      real*8 random,v1,v2,rsq
      real*8 factor,store,normal
      logical compute
      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  --  The Random Number Value 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     Cambridge University Press, 1995, Appendix A4
c
c
      subroutine ranvec (vector)
      implicit none
      include 'inform.i'
      include 'iounit.i'
      real*8 x,y,s
      real*8 random
      real*8 vector(3)
c
c
c     get a pair of appropriate components in the plane
c
      s = 2.0d0
      dowhile (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  --  The Random Vector is',3f10.4)
c     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 rattle  --  apply rattle position constraints  ##
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 constrained interatomic distances
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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'moldyn.i'
      include 'shake.i'
      include 'usage.i'
      integer i,ia,ib
      integer niter,maxiter
      real*8 dt,xr,yr,zr
      real*8 xo,yo,zo
      real*8 eps,dist2,delta
      real*8 dot,term,rma,rmb
      real*8 xterm,yterm,zterm
      real*8 xold(maxatm)
      real*8 yold(maxatm)
      real*8 zold(maxatm)
      logical done
      logical moved(maxatm)
      logical update(maxatm)
c
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 = 100
      niter = 0
      done = .false.
      eps = 0.000001d0
c
c     apply the rattle algorithm to correct the atom
c     positions and the half-step velocity values
c
      dowhile (.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 (ratimage(i))  call image (xr,yr,zr,0)
               dist2 = xr**2 + yr**2 + zr**2
               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 (ratimage(i))  call image (xo,yo,zo,0)
                  dot = xr*xo + yr*yo + zr*zo
                  rma = 1.0d0 / mass(ia)
                  rmb = 1.0d0 / mass(ib)
                  term = delta / (2.0d0 * (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     write information on the number of iterations needed
c
      if (niter .eq. maxiter) then
         write (iout,10)
   10    format (/,' RATTLE  --  Warning, Position Constraints',
     &              ' not Satisfied')
         call prterr
         call fatal
      else if (debug) then
         write (iout,20)  niter
   20    format (' RATTLE   --  Position Constraints met at',i6,
     &              ' Iterations')
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine rattle2  --  apply rattle velocity constraints  ##
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     constrained interatomic distances
c
c
      subroutine rattle2 (dt)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'moldyn.i'
      include 'shake.i'
      include 'units.i'
      include 'usage.i'
      include 'virial.i'
      integer i,ia,ib
      integer niter,maxiter
      real*8 xr,yr,zr
      real*8 xv,yv,zv
      real*8 dt,eps,rma,rmb
      real*8 dot,vterm,term
      real*8 xterm,yterm,zterm
      logical done
      logical moved(maxatm)
      logical update(maxatm)
c
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 = 100
      niter = 0
      done = .false.
      eps = 0.000001d0 / dt
      vterm = 2.0d0 / (dt * convert)
c
c     apply the rattle algorithm to correct the velocities
c
      dowhile (.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 (ratimage(i))  call image (xr,yr,zr,0)
               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.
                  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 diagonal components
c
                  virx = virx - xr*xterm*vterm
                  viry = viry - yr*yterm*vterm
                  virz = virz - zr*zterm*vterm
               end if
            end if
         end do
         do i = 1, n
            moved(i) = update(i)
            update(i) = .false.
         end do
      end do
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
      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 disk file
c
c
      subroutine readdyn (idyn)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'files.i'
      include 'group.i'
      include 'iounit.i'
      include 'mdstuf.i'
      include 'moldyn.i'
      include 'rgddyn.i'
      integer i,idyn,ndyn
      logical exist,opened,quit
      character*60 dynfile
      character*80 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 (a80)
      read (record,*,err=230,end=230)  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 (a80)
      read (record,*,err=230,end=230)  xbox,ybox,zbox
      read (idyn,70)  record
   70 format (a80)
      read (record,*,err=230,end=230)  alpha,beta,gamma
      read (idyn,80)
   80 format ()
c
c     get rigid-body positions, translational and angular velocities
c
      quit = .true.
      if (integrate .eq. 'RIGIDBODY') then
         do i = 1, n
            read (idyn,90)  record
   90       format (a80)
            read (record,*,err=230,end=230)  x(i),y(i),z(i)
         end do
         read (idyn,100)
  100    format ()
         do i = 1, ngrp
            read (idyn,110)  record
  110       format (a80)
            read (record,*,err=230,end=230)  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 (a80)
            read (record,*,err=230,end=230)  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 (a80)
            read (record,*,err=230,end=230)  lm(1,i),lm(2,i),lm(3,i)
         end do
c
c     get the atomic positions, velocities and accelerations
c
      else
         do i = 1, n
            read (idyn,160)  record
  160       format (a80)
            read (record,*,err=230,end=230)  x(i),y(i),z(i)
         end do
         read (idyn,170)
  170    format ()
         do i = 1, n
            read (idyn,180)  record
  180       format (a80)
            read (record,*,err=230,end=230)  v(1,i),v(2,i),v(3,i)
         end do
         read (idyn,190)
  190    format ()
         do i = 1, n
            read (idyn,200)  record
  200       format (a80)
            read (record,*,err=230,end=230)  a(1,i),a(2,i),a(3,i)
         end do
         read (idyn,210)
  210    format ()
         do i = 1, n
            read (idyn,220)  record
  220       format (a80)
            read (record,*,err=230,end=230)  aold(1,i),aold(2,i),
     &                                       aold(3,i)
         end do
      end if
      quit = .false.
  230 continue
      if (.not. opened)  close (unit=idyn)
c
c     report any error in reading the dynamics restart file
c
      if (quit) then
         write (iout,240)  i
  240    format (/,' READDYN  --  Error in Dynamics Restart',
     &              ' File at Atom',i6)
         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 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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'titles.i'
      include 'zclose.i'
      include 'zcoord.i'
      integer i,j,izmt
      integer next,size
      integer first,last
      integer nexttext
      integer trimtext
      logical exist,opened
      logical quit
      character*60 intfile
      character*120 record
      character*120 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
      dowhile (size .eq. 0)
         read (izmt,20,err=60,end=60)  record
   20    format (a120)
         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=60,end=60)  n
c
c     extract the title and determine its length
c
      string = record(next:120)
      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 .gt. maxatm) then
         write (iout,30)  maxatm
   30    format (' READINT  --  The Maximum of',i6,' Atoms',
     &           ' has been Exceeded')
         call fatal
      end if
c
c     read the coordinates and connectivities for each atom
c
      do i = 1, n
         next = 1
         size = 0
         dowhile (size .eq. 0)
            read (izmt,40,err=60,end=60)  record
   40       format (a120)
            size = trimtext (record)
         end do
         read (record,*,err=60,end=60)  tag(i)
         call getword (record,name(i),next)
         string = record(next:120)
         read (string,*,err=60,end=50)  type(i),iz(1,i),zbond(i),
     &                                  iz(2,i),zang(i),iz(3,i),
     &                                  ztors(i),iz(4,i)
   50    continue
      end do
      quit = .false.
   60 continue
      if (.not. opened)  close (unit=izmt)
c
c     an error occurred in reading the Z-matrix coordinates
c
      if (quit) then
         write (iout,70)  i
   70    format (' READZ  --  Error in Z-Matrix File at Atom',i6)
         call fatal
      end if
c
c     read in any additional bonds to be added or deleted
c
      nadd = 0
      ndel = 0
      read (izmt,80,err=120,end=120)
   80 format ()
      do i = 1, maxatm
         read (izmt,90,err=120,end=120)  record
   90    format (a120)
         read (record,*,err=100,end=100)  (iadd(j,i),j=1,2)
         nadd = i
      end do
  100 continue
      do i = 1, maxatm
         read (izmt,110,err=120,end=120)  record
  110    format (a120)
         read (record,*,err=120,end=120)  (idel(j,i),j=1,2)
         ndel = i
      end do
  120 continue
      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 Sybyl MOL2 file  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "readmol2" gets a set of Sybyl MOL2 coordinates from
c     an external disk file
c
c
      subroutine readmol2 (isyb)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'files.i'
      include 'iounit.i'
      include 'titles.i'
      integer i,j,k,m,ia,ib,isyb
      integer nbond,number
      integer next,trimtext
      logical exist,opened
      character*10 atmnam
      character*60 sybylfile
      character*80 record
      character*80 string
c
c
c     open the input file if it has not already been done
c
      inquire (unit=isyb,opened=opened)
      if (.not. opened) then
         sybylfile = filename(1:leng)//'.mol2'
         call version (sybylfile,'old')
         inquire (file=sybylfile,exist=exist)
         if (exist) then
            open (unit=isyb,file=sybylfile,status='old')
            rewind (unit=isyb)
         else
            write (iout,10)
   10       format (/,' READMOL2  --  Unable to Find the TRIPOS',
     &                 ' Sybyl MOL2 File')
            call fatal
         end if
      end if
c
c     get title line and get the number of atoms and bonds
c
      do i = 1, 1000000
         read (isyb,20)  record
   20    format (a80)
         next = 1
         call gettext (record,string,next)
         call upcase (string)
         if (string .eq. '@<TRIPOS>MOLECULE') then
            read (isyb,30)  title
   30       format (a60)
            ltitle = trimtext (title)
            read (isyb,40)  record
   40       format (a80)
            read (record,*)  n,nbond
            goto 50
         end if
      end do
   50 continue
c
c     check for too many total atoms in the file
c
      if (n .gt. maxatm) then
         write (iout,60)  maxatm
   60    format (/,' READMOL2  --  The Maximum of',i6,' Atoms',
     &              ' has been Exceeded')
         call fatal
      end if
c
c     read the atom names and coordinates
c
      do i = 1, 1000000
         read (isyb,70)  record
   70    format (a80)
         next = 1
         call gettext (record,string,next)
         call upcase (string)
         if (string .eq. '@<TRIPOS>ATOM') then
            do j = 1, n
               read (isyb,80)  record
   80          format (a80)
               read (record,*)  number
               next = 1
               call getword (record,atmnam,next)
               read (record(next:80),*)  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
               type(j) = 0
            end do
            goto 90
         end if
      end do
   90 continue
c
c     read the bond list to get attached atom lists
c
      do i = 1, 1000000
         read (isyb,100)  record
  100    format (a80)
         next = 1
         call gettext (record,string,next)
         call upcase (string)
         if (string .eq. '@<TRIPOS>BOND') then
            do j = 1, nbond
               read (isyb,110)  record
  110          format (a80)
               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 120
         end if
      end do
  120 continue
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=isyb)
      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 Protein Data Bank coordinates
c     from an external disk file
c
c
      subroutine readpdb (ipdb)
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'iounit.i'
      include 'pdb.i'
      include 'sequen.i'
      include 'titles.i'
      integer i,ipdb
      integer next,nres
      integer nalt,nins
      integer index,trimtext
      integer length,serial
      integer residue,reslast
      real*8 xx,yy,zz
      logical exist,opened
      logical model
      character*1 altloc,chain
      character*1 chnsym,altsym
      character*1 altlast,chnlast
      character*1 insert,inslast
      character*1 letter,chnatm(maxatm)
      character*3 resname,namelast
      character*4 atmname
      character*6 remark
      character*20 blank,text
      character*20 alttyp
      character*20 chntyp,chntemp
      character*20 instyp,instemp
      character*60 pdbfile
      character*80 record,string
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     initialize the residue counter and residue name
c
      nres = 0
      reslast = maxres
      namelast = '   '
      blank = '                    '
c
c     initialize alternate site, chain and insertion lists
c
      nalt = 0
      nchain = 0
      nins = 0
      altlast = '#'
      chnlast = '#'
      inslast = '#'
      alttyp = blank
      chntyp = '####################'
      instyp = blank
c
c     extract header information from the PDB file
c
      dowhile (.true.)
         read (ipdb,20,err=30,end=30) record
   20    format (a80)
         call upcase (record(1:6))
         remark = record(1:6)
         if (remark .eq. 'HEADER') then
            title = record(11:70)
            ltitle = trimtext (title)
            goto 30
         end if
      end do
   30 continue
c
c     scan for alternate locations, multiple chains and inserts
c
      rewind (unit=ipdb)
      dowhile (.true.)
         read (ipdb,40,err=60,end=60)  record
   40    format (a80)
         call upcase (record)
         remark = record(1:6)
         string = record(7:80)
         if (remark.eq.'ATOM  ' .or. remark.eq.'HETATM') then
            read (string,50)  altloc,chain,insert
   50       format (10x,a1,4x,a1,4x,a1)
            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 (chain .ne. chnlast) then
               if (index(chntyp,chain) .eq. 0) then
                  nchain = nchain + 1
                  chntyp(nchain:nchain) = chain
                  chnlast = chain
               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
   60 continue
c
c     find out which of the alternate locations will be used
c
      altsym = ' '
      if (nalt .gt. 0) 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,70)  string(1:length)
   70    format (/,' Enter a Set of Alternate Atom Locations',
     &              ' from (',a,') :  ',$)
         read (input,80)  record
   80    format (a80)
         next = 1
         call gettext (record,altsym,next)
         if (altsym .eq. ' ')  altsym = alttyp(1:1)
         call upcase (altsym)
      end if
c
c     find out which of the multiple chains will be used
c
      if (nchain .gt. 1) then
         chntemp = blank
         if (chntyp(1:1) .eq. ' ') then
            string = 'BLANK'
            length = 5
         else
            string(1:1) = chntyp(1:1)
            length = 1
         end if
         do i = 2, nchain
            if (chntyp(i:i) .eq. ' ') then
               string = string(1:length)//' BLANK'
               length = length + 6
            else
               string = string(1:length)//' '//chntyp(i:i)
               length = length + 2
            end if
         end do
         string = string(1:length)//' [ALL]'
         length = length + 6
         write (iout,90)  string(1:length)
   90    format (/,' Enter the Chain Names to Include',
     &              ' (',a,') :  ',$)
         read (input,100)  chntemp
  100    format (a20)
         call upcase (chntemp)
         next = 1
         call gettext (chntemp,text,next)
         if (text.eq.blank .or. text.eq.'ALL ') then
            chntyp = chntyp(1:nchain)
         else
            nchain = 1
            chntyp = chntemp(1:1)
         end if
      end if
c
c     find out which of the insert records will be used
c
      if (nins .gt. 0) 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)
         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     process individual atoms from the Protein Data Bank file
c
      do i = 1, nchain
         rewind (unit=ipdb)
         model = .false.
         chnsym = chntyp(i:i)
         dowhile (.true.)
            read (ipdb,130,err=210,end=210)  record
  130       format (a80)
            call upcase (record)
            remark = record(1:6)
            if (remark .eq. 'ATOM  ') then
               string = record(7:80)
               read (string,140)  serial,atmname,altloc,resname,
     &                            chain,residue,insert,xx,yy,zz
  140          format (i5,1x,a4,a1,a3,1x,a1,i4,a1,3x,3f8.3)
               if (chain .ne. chnsym)  goto 160
               if (altloc.ne.' ' .and. altloc.ne.altsym)  goto 160
               if (insert.ne.' ' .and. index(instyp,insert).eq.0)
     &            goto 160
               call fixpdb (resname,atmname)
               if (residue.ne.reslast .or. resname.ne.namelast
     &                     .or. insert.ne.inslast) then
                  nres = nres + 1
                  reslast = residue
                  namelast = resname
                  inslast = insert
                  if (nres .gt. maxres) then
                     write (iout,150)  maxres
  150                format (/,' READPDB  --  The Maximum of',i6,
     &                          ' Residues has been Exceeded')
                     call fatal
                  end if
               end if
               npdb = npdb + 1
               xpdb(npdb) = xx
               ypdb(npdb) = yy
               zpdb(npdb) = zz
               pdbtyp(npdb) = remark
               atmnam(npdb) = atmname
               resnam(npdb) = resname
               resnum(npdb) = nres
               chnatm(npdb) = chain
  160          continue
            else if (remark .eq. 'HETATM') then
               string = record(7:80)
               read (string,170)  serial,atmname,altloc,resname,
     &                            chain,residue,insert,xx,yy,zz
  170          format (i5,1x,a4,a1,a3,1x,a1,i4,a1,3x,3f8.3)
               if (chain .ne. chnsym)  goto 180
               if (altloc.ne.' ' .and. altloc.ne.altsym)  goto 180
               if (insert.ne.' ' .and. index(instyp,insert).eq.0)
     &            goto 180
               call fixpdb (resname,atmname)
               npdb = npdb + 1
               xpdb(npdb) = xx
               ypdb(npdb) = yy
               zpdb(npdb) = zz
               pdbtyp(npdb) = remark
               atmnam(npdb) = atmname
               resnam(npdb) = resname
               resnum(npdb) = 0
               chnatm(npdb) = chain
  180          continue
            else if (remark .eq. 'MODEL ') then
               if (model) then
                  write (iout,190)
  190             format (/,' READPDB  --  File contains Multiple',
     &                       ' Models; First one Used')
                  goto 210
               else
                  model = .true.
               end if
            end if
            if (npdb .gt. maxatm) then
               write (iout,200)  maxatm
  200          format (/,' READPDB  --  The Maximum of',i6,
     &                    ' Atoms has been Exceeded')
               call fatal
            end if
         end do
  210    continue
      end do
c
c     set the total sequence length and chain termini information
c
      nseq = npdb
      nchain = 0
      chnlast = '#'
      do i = 1, npdb
         if (pdbtyp(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
      if (.not. opened)  close (unit=ipdb)
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine fixpdb  --  standardize atom and residue names  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "fixpdb" corrects problems with PDB files by converting residue
c     and atom names to the forms used by TINKER
c
c
      subroutine fixpdb (resname,atmname)
      implicit none
      character*3 resname
      character*4 atmname
c
c
c     convert 1-letter base names to 3-letter base names
c
      if (resname .eq. '  A')  resname = 'ADE'
      if (resname .eq. '  G')  resname = 'GUA'
      if (resname .eq. '  C')  resname = 'CYT'
      if (resname .eq. '  U')  resname = 'URA'
      if (resname .eq. '  T')  resname = 'THY'
c
c     convert any unusual histidine residue names
c
      if (resname .eq. 'HSD')  resname = 'HID'
      if (resname .eq. 'HSE')  resname = 'HIE'
      if (resname .eq. 'HSP')  resname = 'HIS'
      if (resname .eq. 'HIP')  resname = 'HIS'
c
c     convert any generically used unusual atom names
c
      if (atmname .eq. ' HN ')  atmname = ' H  '
c
c     convert any unusual atom names in terminal residues
c
      if (atmname .eq. ' HN1')  atmname = '1H  '
      if (atmname .eq. ' HN2')  atmname = '2H  '
      if (atmname .eq. ' HN3')  atmname = '3H  '
      if (atmname .eq. ' HT1')  atmname = '1H  '
      if (atmname .eq. ' HT2')  atmname = '2H  '
      if (atmname .eq. ' HT3')  atmname = '3H  '
      if (atmname .eq. ' OT1')  atmname = ' O  '
      if (atmname .eq. 'OCT1')  atmname = ' O  '
      if (atmname .eq. ' OT ')  atmname = ' OXT'
      if (atmname .eq. ' OT2')  atmname = ' OXT'
      if (atmname .eq. 'OCT2')  atmname = ' OXT'
c
c     glycine residue  (GLY)
c
      if (resname .eq. 'GLY') then
         if (atmname .eq. ' HA1')  atmname = '1HA '
         if (atmname .eq. ' HA2')  atmname = '2HA '
c
c     alanine residue  (ALA)
c
      else if (resname .eq. 'ALA') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HB3')  atmname = '3HB '
c
c     valine residue  (VAL)
c
      else if (resname .eq. 'VAL') then
         if (atmname .eq. 'HG11')  atmname = '1HG1'
         if (atmname .eq. 'HG12')  atmname = '2HG1'
         if (atmname .eq. 'HG13')  atmname = '3HG1'
         if (atmname .eq. 'HG21')  atmname = '1HG2'
         if (atmname .eq. 'HG22')  atmname = '2HG2'
         if (atmname .eq. 'HG23')  atmname = '3HG2'
c
c     leucine residue  (LEU)
c
      else if (resname .eq. 'LEU') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. 'HD11')  atmname = '1HD1'
         if (atmname .eq. 'HD12')  atmname = '2HD1'
         if (atmname .eq. 'HD13')  atmname = '3HD1'
         if (atmname .eq. 'HD21')  atmname = '1HD2'
         if (atmname .eq. 'HD22')  atmname = '2HD2'
         if (atmname .eq. 'HD23')  atmname = '3HD2'
c
c     isoleucine residue  (ILE)
c
      else if (resname .eq. 'ILE') then
         if (atmname .eq. ' CD ')  atmname = ' CD1'
         if (atmname .eq. 'HG11')  atmname = '1HG1'
         if (atmname .eq. 'HG12')  atmname = '2HG1'
         if (atmname .eq. 'HG21')  atmname = '1HG2'
         if (atmname .eq. 'HG22')  atmname = '2HG2'
         if (atmname .eq. 'HG23')  atmname = '3HG2'
         if (atmname .eq. 'HD11')  atmname = '1HD1'
         if (atmname .eq. ' HD1')  atmname = '1HD1'
         if (atmname .eq. 'HD12')  atmname = '2HD1'
         if (atmname .eq. ' HD2')  atmname = '2HD1'
         if (atmname .eq. 'HD13')  atmname = '3HD1'
         if (atmname .eq. ' HD3')  atmname = '3HD1'
c
c     serine residue  (SER)
c
      else if (resname .eq. 'SER') then
         if (atmname .eq. ' OG1')  atmname = ' OG '
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         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. 'HG21')  atmname = '1HG2'
         if (atmname .eq. 'HG22')  atmname = '2HG2'
         if (atmname .eq. 'HG23')  atmname = '3HG2'
c
c     cysteine residue  (CYS)
c
      else if (resname .eq. 'CYS') then
         if (atmname .eq. ' SG1')  atmname = ' SG '
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         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. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HG1')  atmname = '1HG '
         if (atmname .eq. ' HG2')  atmname = '2HG '
         if (atmname .eq. ' HD1')  atmname = '1HD '
         if (atmname .eq. ' HD2')  atmname = '2HD '
c
c     phenylalanine residue  (PHE)
c
      else if (resname .eq. 'PHE') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
c
c     tyrosine residue  (TYR)
c
      else if (resname .eq. 'TYR') then
         if (atmname .eq. ' HOH')  atmname = ' HH '
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
c
c     tryptophan residue  (TRP)
c
      else if (resname .eq. 'TRP') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HNE')  atmname = ' HE1'
c
c     histidine (HD and HE) residue  (HIS)
c
      else if (resname .eq. 'HIS') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HD ')  atmname = ' HD2'
         if (atmname .eq. ' HE ')  atmname = ' HE1'
         if (atmname .eq. ' HND')  atmname = ' HD1'
         if (atmname .eq. ' HNE')  atmname = ' HE2'
c
c     histidine (HD only) residue  (HID)
c
      else if (resname .eq. 'HID') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HD ')  atmname = ' HD2'
         if (atmname .eq. ' HE ')  atmname = ' HE1'
         if (atmname .eq. ' HND')  atmname = ' HD1'
c
c     histidine (HE only) residue  (HIE)
c
      else if (resname .eq. 'HIE') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HD ')  atmname = ' HD2'
         if (atmname .eq. ' HE ')  atmname = ' HE1'
         if (atmname .eq. ' HNE')  atmname = ' HE2'
c
c     aspartic acid residue  (ASP)
c
      else if (resname .eq. 'ASP') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
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. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. 'HD21')  atmname = '1HD2'
         if (atmname .eq. 'HND1')  atmname = '1HD2'
         if (atmname .eq. 'HD22')  atmname = '2HD2'
         if (atmname .eq. 'HND2')  atmname = '2HD2'
c
c     glutamic acid residue  (GLU)
c
      else if (resname .eq. 'GLU') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HG1')  atmname = '1HG '
         if (atmname .eq. ' HG2')  atmname = '2HG '
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. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HG1')  atmname = '1HG '
         if (atmname .eq. ' HG2')  atmname = '2HG '
         if (atmname .eq. 'HE21')  atmname = '1HE2'
         if (atmname .eq. 'HNE1')  atmname = '1HE2'
         if (atmname .eq. 'HE22')  atmname = '2HE2'
         if (atmname .eq. 'HNE2')  atmname = '2HE2'
c
c     methionine residue  (MET)
c
      else if (resname .eq. 'MET') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HG1')  atmname = '1HG '
         if (atmname .eq. ' HG2')  atmname = '2HG '
         if (atmname .eq. ' HE1')  atmname = '1HE '
         if (atmname .eq. ' HE2')  atmname = '2HE '
         if (atmname .eq. ' HE3')  atmname = '3HE '
c
c     lysine residue  (LYS)
c
      else if (resname .eq. 'LYS') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HG1')  atmname = '1HG '
         if (atmname .eq. ' HG2')  atmname = '2HG '
         if (atmname .eq. ' HD1')  atmname = '1HD '
         if (atmname .eq. ' HD2')  atmname = '2HD '
         if (atmname .eq. ' HE1')  atmname = '1HE '
         if (atmname .eq. ' HE2')  atmname = '2HE '
         if (atmname .eq. ' HZ1')  atmname = '1HZ '
         if (atmname .eq. 'HNZ1')  atmname = '1HZ '
         if (atmname .eq. ' HZ2')  atmname = '2HZ '
         if (atmname .eq. 'HNZ2')  atmname = '2HZ '
         if (atmname .eq. ' HZ3')  atmname = '3HZ '
         if (atmname .eq. 'HNZ3')  atmname = '3HZ '
c
c     arginine residue  (ARG)
c
      else if (resname .eq. 'ARG') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HG1')  atmname = '1HG '
         if (atmname .eq. ' HG2')  atmname = '2HG '
         if (atmname .eq. ' HD1')  atmname = '1HD '
         if (atmname .eq. ' HD2')  atmname = '2HD '
         if (atmname .eq. 'HH11')  atmname = '1HH1'
         if (atmname .eq. 'HN11')  atmname = '1HH1'
         if (atmname .eq. 'HH12')  atmname = '2HH1'
         if (atmname .eq. 'HN12')  atmname = '2HH1'
         if (atmname .eq. 'HH21')  atmname = '1HH2'
         if (atmname .eq. 'HN21')  atmname = '1HH2'
         if (atmname .eq. 'HH22')  atmname = '2HH2'
         if (atmname .eq. 'HN22')  atmname = '2HH2'
c
c     ornithine residue  (ORN)
c
      else if (resname .eq. 'ORN') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HG1')  atmname = '1HG '
         if (atmname .eq. ' HG2')  atmname = '2HG '
         if (atmname .eq. ' HD1')  atmname = '1HD '
         if (atmname .eq. ' HD2')  atmname = '2HD '
         if (atmname .eq. ' HE1')  atmname = '1HE '
         if (atmname .eq. 'HNE1')  atmname = '1HE '
         if (atmname .eq. ' HE2')  atmname = '2HE '
         if (atmname .eq. 'HNE2')  atmname = '2HE '
         if (atmname .eq. ' HE3')  atmname = '3HE '
         if (atmname .eq. 'HNE3')  atmname = '3HE '
c
c     methylalanine residue  (AIB)
c
      else if (resname .eq. 'AIB') then
         if (atmname .eq. 'HB11')  atmname = '1HB1'
         if (atmname .eq. 'HB12')  atmname = '2HB1'
         if (atmname .eq. 'HB13')  atmname = '3HB1'
         if (atmname .eq. 'HB21')  atmname = '1HB2'
         if (atmname .eq. 'HB22')  atmname = '2HB2'
         if (atmname .eq. 'HB23')  atmname = '3HB2'
c
c     pyroglutamic acid residue  (PCA)
c
      else if (resname .eq. 'PCA') then
         if (atmname .eq. ' HB1')  atmname = '1HB '
         if (atmname .eq. ' HB2')  atmname = '2HB '
         if (atmname .eq. ' HG1')  atmname = '1HG '
         if (atmname .eq. ' HG2')  atmname = '2HG '
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. ' H1 ')  atmname = '1H  '
         if (atmname .eq. ' H2 ')  atmname = '2H  '
         if (atmname .eq. ' H3 ')  atmname = '3H  '
         if (atmname .eq. ' HY1')  atmname = '1H  '
         if (atmname .eq. ' HY2')  atmname = '2H  '
         if (atmname .eq. ' HY3')  atmname = '3H  '
         if (atmname .eq. '1HH3')  atmname = '1H  '
         if (atmname .eq. '2HH3')  atmname = '2H  '
         if (atmname .eq. '3HH3')  atmname = '3H  '
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 = ' CH3'
         if (atmname .eq. ' CAT')  atmname = ' CH3'
         if (atmname .eq. ' CA ')  atmname = ' CH3'
         if (atmname .eq. ' HNT')  atmname = ' H  '
         if (atmname .eq. ' H1 ')  atmname = '1H  '
         if (atmname .eq. ' H2 ')  atmname = '2H  '
         if (atmname .eq. ' H3 ')  atmname = '3H  '
         if (atmname .eq. ' HT1')  atmname = '1H  '
         if (atmname .eq. ' HT2')  atmname = '2H  '
         if (atmname .eq. ' HT3')  atmname = '3H  '
         if (atmname .eq. '1HH3')  atmname = '1H  '
         if (atmname .eq. '2HH3')  atmname = '2H  '
         if (atmname .eq. '3HH3')  atmname = '3H  '
c
c     C-terminal amide residue  (NH2)
c
      else if (resname .eq. 'NH2') then
         if (atmname .eq. ' NT ')  atmname = ' N  '
         if (atmname .eq. ' H1 ')  atmname = '1H  '
         if (atmname .eq. ' H2 ')  atmname = '2H  '
         if (atmname .eq. ' HT1')  atmname = '1H  '
         if (atmname .eq. ' HT2')  atmname = '2H  '
c
c     deoxythymidine residue  (THY)
c
      else if (resname .eq. 'THY') then
         if (atmname .eq. 'H5M1')  atmname = '1H5M'
         if (atmname .eq. 'H5M2')  atmname = '2H5M'
         if (atmname .eq. 'H5M3')  atmname = '3H5M'
      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 (iprm)
      implicit none
      include 'sizes.i'
      include 'fields.i'
      include 'iounit.i'
      include 'kanang.i'
      include 'kangs.i'
      include 'katoms.i'
      include 'kbonds.i'
      include 'kchrge.i'
      include 'kdipol.i'
      include 'khbond.i'
      include 'kiprop.i'
      include 'kitors.i'
      include 'kmulti.i'
      include 'kopbnd.i'
      include 'kopdst.i'
      include 'korbs.i'
      include 'kpolr.i'
      include 'kstbnd.i'
      include 'ksttor.i'
      include 'ktorsn.i'
      include 'kurybr.i'
      include 'kvdws.i'
      include 'kvdwpr.i'
      integer i,j,iprm
      integer size,next
      integer length,trimtext
      integer ia,ib,ic,id
      integer cls,atn,lig
      integer ft(6),pg(maxval)
      integer nvp,nhb,nmp,npi
      integer nb,nb5,nb4,nb3,nel
      integer na,na5,na4,na3,naf
      integer nu,nopb,nopd,ndi,nti
      integer nt,nt5,nt4,nbt
      integer nd,nd5,nd4,nd3
      real*8 wght,rd,ep,rdn
      real*8 an1,an2,an3
      real*8 ba1,ba2,ba3
      real*8 aa1,aa2,aa3
      real*8 bt1,bt2,bt3
      real*8 an,pr,ds,dk,vd,cg
      real*8 dp,ps,fc,bd,dl,el
      real*8 pol,iz,rp,ss,ts
      real*8 vt(6),st(6),pl(13)
      logical header
      character*3 pa,pb,pc,pd
      character*8 axt
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     initialize the counters for some parameter types
c
      nvp = 0
      nhb = 0
      nb = 0
      nb5 = 0
      nb4 = 0
      nb3 = 0
      nel = 0
      na = 0
      na5 = 0
      na4 = 0
      na3 = 0
      naf = 0
      nu = 0
      nopb = 0
      nopd = 0
      ndi = 0
      nti = 0
      nt = 0
      nt5 = 0
      nt4 = 0
      nbt = 0
      nd = 0
      nd5 = 0
      nd4 = 0
      nd3 = 0
      nmp = 0
      npi = 0
c
c     number of characters in an atom number text string
c
      size = 3
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
      dowhile (.true.)
         read (iprm,10,err=480,end=480)  record
   10    format (a80)
         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:80)
            length = trimtext (string)
            if (header) then
               header = .false.
               write (iout,20)
   20          format ()
            end if
            if (length .eq. 0) then
               write (iout,30)
   30          format ()
            else
               write (iout,40)  string(1:length)
   40          format (a)
            end if
c
c     biopolymer atom type conversion definitions
c
         else if (keyword(1:8) .eq. 'BIOTYPE ') then
            ia = 0
            ib = 0
            string = record(next:80)
            read (string,*,err=50,end=50)  ia
            call getword (record,string,next)
            call getstring (record,string,next)
            string = record(next:80)
            read (string,*,err=50,end=50)  ib
            if (ia .ne. 0)  biotyp(ia) = ib
   50       continue
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,60)
   60          format (/,' READPRM  --  Too many Atom Types;',
     &                    ' Increase MAXTYP')
               call fatal
            else if (cls .ge. maxclass) then
               write (iout,70)
   70          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:80)
               read (string,*,err=80,end=80)  atn,wght,lig
   80          continue
               atmnum(ia) = atn
               weight(ia) = wght
               ligand(ia) = lig
            end if
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:80)
            read (string,*,err=90,end=90)  ia,rd,ep,rdn
   90       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:80)
            read (string,*,err=100,end=100)  ia,rd,ep
  100       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:6) .eq. 'VDWPR ') then
            ia = 0
            ib = 0
            rd = 0.0d0
            ep = 0.0d0
            string = record(next:80)
            read (string,*,err=110,end=110)  ia,ib,rd,ep
  110       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:80)
            read (string,*,err=120,end=120)  ia,ib,rd,ep
  120       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     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:80)
            read (string,*,err=130,end=130)  ia,ib,fc,bd
  130       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:80)
            read (string,*,err=140,end=140)  ia,ib,fc,bd
  140       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:80)
            read (string,*,err=150,end=150)  ia,ib,fc,bd
  150       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:80)
            read (string,*,err=160,end=160)  ia,ib,fc,bd
  160       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:80)
            read (string,*,err=170,end=170)  ia,ib,ic,dl
  170       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:80)
            read (string,*,err=180,end=180)  ia,ib,ic,fc,an1,an2,an3
  180       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:80)
            read (string,*,err=190,end=190)  ia,ib,ic,fc,an1,an2,an3
  190       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:80)
            read (string,*,err=200,end=200)  ia,ib,ic,fc,an1,an2,an3
  200       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:80)
            read (string,*,err=210,end=210)  ia,ib,ic,fc,an1,an2,an3
  210       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     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:80)
            read (string,*,err=220,end=220)  ia,ib,ic,fc,an,pr
  220       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
            ba1 = 0.0d0
            ba2 = 0.0d0
            ba3 = 0.0d0
            string = record(next:80)
            read (string,*,err=230,end=230)  ia,ba1,ba2,ba3
  230       continue
            if (ia .ne. 0) then
               stbn(1,ia) = ba1
               stbn(2,ia) = ba2
               stbn(3,ia) = ba3
            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:80)
            read (string,*,err=240,end=240)  ia,ib,ic,fc,ds
  240       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:80)
            read (string,*,err=250,end=250)  ia,aa1,aa2,aa3
  250       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
            fc = 0.0d0
            string = record(next:80)
            read (string,*,err=260,end=260)  ia,ib,fc
  260       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nopb = nopb + 1
            kaopb(nopb) = pa//pb
            copb(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:80)
            read (string,*,err=270,end=270)  ia,ib,ic,id,fc
  270       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            call numeral (id,pd,size)
            nopd = nopd + 1
            kaopd(nopd) = pa//pb//pc//pd
            copd(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:80)
            read (string,*,err=280,end=280)  ia,ib,ic,id,dk,vd
  280       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:80)
            read (string,*,err=290,end=290)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  290       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:80)
            read (string,*,err=300,end=300)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  300       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:80)
            read (string,*,err=310,end=310)  ia,ib,ic,id,
     &                                       (vt(j),st(j),ft(j),j=1,6)
  310       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:80)
            read (string,*,err=320,end=320)  ia,ib,ic,id,
     &                                       (vt(i),st(i),ft(i),i=1,6)
  320       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     stretch-torsion parameters
c
         else if (keyword(1:8) .eq. 'STRTORS ') then
            ia = 0
            ib = 0
            bt1 = 0.0d0
            bt2 = 0.0d0
            bt3 = 0.0d0
            string = record(next:80)
            read (string,*,err=330,end=330)  ia,ib,bt1,bt2,bt3
  330       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nbt = nbt + 1
            if (ia .le. ib) then
               kbt(nbt) = pa//pb
            else
               kbt(nbt) = pb//pa
            end if
            btcon(1,nbt) = bt1
            btcon(2,nbt) = bt2
            btcon(3,nbt) = bt3
c
c     atomic partial charge parameters
c
         else if (keyword(1:7) .eq. 'CHARGE ') then
            ia = 0
            cg = 0.0d0
            string = record(next:80)
            read (string,*,err=340,end=340)  ia,cg
  340       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:80)
            read (string,*,err=350,end=350)  ia,ib,dp,ps
  350       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nd = nd + 1
            if (ia .le. ib) then
               kd(nd) = pa//pb
            else
               kd(nd) = pb//pa
            end if
            dpl(nd) = dp
            pos(nd) = ps
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:80)
            read (string,*,err=360,end=360)  ia,ib,dp,ps
  360       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nd5 = nd5 + 1
            if (ia .le. ib) then
               kd5(nd5) = pa//pb
            else
               kd5(nd5) = pb//pa
            end if
            dpl5(nd5) = dp
            pos5(nd5) = ps
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:80)
            read (string,*,err=370,end=370)  ia,ib,dp,ps
  370       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nd4 = nd4 + 1
            if (ia .le. ib) then
               kd4(nd4) = pa//pb
            else
               kd4(nd4) = pb//pa
            end if
            dpl4(nd4) = dp
            pos4(nd4) = ps
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:80)
            read (string,*,err=380,end=380)  ia,ib,dp,ps
  380       continue
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            nd3 = nd3 + 1
            if (ia .le. ib) then
               kd3(nd3) = pa//pb
            else
               kd3(nd3) = pb//pa
            end if
            dpl3(nd3) = dp
            pos3(nd3) = ps
c
c     atomic multipole moment parameters
c
         else if (keyword(1:10) .eq. 'MULTIPOLE ') then
            ia = 0
            ib = 0
            ic = 0
            axt = 'Z-then-X'
            do i = 1, 13
               pl(i) = 0.0d0
            end do
            string = record(next:80)
            read (string,*,err=430,end=430)  ia,ib,ic,pl(1)
            read (iprm,390,err=480,end=480)  record
  390       format (a80)
            read (record,*,err=430,end=430)  pl(2),pl(3),pl(4)
            read (iprm,400,err=480,end=480)  record
  400       format (a80)
            read (record,*,err=430,end=430)  pl(5)
            read (iprm,410,err=480,end=480)  record
  410       format (a80)
            read (record,*,err=430,end=430)  pl(8),pl(9)
            read (iprm,420,err=480,end=480)  record
  420       format (a80)
            read (record,*,err=430,end=430)  pl(11),pl(12),pl(13)
  430       continue
            if (ic .lt. 0) then
               ic = -ic
               axt = 'Bisector'
            end if
            call numeral (ia,pa,size)
            call numeral (ib,pb,size)
            call numeral (ic,pc,size)
            nmp = nmp + 1
            kmp(nmp) = pa//pb//pc
            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     atomic dipole polarizability parameters
c
         else if (keyword(1:9) .eq. 'POLARIZE ') then
            ia = 0
            pol = 0.0d0
            do i = 1, maxval
               pg(i) = 0
            end do
            string = record(next:80)
            read (string,*,err=440,end=440)  ia,pol,(pg(i),i=1,maxval)
  440       continue
            if (ia .ne. 0) then
               polr(ia) = pol
               do i = 1, maxval
                  pgrp(i,ia) = pg(i)
               end do
            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:80)
            read (string,*,err=450,end=450)  ia,el,iz,rp
  450       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:80)
            read (string,*,err=460,end=460)  ia,ib,ss,ts
  460       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     metal ligand field parameters
c
         else if (keyword(1:6) .eq. 'METAL ') then
            string = record(next:80)
            read (string,*,err=470,end=470)  ia
  470       continue
         end if
      end do
  480 continue
      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)
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'iounit.i'
      include 'resdue.i'
      include 'sequen.i'
      integer i,j,iseq
      integer length,number
      integer next,trimtext
      logical exist,opened,done
      character*1 letter
      character*3 word
      character*60 seqfile
      character*120 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
      dowhile (.true.)
         read (iseq,20,err=30,end=30)  record
   20    format (a120)
         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.
         dowhile (.not. done)
            call getword (record,word,next)
            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 the residue type for each sequence element
c
      do i = 1, nseq
         seqtyp(i) = 0
         do j = 1, maxamino
            if (seq(i) .eq. amino(j)) then
               seqtyp(i) = j
               goto 40
            end if
         end do
         do j = 1, maxnuc
            if (seq(i) .eq. nuclz(j)) then
               seqtyp(i) = j
               goto 40
            end if
         end do
   40    continue
      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 Cartesian coordinates  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "readxyz" gets a set of Cartesian coordinates from
c     an external disk file
c
c
      subroutine readxyz (ixyz)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'titles.i'
      integer i,j,k,m,ixyz
      integer next,size
      integer first,last
      integer nexttext
      integer trimtext
      integer list(maxatm)
      logical exist,opened
      logical quit,reorder
      character*60 xyzfile
      character*120 record
      character*120 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=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.
      size = 0
      dowhile (size .eq. 0)
         read (ixyz,20,err=60,end=60)  record
   20    format (a120)
         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=60,end=60)  n
c
c     extract the title and determine its length
c
      string = record(next:120)
      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 .gt. maxatm) then
         write (iout,30)  maxatm
   30    format (/,' READXYZ  --  The Maximum of',i6,' Atoms',
     &              ' has been Exceeded')
         call fatal
      end if
c
c     read the coordinates and connectivities for each atom
c
      do i = 1, n
         next = 1
         do j = 1, maxval
            i12(j,i) = 0
         end do
         size = 0
         dowhile (size .eq. 0)
            read (ixyz,40,err=60,end=60)  record
   40       format (a120)
            size = trimtext (record)
         end do
         read (record,*,err=60,end=60)  tag(i)
         call getword (record,name(i),next)
         string = record(next:120)
         read (string,*,err=60,end=50)  x(i),y(i),z(i),type(i),
     &                                  (i12(j,i),j=1,maxval)
   50    continue
      end do
      quit = .false.
   60 continue
      if (.not. opened)  close (unit=ixyz)
c
c     an error occurred in reading the coordinate file
c
      if (quit) then
         write (iout,70)  i
   70    format (/,' READXYZ  --  Error in Coordinate File at Atom',i6)
         call fatal
      end if
c
c     for each atom, count and sort its attached atoms
c
      do i = 1, n
         n12(i) = 0
         do j = maxval, 1, -1
            if (i12(j,i) .ne. 0) then
               n12(i) = j
               goto 80
            end if
         end do
   80    continue
         call sort (n12(i),i12(1,i))
      end do
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,90)
   90    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     check for atom pairs with identical coordinates
c
      call chkxyz
c
c     make sure that all 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 110
            end do
            write (iout,100)  k,i
  100       format (/,' READXYZ  --  Check Connection of Atom',
     &                 i6,' to Atom',i6)
            call fatal
  110       continue
         end do
      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 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)
      implicit none
      include 'sizes.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'inform.i'
      include 'iounit.i'
      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
      if (.not. use_image)  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 = 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
      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     truncated octahedron cannot use the replicates method
c
      if (octahedron .and. use_replica) then
         write (iout,10)
   10    format (/,' REPLICA  --  Truncated Octahedron',
     &              ' cannot be Replicated')
         call fatal
      end if
c
c     find the number of replicates for orthogonal lattice
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
      xcell = dble(nx) * xbox
      ycell = dble(ny) * ybox
      zcell = dble(nz) * zbox
c
c     check the total number of replicated unit cells
c
      ncell = nx*ny*nz - 1
      if (ncell .gt. maxcell) then
         write (iout,20)
   20    format (/,' REPLICA  --  Increase MAXCELL or Decrease',
     &              ' the Interaction Cutoffs')
         call fatal
      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
               if (k.ne.0 .or. j.ne.0 .or. i.ne.0) then
                  ncell = ncell + 1
                  icell(1,ncell) = i
                  icell(2,ncell) = j
                  icell(3,ncell) = k
               end if
            end do
         end do
      end do
c
c     set the half width values for the full replicated cell
c
      xcell2 = 0.5d0 * xcell
      ycell2 = 0.5d0 * ycell
      zcell2 = 0.5d0 * zcell
c
c     print a message indicating the number of replicates used
c
      if (debug .and. ncell.ne.0) then
         write (iout,30)  nx,ny,nz
   30    format (/,' REPLICA  --  Period Boundary via',i3,' x',
     &              i3,' x',i3,' Set of Cell Replicates')
      end if
      return
      end
c
c
c     ###########################################################
c     ##                 COPYRIGHT (C) 2001 by                 ##
c     ##  Marina A. Vorobieva, Andrey Kutepov & 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 single molecular dynamics time step
c     for a rigid-body calculation
c
c
      subroutine rgdstep (istep,dt)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bath.i'
      include 'bound.i'
      include 'group.i'
      include 'mdstuf.i'
      include 'rgddyn.i'
      include 'units.i'
      integer i,j,k,m
      integer istep,size
      integer start,stop
      integer iter,maxiter
      real*8 xr,yr,zr
      real*8 fx,fy,fz
      real*8 xx,yy,zz
      real*8 x2,y2,z2
      real*8 eps,dt
      real*8 temp,pres
      real*8 delta,weight
      real*8 ekin,epot,etot
      real*8 etrans,erot
      real*8 vc(3),wc(3)
      real*8 vcp(3),wcp(3)
      real*8 fc(3),tc(3)
      real*8 rc(3),rcold(3)
      real*8 dfi(3),dfiold(3)
      real*8 inert(6),inert0(3)
      real*8 arot(3,3)
      real*8 itensor(3,3)
      real*8 xp(maxatm),xm(maxatm)
      real*8 yp(maxatm),ym(maxatm)
      real*8 zp(maxatm),zm(maxatm)
      real*8 derivs(3,maxatm)
c
c
c     zero out the total kinetic energy over all groups
c
      ekin = 0.0d0
c
c     get the energy and atomic forces at start of the step
c
      call gradient (epot,derivs)
c
c     get the extent and size of the current rigid body
c
      do i = 1, ngrp
         start = igrp(1,i)
         stop = igrp(2,i)
         size = stop - start + 1
c
c     compute the center of mass coordinates prior to step
c
         do j = 1, 3
            rc(j) = 0.0d0
         end do
         do j = start, stop
            k = kgrp(j)
            weight = mass(k)
            rc(1) = rc(1) + x(k)*weight
            rc(2) = rc(2) + y(k)*weight
            rc(3) = rc(3) + z(k)*weight
         end do
         do j = 1, 3
            rc(j) = rc(j) / grpmass(i)
         end do
         do j = start, stop
            k = kgrp(j)
            xm(k) = x(k) - rc(1)
            ym(k) = y(k) - rc(2)
            zm(k) = z(k) - rc(3)
         end do
c
c     compute the force and torque components for this group
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 = -convert * derivs(1,k)
            fy = -convert * derivs(2,k)
            fz = -convert * 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     get new velocities and coordinates for center of mass
c
         do j = 1, 3
            vcp(j) = vcm(j,i) + dt*fc(j)/grpmass(i)
            rcold(j) = rc(j)
            rc(j) = rc(j) + dt*vcp(j)
         end do
c
c     handle the single-atom group case separately
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
               wc(j) = 0.0d0
               wcm(j,i) = 0.0d0
               lm(j,i) = 0.0d0
               do k = 1, 3
                  itensor(k,j) = 0.0d0
               end do
            end do
c
c     compute and store the inertial tensor components
c
         else
            do j = 1, 6
               inert(j) = 0.0d0
            end do
            do j = start, stop
               k = kgrp(j)
               xx = xm(k)
               yy = ym(k)
               zz = zm(k)
               x2 = xx * xx
               y2 = yy * yy
               z2 = zz * zz
               weight = mass(k)
               inert(1) = inert(1) + weight*(y2+z2)
               inert(2) = inert(2) - weight*xx*yy
               inert(3) = inert(3) + weight*(x2+z2)
               inert(4) = inert(4) - weight*xx*zz
               inert(5) = inert(5) - weight*yy*zz
               inert(6) = inert(6) + weight*(x2+y2)
            end do
            m = 0
            do j = 1, 3
               do k = 1, j
                  m = m + 1
                  itensor(k,j) = inert(m)
                  itensor(j,k) = inert(m)
               end do
            end do
c
c     get impulse moment in space fixed coordinate system
c
            do j = 1, 3
               lm(j,i) = lm(j,i) + dt*tc(j)
            end do
c
c     use an iterative scheme to converge the angular momentum
c
            maxiter = 15
            eps = 1.0d-12
            iter = 0
            delta = 1.0d0
            do j = 1, 3
               dfi(j) = dt * wcm(j,i)
               dfiold(j) = dfi(j)
            end do
c
c     predict the atomic coordinates at the half timestep
c
            dowhile (delta.gt.eps .and. iter.le.maxiter)
               iter = iter + 1
               call rotrgd (dfi,arot)
               call newcrd (i,arot,xm,ym,zm,xp,yp,zp,rcold,rc,0)
c
c     compute the moments of inertia at the half timestep
c
               do j = 1, 6
                  inert(j) = 0.0d0
               end do
               do j = start, stop
                  k = kgrp(j)
                  xx = xp(k)
                  yy = yp(k)
                  zz = zp(k)
                  x2 = xx * xx
                  y2 = yy * yy
                  z2 = zz * zz
                  weight = mass(k)
                  inert(1) = inert(1) + weight*(y2+z2)
                  inert(2) = inert(2) - weight*xx*yy
                  inert(3) = inert(3) + weight*(x2+z2)
                  inert(4) = inert(4) - weight*xx*zz
                  inert(5) = inert(5) - weight*yy*zz
                  inert(6) = inert(6) + weight*(x2+y2)
               end do
c
c     get angular velocity from L=Iw at the half timestep
c
               do j = 1, 3
                  wcp(j) = lm(j,i)
               end do
               if (linear(i)) then
                  j = kgrp(start)
                  k = kgrp(stop)
                  call linbody (inert,x(j),y(j),z(j),
     &                          x(k),y(k),z(k),wcp)
               else
                  call regbody (inert,inert0,wcp)
               end if
c
c     check to see if the angular momentum has converged
c
               delta = 0.0d0
               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     compute final atomic coordinates at the full timestep
c
            do j = 1, 3
               dfi(j) = dt * wcp(j)
            end do
            call rotrgd (dfi,arot)
            call newcrd (i,arot,x,y,z,x,y,z,rcold,rc,1)
            do j = 1, 3
               wc(j) = 0.5d0 * (wcm(j,i)+wcp(j))
               wcm(j,i) = wcp(j)
            end do
         end if
c
c     increment the translational kinetic energy for this group
c
         etrans = 0.0d0
         do j = 1, 3
            vc(j) = 0.5d0 * (vcm(j,i)+vcp(j))
            vcm(j,i) = vcp(j)
            etrans = etrans + vc(j)*vc(j)
         end do
         etrans = 0.5d0 * etrans * grpmass(i) / convert
         ekin = ekin + etrans
c
c     increment the rotational kinetic energy for this group
c
         erot = 0.0d0
         do j = 1, 3
            do k = 1, 3
               erot = erot + itensor(j,k)*wc(j)*wc(k)
            end do
         end do
         erot = 0.5d0 * erot / convert
         ekin = ekin + erot
      end do
c
c     determine the system temperature and total energy
c
      temp = 2.0d0 * ekin / (dble(nfree) * gasconst)
      etot = ekin + epot
c
c     control temperature and pressure via external bath coupling
c
      if (isothermal)  call temper (dt,temp)
      if (isobaric)  call pressure (dt,pres,ekin)
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,ekin,temp,pres)
      call mdsave (istep)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine rotrgd  --  rotation matrix for dynamics step  ##
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
      integer i,j
      real*8 x,y,z
      real*8 c,s,ct
      real*8 sx,sy,sz
      real*8 anorm,anorm2
      real*8 dfi(3),arot(3,3)
c
c
      anorm2 = dfi(1)**2 + dfi(2)**2 + dfi(3)**2
      if (anorm2 .eq. 0.0d0) then
         do i = 1, 3
            do j = 1, 3
               arot(j,i) = 0.0d0
            end do
            arot(i,i) = 1.0d0
         end do
      else
         anorm = sqrt(anorm2)
         x = dfi(1) / anorm
         y = dfi(2) / anorm
         z = dfi(3) / anorm
         c = cos(anorm)
         s = sin(anorm)
         ct = 1.0d0 - c
         arot(1,1) = c + ct*x*x
         arot(2,2) = c + ct*y*y
         arot(3,3) = c + ct*z*z
         sz = s * z
         arot(1,2) = ct * x * y
         arot(2,1) = arot(1,2) + sz
         arot(1,2) = arot(1,2) - sz
         sy = s * y
         arot(1,3) = ct * x * z
         arot(3,1) = arot(1,3) - sy
         arot(1,3) = arot(1,3) + sy
         sx = s * x
         arot(2,3) = ct * y * z
         arot(3,2) = arot(2,3) + sx
         arot(2,3) = arot(2,3) - sx
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine newcrd  --  coordinates after translate/rotate  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "newcrd" computes updated atomic coordinates for a rigid body
c     given the previous coordinates, the rotation matrix and shift
c     in the center of mass corresponding to the motion
c
c
      subroutine newcrd (i,a,xold,yold,zold,xnew,ynew,znew,rcold,rc,key)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'group.i'
      integer i,j,k,m1,m2,key
      real*8 tmp(3),tmp2(3)
      real*8 rc(3),rcold(3)
      real*8 a(3,3)
      real*8 xold(maxatm),xnew(maxatm)
      real*8 yold(maxatm),ynew(maxatm)
      real*8 zold(maxatm),znew(maxatm)
c
c
      do j = igrp(1,i), igrp(2,i)
         k = kgrp(j)
         if (key .eq. 1) then
            tmp(1) = xold(k) - rcold(1)
            tmp(2) = yold(k) - rcold(2)
            tmp(3) = zold(k) - rcold(3)
            do m1 = 1, 3
               tmp2(m1) = 0.0d0
               do m2 = 1, 3
                  tmp2(m1) = tmp2(m1) + a(m1,m2)*tmp(m2)
               end do
            end do
            xnew(k) = tmp2(1) + rc(1)
            ynew(k) = tmp2(2) + rc(2)
            znew(k) = tmp2(3) + rc(3)
         else
            tmp(1) = xold(k)
            tmp(2) = yold(k)
            tmp(3) = zold(k)
            do m1 = 1, 3
               tmp2(m1) = 0.0d0
               do m2 = 1, 3
                  tmp2(m1) = tmp2(m1) + a(m1,m2)*tmp(m2)
               end do
            end do
            xnew(k) = tmp2(1)
            ynew(k) = tmp2(2)
            znew(k) = tmp2(3)
         end if
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine linbody  --  angular velocity of a linear body  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "linbody" finds the angular velocity of a linear rigid body
c
c
      subroutine linbody (inert,x1,y1,z1,x2,y2,z2,wcp)
      implicit none
      integer i,k
      real*8 dd,rm
      real*8 x1,y1,z1
      real*8 x2,y2,z2
      real*8 a11,a12,a22
      real*8 b1,b2,w1,w2
      real*8 inert(6)
      real*8 wcp(3)
      real*8 rmol(3)
      real*8 r1(3),r2(3),r3(3)
c
c
c     construct a normalized vector along molecular axis
c
      rmol(1) = x2 - x1
      rmol(2) = y2 - y1
      rmol(3) = z2 - z1
      dd = 1.0d0 / sqrt(rmol(1)**2+rmol(2)**2+rmol(3)**2)
      do i = 1, 3
         rmol(i) = rmol(i) * dd
      end do
c
c     find two orthogonal vectors to complete coordinate frame
c
      k = 1
      rm = abs(rmol(1))
      do i = 2, 3
         if (abs(rmol(i)) .lt. rm) then
            rm = abs(rmol(i))
            k = i
         end if
      end do
      do i = 1, 3
         r1(i) = -rmol(k) * rmol(i)
      end do
      r1(k) = 1.0d0 + r1(k)
      dd = 1.0d0 / sqrt(r1(1)**2+r1(2)**2+r1(3)**2)
      do i = 1, 3
         r1(i) = r1(i) * dd
      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(4)*r1(3)
      r3(2) = inert(2)*r1(1) + inert(3)*r1(2) + inert(5)*r1(3)
      r3(3) = inert(4)*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(4)*r2(3)
      r3(2) = inert(2)*r2(1) + inert(3)*r2(2) + inert(5)*r2(3)
      r3(3) = inert(4)*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 i = 1, 3
         wcp(i) = w1*r1(i) + w2*r2(i)
      end do
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine regbody  --  angular velocity of nonlinear body  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "regbody" finds the angular velocity of a regular, nonlinear
c     rigid body
c
c
      subroutine regbody (inert,inert0,wcp)
      implicit none
      integer i,j,k
      integer j1,k1
      real*8 sum
      real*8 inert(6)
      real*8 inert0(3)
      real*8 wcp(3)
c
c
      do k = 1, 3
         sum = 0.0d0
         k1 = k * (k-1) / 2
         do i = 1, k-1
            sum = sum + inert0(i)*inert(k1+i)**2
         end do
         inert0(k) = inert(k1+k) - sum
         do j = k+1, 3
            sum = 0.0d0
            j1 = j * (j-1) / 2
            do i = 1, k-1
               sum = sum + inert0(i)*inert(k1+i)*inert(j1+i)
            end do
            i = j1 + k
            inert(i) = (inert(i)-sum) / inert0(k)
         end do
      end do
c
c
      do k = 1, 3
         sum = 0.0d0
         k1 = k * (k-1) / 2
         do i = 1, k-1
            sum = sum + wcp(i)*inert(k1+i)
         end do
         wcp(k) = wcp(k) - sum
      end do
      do i = 1, 3
         wcp(i) = wcp(i) / inert0(i)
      end do
      do k = 3, 1, -1
         sum = 0.0d0
         k1 = k * (k+3) / 2
         do i = k+1, 3
            sum = sum + inert(k1)*wcp(i)
            k1 = k1 + i
         end do
         wcp(k) = wcp(k) - sum
      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 rings  --  locate and store small rings  ##
c     ##                                                      ##
c     ##########################################################
c
c
c     "rings" searches the structure for small rings and stores
c     their component atoms; code to remove the reducible rings
c     consisting of smaller rings is commented in this version
c     since reducible rings are needed for parameter assignment
c
c
      subroutine rings
      implicit none
      include 'sizes.i'
      include 'angle.i'
c     include 'atoms.i'
      include 'bond.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'ring.i'
      include 'tors.i'
      integer i,j,k,ii,iii,imax
      integer ia,ib,ic,id,ie,ig
c     integer list1,list2
c     integer list3,list4
c     integer m,list(maxatm)
c
c
c     zero out the number of small rings in the structure
c
      nring3 = 0
      nring4 = 0
      nring5 = 0
      nring6 = 0
c
c     parse the structure for bonds, angles and torsions
c
      if (nbond .eq. 0)  call bonds
      if (nangle .eq. 0)  call angles
      if (ntors .eq. 0)  call torsions
c
c     search for and store all of the 3-membered rings
c
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         if (ib.lt.ia .and. ib.lt.ic) then
            do j = 1, n12(ia)
               if (i12(j,ia) .eq. ic) then
                  nring3 = nring3 + 1
                  if (nring3 .gt. maxring) then
                     write (iout,10)
   10                format (/,' RINGS  --  Too many 3-Membered Rings')
                     call fatal
                  end if
                  iring3(1,nring3) = ia
                  iring3(2,nring3) = ib
                  iring3(3,nring3) = ic
                  goto 20
               end if
            end do
   20       continue
         end if
      end do
c
c     search for and store all of the 4-membered rings
c
c     do i = 1, n
c        list(i) = 0
c     end do
      do i = 1, nangle
         ia = iang(1,i)
         ib = iang(2,i)
         ic = iang(3,i)
         imax = max(ia,ib,ic)
         do j = 1, n12(ia)
            id = i12(j,ia)
            if (id .gt. imax) then
               do k = 1, n12(ic)
                  if (i12(k,ic) .eq. id) then
                     nring4 = nring4 + 1
                     if (nring4 .gt. maxring) then
                        write (iout,30)
   30                   format (/,' RINGS  --  Too many',
     &                             ' 4-Membered Rings')
                        call fatal
                     end if
                     iring4(1,nring4) = ia
                     iring4(2,nring4) = ib
                     iring4(3,nring4) = ic
                     iring4(4,nring4) = id
c
c     remove the ring if it is reducible into smaller rings
c
c                    list(ia) = nring4
c                    list(ib) = nring4
c                    list(ic) = nring4
c                    list(id) = nring4
c                    do m = 1, nring3
c                       list1 = list(iring3(1,m))
c                       list2 = list(iring3(2,m))
c                       list3 = list(iring3(3,m))
c                       if (list1.eq.nring4 .and. list2.eq.nring4
c    &                          .and. list3.eq.nring4) then
c                          nring4 = nring4 - 1
c                          list(ia) = 0
c                          list(ib) = 0
c                          list(ic) = 0
c                          list(id) = 0
c                          goto 40
c                       end if
c                    end do
                     goto 40
                  end if
               end do
   40          continue
            end if
         end do
      end do
c
c     search for and store all of the 5-membered rings
c
c     do i = 1, n
c        list(i) = 0
c     end do
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         imax = max(ia,ib,ic,id)
         do j = 1, n12(ia)
            ie = i12(j,ia)
            if (ie .gt. imax) then
               do k = 1, n12(id)
                  if (i12(k,id) .eq. ie) then
                     nring5 = nring5 + 1
                     if (nring5 .gt. maxring) then
                        write (iout,50)
   50                   format (/,' RINGS  --  Too many',
     &                             ' 5-Membered Rings')
                        call fatal
                     end if
                     iring5(1,nring5) = ia
                     iring5(2,nring5) = ib
                     iring5(3,nring5) = ic
                     iring5(4,nring5) = id
                     iring5(5,nring5) = ie
c
c     remove the ring if it is reducible into smaller rings
c
c                    list(ia) = nring5
c                    list(ib) = nring5
c                    list(ic) = nring5
c                    list(id) = nring5
c                    list(ie) = nring5
c                    do m = 1, nring3
c                       list1 = list(iring3(1,m))
c                       list2 = list(iring3(2,m))
c                       list3 = list(iring3(3,m))
c                       if (list1.eq.nring5 .and. list2.eq.nring5
c    &                          .and. list3.eq.nring5) then
c                          nring5 = nring5 - 1
c                          list(ia) = 0
c                          list(ib) = 0
c                          list(ic) = 0
c                          list(id) = 0
c                          list(ie) = 0
c                          goto 60
c                       end if
c                    end do
                     goto 60
                  end if
               end do
   60          continue
            end if
         end do
      end do
c
c     search for and store all of the 6-membered rings
c
c     do i = 1, n
c        list(i) = 0
c     end do
      do i = 1, nangle
         ib = iang(1,i)
         ic = iang(2,i)
         id = iang(3,i)
         do ii = 1, n12(ib)
            ia = i12(ii,ib)
            if (ia.ne.ic .and. ia.ne.id) then
               do iii = 1, n12(id)
                  ie = i12(iii,id)
                  if (ie.ne.ic .and. ie.ne.ib .and. ie.ne.ia) then
                     imax = max(ia,ib,ic,id,ie)
                     do j = 1, n12(ia)
                        ig = i12(j,ia)
                        if (ig .gt. imax) then
                           do k = 1, n12(ie)
                              if (i12(k,ie) .eq. ig) then
                                 nring6 = nring6 + 1
                                 if (nring6 .gt. maxring) then
                                    write (iout,70)
   70                               format (/,' RINGS  --  Too many',
     &                                         ' 6-Membered Rings')
                                    call fatal
                                 end if
                                 iring6(1,nring6) = ia
                                 iring6(2,nring6) = ib
                                 iring6(3,nring6) = ic
                                 iring6(4,nring6) = id
                                 iring6(5,nring6) = ie
                                 iring6(6,nring6) = ig
c
c     remove the ring if it is reducible into smaller rings
c
c                                list(ia) = nring6
c                                list(ib) = nring6
c                                list(ic) = nring6
c                                list(id) = nring6
c                                list(ie) = nring6
c                                list(ig) = nring6
c                                do m = 1, nring3
c                                   list1 = list(iring3(1,m))
c                                   list2 = list(iring3(2,m))
c                                   list3 = list(iring3(3,m))
c                                   if (list1.eq.nring6 .and.
c    &                                  list2.eq.nring6 .and.
c    &                                  list3.eq.nring6) then
c                                      nring6 = nring6 - 1
c                                      list(ia) = 0
c                                      list(ib) = 0
c                                      list(ic) = 0
c                                      list(id) = 0
c                                      list(ie) = 0
c                                      list(ig) = 0
c                                      goto 80
c                                   end if
c                                end do
c                                do m = 1, nring4
c                                   list1 = list(iring4(1,m))
c                                   list2 = list(iring4(2,m))
c                                   list3 = list(iring4(3,m))
c                                   list4 = list(iring4(4,m))
c                                   if (list1.eq.nring6 .and.
c    &                                  list2.eq.nring6 .and.
c    &                                  list3.eq.nring6 .and.
c    &                                  list4.eq.nring6) then
c                                      nring6 = nring6 - 1
c                                      list(ia) = 0
c                                      list(ib) = 0
c                                      list(ic) = 0
c                                      list(id) = 0
c                                      list(ie) = 0
c                                      list(ig) = 0
c                                      goto 80
c                                   end if
c                                end do
   80                            continue
                              end if
                           end do
                        end if
                     end do
                  end if
               end do
            end if
         end do
      end do
c
c     print out lists of the small rings in the structure
c
      if (debug) then
         if (nring3 .gt. 0) then
            write (iout,90)
   90       format (/,' Three-Membered Rings Contained',
     &                 ' in the Structure :',
     &              //,11x,'Ring',14x,'Atoms in Ring',/)
            do i = 1, nring3
               write (iout,100)  i,(iring3(j,i),j=1,3)
  100          format (9x,i5,10x,3i6)
            end do
         end if
         if (nring4 .gt. 0) then
            write (iout,110)
  110       format (/,' Four-Membered Rings Contained',
     &                 ' in the Structure :',
     &              //,11x,'Ring',17x,'Atoms in Ring',/)
            do i = 1, nring4
               write (iout,120)  i,(iring4(j,i),j=1,4)
  120          format (9x,i5,10x,4i6)
            end do
         end if
         if (nring5 .gt. 0) then
            write (iout,130)
  130       format (/,' Five-Membered Rings Contained',
     &                 ' in the Structure :',
     &              //,11x,'Ring',20x,'Atoms in Ring',/)
            do i = 1, nring5
               write (iout,140)  i,(iring5(j,i),j=1,5)
  140          format (9x,i5,10x,5i6)
            end do
         end if
         if (nring6 .gt. 0) then
            write (iout,150)
  150       format (/,' Six-Membered Rings Contained',
     &                 ' in the Structure :',
     &              //,11x,'Ring',23x,'Atoms in Ring',/)
            do i = 1, nring6
               write (iout,160)  i,(iring6(j,i),j=1,6)
  160          format (9x,i5,10x,6i6)
            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)
      implicit none
      include 'sizes.i'
      include 'align.i'
      integer i,i1,i2
      real*8 rmsfit,rmsterm
      real*8 xr,yr,zr,dist2
      real*8 weight,norm
      real*8 x1(maxatm),x2(maxatm)
      real*8 y1(maxatm),y2(maxatm)
      real*8 z1(maxatm),z2(maxatm)
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)
         weight = 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 + weight
         rmsterm = dist2 * weight
         rmsfit = rmsfit + rmsterm
      end do
      rmsfit = sqrt(rmsfit/norm)
      return
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'couple.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'rotate.i'
      include 'zclose.i'
      integer i,k,ia,ib,swap
      integer base,partner
      integer mark,test,nattach
      integer list(0:maxatm)
      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     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
c
c     remove links added to make intermolecular connections
c
   40 continue
      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" computes the atomic multipole values in the global
c     coordinate frame by applying a rotation matrix to a set of
c     locally defined multipoles
c
c
      subroutine rotpole (imdq,a)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'mpole.i'
      integer i,j,k,m
      integer imdq
      real*8 a(3,3)
      real*8 m2(3,3)
      real*8 r2(3,3)
c
c
c     monopoles have the same value in any coordinate frame
c
      rpole(1,imdq) = pole(1,imdq)
c
c     rotate the dipoles to the global coordinate frame
c
      do i = 2, 4
         rpole(i,imdq) = 0.0d0
         do j = 2, 4
            rpole(i,imdq) = rpole(i,imdq) + pole(j,imdq)*a(i-1,j-1)
         end do
      end do
c
c     rotate the quadrupoles to the global coordinate frame
c
      k = 5
      do i = 1, 3
         do j = 1, 3
            m2(i,j) = pole(k,imdq)
            r2(i,j) = 0.0d0
            k = k + 1
         end do
      end do
      do i = 1, 3
         do j = 1, 3
            if (j .lt. i) then
               r2(i,j) = r2(j,i)
            else
               do k = 1, 3
                  do m = 1, 3
                     r2(i,j) = r2(i,j) + a(i,k)*a(j,m)*m2(k,m)
                  end do
               end do
            end if
         end do
      end do
      k = 5
      do i = 1, 3
         do j = 1, 3
            rpole(k,imdq) = r2(i,j)
            k = k + 1
         end do
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine rotmat  --  find multipole rotation matrix  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "rotmat" find the rotation matrix that converts from the local
c     coordinate system at each multipole site to the global system
c
c
      subroutine rotmat (i,a)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'mpole.i'
      integer i
      real*8 r,dotxz
      real*8 dx,dy,dz
      real*8 dx1,dy1,dz1
      real*8 dx2,dy2,dz2
      real*8 a(3,3)
c
c
c     rotation matrix elements for z- and x-axes, first z then x
c
      if (polaxe(i) .eq. 'Z-then-X') then
         dx = x(zaxis(i)) - x(ipole(i))
         dy = y(zaxis(i)) - y(ipole(i))
         dz = z(zaxis(i)) - z(ipole(i))
         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(xaxis(i)) - x(ipole(i))
         dy = y(xaxis(i)) - y(ipole(i))
         dz = z(xaxis(i)) - z(ipole(i))
         dotxz = dx*a(1,3) + dy*a(2,3) + dz*a(3,3)
         dx = dx - dotxz*a(1,3)
         dy = dy - dotxz*a(2,3)
         dz = dz - dotxz*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     rotation matrix elements for z- and x-axes, bisector method
c
      else if (polaxe(i) .eq. 'Bisector') then
         dx = x(zaxis(i)) - x(ipole(i))
         dy = y(zaxis(i)) - y(ipole(i))
         dz = z(zaxis(i)) - z(ipole(i))
         r = sqrt(dx*dx + dy*dy + dz*dz)
         dx1 = dx / r
         dy1 = dy / r
         dz1 = dz / r
         dx = x(xaxis(i)) - x(ipole(i))
         dy = y(xaxis(i)) - y(ipole(i))
         dz = z(xaxis(i)) - z(ipole(i))
         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
         dotxz = dx2*a(1,3) + dy2*a(2,3) + dz2*a(3,3)
         dx = dx2 - dotxz*a(1,3)
         dy = dy2 - dotxz*a(2,3)
         dz = dz2 - dotxz*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     ##  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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'keys.i'
      include 'linmin.i'
      include 'syntrn.i'
      include 'titles.i'
      include 'zcoord.i'
      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,gamma,gammamin
      real*8 sg,sg0,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,angle
      real*8 rmsvalue,energy1,energy2
      real*8 zbond1(maxatm),zbond2(maxatm)
      real*8 zang1(maxatm),zang2(maxatm)
      real*8 ztors1(maxatm),ztors2(maxatm)
      real*8 xx(maxvar),x_old(maxvar)
      real*8 g(maxvar),g_old(maxvar)
      real*8 tan(maxvar),dgdt(maxvar)
      real*8 s0(maxvar),s(maxvar)
      real*8 h0(maxvar)
      real*8 x1(maxatm),x2(maxatm)
      real*8 y1(maxatm),y2(maxatm)
      real*8 z1(maxatm),z2(maxatm)
      logical exist,terminate
      logical scan,spanned
      logical done,newcycle
      character*1 answer
      character*9 status
      character*20 keyword
      character*60 tsfile
      character*80 record
      character*80 string
      external saddle1
c
c
c     set default parameters for the saddle point run
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     get coordinates for the first endpoint structure
c
      call getxyz
      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
      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)
         if (keyword(1:8) .eq. 'DIVERGE ') then
            read (record(next:80),*,err=10)  diverge
         else if (keyword(1:7) .eq. 'REDUCE ') then
            read (record(next:80),*,err=10)  reduce
         else if (keyword(1:9) .eq. 'GAMMAMIN ') then
            read (record(next:80),*,err=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 (a80)
         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     copy the superimposed structures into vectors
c
      nvar = 3 * n
      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     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
         t = 0.5d0
         do i = 1, n
            zbond(i) = (1.0d0-t)*zbond1(i) + t*zbond2(i)
            zang(i) = (1.0d0-t)*zang1(i) + t*zang2(i)
            ztors(i) = (1.0d0-t)*ztors1(i) + t*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     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
      t = pm
      call pathpnt (nvar,t,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,t,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
      dowhile (.not. done)
         f_0 = f
         t = t + delta
         call pathpnt (nvar,t,xx,xmin1,xmin2)
         ncalls = ncalls + 1
         f_1 = saddle1 (xx,g)
         t = t - 2.0d0*delta
         call pathpnt (nvar,t,xx,xmin1,xmin2)
         t = t + 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
            t = t + delta
            p = 1.0d0
         else if (f_2 .gt. f_0) then
            t = t - delta
            p = -1.0d0
            f_1 = f_2
         else
            t = t + 0.5d0*delta*(f_2-f_1)/(f_1-2.0d0*f_0+f_2)
            goto 130
         end if
         spanned = .false.
         dowhile (.not. spanned)
            p = 2.0d0 * p
            t = t + p*delta
            if (t .le. 0.0d0) then
               t = 0.0d0
               f_2 = energy1
            else if (t .ge. 1.0d0) then
               t = 1.0d0
               f_2 = energy2
            else
               call pathpnt (nvar,t,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
         t = t - p*delta
         if (t .le. 0.0d0) then
            t = 0.0d0
            f_3 = energy1
         else if (t .ge. 1.0d0) then
            t = 1.0d0
            f_3 = energy2
         else
            call pathpnt (nvar,t,xx,xmin1,xmin2)
            ncalls = ncalls + 1
            f_3 = saddle1 (xx,g)
         end if
         if (f_3 .gt. f_1) then
            t = t + 0.5d0*abs(p)*delta*(f_1-f_2)/(f_2-2.0d0*f_3+f_1)
         else
            t = t - p*delta
            t = t + 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,t,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,t,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 (t.le.0.05d0 .or. t.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
      dowhile (.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)
                  t = reduce * pm
                  call pathpnt (nvar,t,x_old,xmin1,xmin2)
                  do i = 1, nvar
                     xmin1(i) = x_old(i)
                  end do
                  ncalls = ncalls + 1
                  energy1 = saddle1 (xmin1,g)
                  t = 1.0d0 - reduce*(1.0d0-pm)
                  call pathpnt (nvar,t,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 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
c     value for the specified structure
c
c
      subroutine pathval (nvar,xx)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'syntrn.i'
      integer i,nvar
      real*8 dr,dp,rmsvalue
      real*8 xx(maxvar)
      real*8 x1(maxatm),x2(maxatm)
      real*8 y1(maxatm),y2(maxatm)
      real*8 z1(maxatm),z2(maxatm)
c
c
c     find the value of the transit path coordinate "pm";
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)
      pm = dr / (dr+dp)
c
c     superimpose on linear transit structure of same path value
c
      do i = 1, n
         x1(i) = (1.0d0-pm)*xmin1(3*i-2) + pm*xmin2(3*i-2)
         y1(i) = (1.0d0-pm)*xmin1(3*i-1) + pm*xmin2(3*i-1)
         z1(i) = (1.0d0-pm)*xmin1(3*i) + pm*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
      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
c     transit path with the specified path value "t"
c
c
      subroutine pathpnt (nvar,t,xx,x0,x1)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'minima.i'
      integer i,nvar
      real*8 t,value
      real*8 grdmin,transit
      real*8 xx(maxvar)
      real*8 x0(maxvar)
      real*8 x1(maxvar)
      external transit
      external writeout
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-t)*x0(i) + t*x1(i)
      end do
c
c     optimize the synchronous transit function
c
c     call lbfgs (nvar,xx,value,grdmin,transit,writeout)
      call ocvm (nvar,xx,value,grdmin,transit,writeout)
      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)
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'syntrn.i'
      integer i,nvar,ncalls
      real*8 saddle1,energy
      real*8 g_rms,g_tan,gamma
      real*8 xx(maxvar)
      real*8 x0(maxvar)
      real*8 x1(maxvar)
      real*8 g(maxvar)
      real*8 tan(maxvar)
      real*8 dgdt(maxvar)
c
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
         t = 0.1d0 * dble(i)
         call pathpnt (nvar,t,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,t,g_rms,g_tan,gamma,ncalls
   20    format (i6,f13.4,f11.4,f11.4,f11.4,f11.5,i8)
      end do
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'syntrn.i'
      integer i,nvar
      real*8 g_rms,g_tan
      real*8 gamma,delta
      real*8 t0,g2,tan_norm
      real*8 saddle1,energy
      real*8 xx(maxvar)
      real*8 xf(maxvar)
      real*8 xb(maxvar)
      real*8 g(maxvar)
      real*8 gf(maxvar)
      real*8 gb(maxvar)
      real*8 tan(maxvar)
      real*8 dgdt(maxvar)
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 = t
      g2 = 0.0d0
      do i = 1, nvar
         g2 = g2 + g(i)**2
      end do
      g_rms = sqrt(g2/dble(n))
c
c     compute the forward difference
c
      do i = 1, nvar
         xf(i) = xx(i)
      end do
      t = t0 + delta
      call pathpnt (nvar,t,xf,xf,xf)
      energy = saddle1 (xf,gf)
c
c     compute the backward difference
c
      do i = 1, nvar
         xb(i) = xx(i)
      end do
      t = t0 - delta
      call pathpnt (nvar,t,xb,xb,xb)
      energy = saddle1 (xb,gb)
      t = 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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'syntrn.i'
      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(maxvar)
      real*8 g(maxvar)
      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 - t
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 (pm .eq. 0.0d0) then
         mode = 'linear'
      else
         mode = 'quadratic'
         pq = 1.0d0 - pm
      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 + t*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-pm*r2) / (pm*pq)
                  ri = ri + gamma*t*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) + t*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
      function saddle1 (xx,g)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i
      real*8 saddle1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
c
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) 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
c
c
      program scan
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'output.i'
      integer maxmap
      parameter (maxmap=100000)
      integer ixyz,lext,freeunit
      integer nmap,niter,neigen
      real*8 minimum,grdmin,range
      real*8 emap(maxmap)
      logical exist
      character*7 ext
      character*60 coordfile
      character*80 string
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
      if (neigen .le. 0) then
         write (iout,20)
   20    format(/,' Enter the Number Search Directions for Local',
     &             ' Search [5] :  ',$)
         read (input,30)  neigen
   30    format (i10)
         if (neigen .le. 0)  neigen = 5
      end if
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.00000001d0)  digits = 8
      if (grdmin .le. 0.000001d0)  digits = 6
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
      dowhile (niter .lt. nmap)
         niter = niter + 1
         write (iout,110)  niter
  110    format (/,' Normal Mode Local Search',7x,'Minimum',i7,/)
         lext = 3
         call numeral (niter,ext,lext)
         ixyz = freeunit ()
         coordfile = filename(1:leng)//'.'//ext(1:lext)
         call version (coordfile,'old')
         open (unit=ixyz,file=coordfile,status='old')
         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)
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      integer maxmap
      parameter (maxmap=100000)
      integer i,ixyz,lext
      integer nmap,freeunit
      real*8 minimum,grdmin
      real*8 delta,eps,range
      real*8 emap(maxmap)
      logical unique
      character*7 ext
      character*60 coordfile
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
         lext = 3
         call numeral (nmap,ext,lext)
         ixyz = freeunit ()
         coordfile = filename(1:leng)//'.'//ext(1:lext)
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,status='new')
         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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,nvar
      real*8 scan1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(3,maxatm)
c
c
c     translate 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     compute and store the energy and gradient
c
      call gradient (e,derivs)
      scan1 = e
c
c     store atom gradients as optimization gradient, also
c     translate the coordinates of each atom; the latter
c     may be needed when using periodic boundaries
c
      nvar = 0
      do i = 1, n
         nvar = nvar + 1
         xx(nvar) = x(i)
         g(nvar) = derivs(1,i)
         nvar = nvar + 1
         xx(nvar) = y(i)
         g(nvar) = derivs(2,i)
         nvar = nvar + 1
         xx(nvar) = z(i)
         g(nvar) = derivs(3,i)
      end do
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      integer i,nvar
      integer hinit(maxvar)
      integer hstop(maxvar)
      integer hindex(maxhess)
      real*8 xx(maxvar)
      real*8 hdiag(maxvar)
      real*8 h(maxhess)
      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)
c
c     translate the coordinates of each atom; this
c     may be needed when using periodic boundaries
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
      return
      end
c
c
c     #########################################################
c     ##                                                     ##
c     ##  subroutine modesrch  --  normal mode local search  ##
c     ##                                                     ##
c     #########################################################
c
c
      subroutine modesrch (nmap,emap,range,neigen,grdmin)
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'omega.i'
      include 'refer.i'
      integer maxmap
      parameter (maxmap=100000)
      integer i,k,nmap
      integer neigen,nsearch
      real*8 minimum,grdmin,range
      real*8 step(maxrot)
      real*8 emap(maxmap)
      real*8 eigen(maxrot)
      real*8 vects(maxrot,maxrot)
c
c
c     store the current coordinates as the reference set
c
      call makeref
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
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine eigenrot  --  torsional Hessian eigenvectors  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine eigenrot (eigen,vects)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'omega.i'
      integer i,j,ihess
      real*8 vnorm
      real*8 a(maxrot+1),b(maxrot+1)
      real*8 p(maxrot+1),ta(maxrot+1)
      real*8 w(maxrot+1),tb(maxrot+1)
      real*8 ty(maxrot+1)
      real*8 eigen(maxrot)
      real*8 vects(maxrot,maxrot)
      real*8 hrot(maxrot,maxrot)
      real*8 matrix((maxrot+1)*maxrot/2)
c
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,maxrot,nomega,matrix,eigen,vects,
     &                     a,b,p,w,ta,tb,ty)
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)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'omega.i'
      include 'zcoord.i'
      integer maxstep
      parameter (maxstep=500)
      integer i,kstep
      integer nstep,nsearch
      real*8 minimum,grdmin
      real*8 big,energy,size
      real*8 step(maxrot)
      real*8 estep(0:maxstep)
      logical done
c
c
c     convert current reference coordinates to a Z-matrix
c
      call getref
      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
      dowhile (.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 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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'minima.i'
      integer i,j,nvar
      real*8 minimum,scan1
      real*8 grdmin,big
      real*8 gnorm,grms
      real*8 xx(maxvar)
      real*8 derivs(3,maxatm)
      logical oldverb
      character*6 mode,method
      external scan1,scan2
      external writeout
c
c
c     initialize optimization parameters and output level
c
      iwrite = 0
      iprint = 0
      oldverb = verbose
      verbose = .false.
      big = 100000.0d0
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     use optimization to reach the nearest local minimum
c
      mode = 'auto  '
      method = 'auto  '
      call tncg (mode,method,nvar,xx,minimum,
     &           grdmin,scan1,scan2,writeout)
      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     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
      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 single stochastic dynamics time step
c     via a velocity Verlet integration algorithm
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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'atmtyp.i'
      include 'bath.i'
      include 'mdstuf.i'
      include 'moldyn.i'
      include 'shake.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,istep
      real*8 dt,etot
      real*8 ekin,epot
      real*8 temp,pres
      real*8 xold(maxatm)
      real*8 yold(maxatm)
      real*8 zold(maxatm)
      real*8 pfric(maxatm)
      real*8 vfric(maxatm)
      real*8 afric(maxatm)
      real*8 prand(3,maxatm)
      real*8 vrand(3,maxatm)
      real*8 derivs(3,maxatm)
c
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 new atom
c     positions and half-step velocities via Verlet recursion
c
      do i = 1, n
         if (use(i)) then
            xold(i) = x(i)
            yold(i) = y(i)
            zold(i) = z(i)
            x(i) = x(i) + v(1,i)*vfric(i) + a(1,i)*afric(i) + prand(1,i)
            y(i) = y(i) + v(2,i)*vfric(i) + a(2,i)*afric(i) + prand(2,i)
            z(i) = z(i) + v(3,i)*vfric(i) + a(3,i)*afric(i) + prand(3,i)
            do j = 1, 3
               v(j,i) = v(j,i)*pfric(i) + 0.5d0*a(j,i)*vfric(i)
            end do
         end if
      end do
c
c     apply "rattle" to correct atom positions and velocities
c
      if (use_rattle)  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, n
         if (use(i)) then
            do j = 1, 3
               a(j,i) = -convert * derivs(j,i) / mass(i)
               v(j,i) = v(j,i) + 0.5d0*a(j,i)*vfric(i) + vrand(j,i)
            end do
         end if
      end do
c
c     use "rattle" method to get corrected full-step velocities
c
      if (use_rattle)  call rattle2 (dt)
c
c     sum the total kinetic energy over all atoms
c
      ekin = 0.0d0
      do i = 1, n
         if (use(i)) then
            do j = 1, 3
               ekin = ekin + mass(i)*v(j,i)**2
            end do
         end if
      end do
      ekin = 0.5d0 * ekin / convert
c
c     determine the system temperature and total energy
c
      temp = 2.0d0 * ekin / (dble(nfree) * gasconst)
      etot = ekin + epot
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,ekin,temp,pres)
      call mdsave (istep)
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine sdterm  --  frictional and random SD terms  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "sdterm" gets frictional and random force terms needed to
c     update positions and velocities via stochastic dynamics
c
c
      subroutine sdterm (istep,dt,pfric,vfric,afric,prand,vrand)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'atmtyp.i'
      include 'bath.i'
      include 'stodyn.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,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(maxatm)
      real*8 vfric(maxatm)
      real*8 afric(maxatm)
      real*8 prand(3,maxatm)
      real*8 vrand(3,maxatm)
c
c
c     set the atomic friction coefficients to the global value
c
      do i = 1, n
         gamma(i) = friction
      end do
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, n
         if (use(i)) then
            gdt = gamma(i) * dt
c
c     stochastic dynamics reduces to simple MD for zero friction
c
            if (gdt .le. 0.0d0) then
               pfric(i) = 1.0d0
               vfric(i) = dt
               afric(i) = 0.5d0 * dt * dt
               do j = 1, 3
                  prand(j,i) = 0.0d0
                  vrand(j,i) = 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(i) = egdt
                  vfric(i) = (1.0d0-egdt) / gamma(i)
                  afric(i) = (dt-vfric(i)) / gamma(i)
                  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(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0
     &                          - gdt5/120.0d0 + gdt6/720.0d0
     &                          - gdt7/5040.0d0 + gdt8/40320.0d0
     &                          - gdt9/362880.0d0) / gamma(i)**2
                  vfric(i) = dt - gamma(i)*afric(i)
                  pfric(i) = 1.0d0 - gamma(i)*vfric(i)
                  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 - 3.0d0*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)
               end if
c
c     compute the random terms for the nonzero friction case
c
               ktm = boltzmann * kelvin / mass(i)
               psig = sqrt(ktm*pterm) / gamma(i)
               vsig = sqrt(ktm*vterm)
               rhoc = sqrt(1.0d0 - rho*rho)
               do j = 1, 3
                  pnorm = normal ()
                  vnorm = normal ()
                  prand(j,i) = psig * pnorm
                  vrand(j,i) = vsig * (rho*pnorm+rhoc*vnorm)
               end do
            end if
         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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'atmtyp.i'
      include 'couple.i'
      include 'kvdws.i'
      include 'math.i'
      include 'stodyn.i'
      include 'usage.i'
      integer i,istep
      integer resurf,modstep
      real*8 probe,ratio,area
      real*8 radius(maxatm)
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     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, n
         if (use(i)) then
            if (radius(i) .ne. 0.0d0) then
               call surfatom (i,area,radius)
               ratio = area / (4.0d0*pi*radius(i)**2)
               gamma(i) = ratio * friction
            end if
         end if
      end do
c
c     monovalent atoms with zero radius get attached atom value
c
      do i = 1, n
         if (use(i)) then
            if (radius(i).eq.0.0d0 .and. n12(i).eq.1) then
               gamma(i) = gamma(i12(1,i))
            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 search  --  performs line search for minimum  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "search" is a line search minimizer based upon parabolic
c     extrapolation and cubic interpolation using both function
c     and gradient values; if forced to search in an uphill
c     direction, return is after the initial step
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     cappa    reduction in projected gradient for termination
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     status codes upon return :
c
c     Success     normal termination after satisfying "cappa" test
c     ReSearch    normal termination after a reinterpolation
c     WideAngle   large angle between search and -grad directions
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)
      implicit none
      include 'sizes.i'
      include 'linmin.i'
      include 'math.i'
      integer i,nvar
      integer ncalls,intpln
      real*8 fgvalue,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(maxvar)
      real*8 g(maxvar)
      real*8 p(maxvar)
      real*8 s(maxvar)
      character*9 status
      character*9 blank
      external fgvalue
c
c
c     use default parameters for the line search if needed
c
      blank = '         '
      if (cappa .eq. 0.0d0)  cappa = 0.1d0
      if (stpmin .eq. 0.0d0)  stpmin = 1.0d-20
      if (stpmax .eq. 0.0d0)  stpmax = 2.0d0
      if (angmax .eq. 0.0d0)  angmax = 180.0d0
      if (intmax .eq. 0)  intmax = 5
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 directional gradient
c
      f_0 = f
      sg_0 = 0.0d0
      do i = 1, nvar
         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'
         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
      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 gradient, then test for termination
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
      if (abs(sg_b/sg_0).le.cappa .and. f_b.lt.f_a) then
         f = f_b
         if (status .eq. blank)  status = ' Success '
         return
      end if
c
c     if slope changes or function increases, start interpolation;
c     if the finite difference curvature is negative double the step,
c     else if  step < parabolic estimate < 4*step  use this estimate,
c     else truncate to step or 4*step, respectively
c
      if (sg_a*sg_b.lt.0.0d0 .or. f_a.lt.f_b)  goto 30
      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'
         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'
         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 '
         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 far 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'
         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, return with best point
c
      if (status .eq. ' ReSearch') then
         ncalls = ncalls + 1
         f = fgvalue (x,g)
         status = 'BadIntpln'
         return
      else
         status = ' ReSearch'
         goto 10
      end if
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine setime  --  initialize elapsed CPU time clock  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "setime" initializes the elapsed interval CPU timer
c
c
      subroutine setime
      implicit none
      include 'chrono.i'
c
c
c     initialize interval at elapsed CPU time for current job
c
      call clock (cputim)
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine shakeup  --  setup holonomic constraints  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "shakeup" initializes any holonomic constraints for use
c     with the rattle algorithm during molecular dynamics
c
c
      subroutine shakeup
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'bound.i'
      include 'couple.i'
      include 'keys.i'
      include 'math.i'
      include 'molcul.i'
      include 'shake.i'
      include 'usage.i'
      integer i,j,k,next
      integer ia,ib,ic
      integer ita,itb,itc
      real*8 rab,rbc,rac
      real*8 cosine
      character*9 rattyp
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     zero out the number of rattle distance constraints
c
      nrat = 0
      use_rattle = .true.
c
c     search each line of the keyword file for options
c
      do k = 1, nkey
         next = 1
         record = keyline(k)
         call upcase (record)
         call gettext (record,keyword,next)
c
c     get the distance constraint types for the rattle method
c
         if (keyword(1:7) .eq. 'RATTLE ') then
            call getword (record,rattyp,next)
c
c     constrain all bond lengths to their ideal values
c
            if (rattyp(1:5) .eq. 'BONDS') then
               do i = 1, nbond
                  ia = ibnd(1,i)
                  ib = ibnd(2,i)
                  if (use(ia) .or. use(ib)) then
                     nrat = nrat + 1
                     irat(1,nrat) = ia
                     irat(2,nrat) = ib
                     krat(nrat) = bl(i)
                  end if
               end do
c
c     constrain 1-3 distance across each angle at ideal value
c
            else if (rattyp(1:6) .eq. 'ANGLES') then
               do i = 1, nangle
                  ia = iang(1,i)
                  ib = iang(2,i)
                  ic = iang(3,i)
                  if (use(ia) .or. use(ib) .or. use(ic)) then
                     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)
                     rac = sqrt(rab**2+rbc**2-2.0d0*rab*rbc*cosine)
                     nrat = nrat + 1
                     irat(1,nrat) = ia
                     irat(2,nrat) = ic
                     krat(nrat) = rac
                  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)
                  if (use(ia) .or. use(ib)) then
                     if (n12(ia).eq.1 .and. n12(ib).eq.1) then
                        nrat = nrat + 1
                        irat(1,nrat) = ia
                        irat(2,nrat) = ib
                        krat(nrat) = bl(i)
                     end if
                  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)
                  if (use(ia) .or. use(ib) .or. use(ic)) then
                     if (n12(ia)+n12(ib)+n12(ic) .eq. 4) 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)
                        nrat = nrat + 1
                        irat(1,nrat) = ia
                        irat(2,nrat) = ib
                        krat(nrat) = rab
                        nrat = nrat + 1
                        irat(1,nrat) = ib
                        irat(2,nrat) = ic
                        krat(nrat) = rbc
                        nrat = nrat + 1
                        irat(1,nrat) = ia
                        irat(2,nrat) = ic
                        krat(nrat) = rac
                     end if
                  end if
               end do
c
c     fix bonds and angle of each water to give a rigid molecule
c
            else if (rattyp(1:5) .eq. 'WATER') then
               do i = 1, nangle
                  ia = iang(1,i)
                  ib = iang(2,i)
                  ic = iang(3,i)
                  if (use(ia) .or. use(ib) .or. use(ic)) then
                     ita = atomic(ia)
                     itb = atomic(ib)
                     itc = atomic(ic)
                     if (ita.eq.1 .and. itb.eq.8 .and. itc.eq.1) 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)
                        nrat = nrat + 1
                        irat(1,nrat) = ia
                        irat(2,nrat) = ib
                        krat(nrat) = rab
                        nrat = nrat + 1
                        irat(1,nrat) = ib
                        irat(2,nrat) = ic
                        krat(nrat) = rbc
                        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
               do i = 1, nbond
                  ia = ibnd(1,i)
                  ib = ibnd(2,i)
                  if (use(ia) .or. use(ib)) then
                     ita = atomic(ia)
                     itb = atomic(ib)
                     if (ita.eq.1 .or. itb.eq.1) then
                        nrat = nrat + 1
                        irat(1,nrat) = ia
                        irat(2,nrat) = ib
                        krat(nrat) = bl(i)
                     end if
                  end if
               end do
            end if
c
c     fix a single specified atom pair at the desired distance
c
         else if (keyword(1:12) .eq. 'RATTLE-BOND ') then
            call getnumb (record,ia,next)
            call getnumb (record,ib,next)
            rab = 0.0d0
            string = record(next:80)
            read (string,*,err=10,end=10)  rab
   10       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
            nrat = nrat + 1
            irat(1,nrat) = ia
            irat(2,nrat) = ib
            krat(nrat) = rab
         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
            ratimage(i) = .true.
         else
            ratimage(i) = .false.
         end if
      end do
c
c     if no rattle constraints are used, turn off its use
c
      if (nrat .eq. 0)  use_rattle = .false.
      return
      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)  1994  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine smooth  --  set potential smoothing parameter  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "smooth" sets extent of potential surface deformation for use
c     with potential smoothing plus search, the diffusion equation
c     method or Gaussian density annealing
c
c
      subroutine smooth
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'fields.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'warp.i'
      integer i,next
      logical query,exist
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     set the default value for the deformation parameter
c
      deform = 0.0d0
c
c     set default values for the diffusion coefficients
c
      difft = 0.0225d0
      diffv = 1.0d0
      diffc = 1.0d0
c
c     set a flag to determine use of smoothed potentials
c
      if (forcefield .eq. 'SMOOTH') then
         use_deform = .true.
         query = .true.
      else
         use_deform = .false.
         query = .false.
      end if
c
c     get keyword containing the deformation parameter value
c
      if (query) then
         do i = 1, nkey
            next = 1
            record = keyline(i)
            call gettext (record,keyword,next)
            call upcase (keyword)
            if (keyword(1:7) .eq. 'DEFORM ') then
               query = .false.
               string = record(next:80)
               read (string,*,err=10)  deform
            end if
   10       continue
         end do
      end if
c
c     try to get the deformation value from the command line
c
      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
   30    continue
         if (use_gda) then
            deform = 200.0d0
            write (iout,40)
   40       format (/,' Enter the Initial Mean Squared Gaussian',
     &                 ' Width [200.0] :  ',$)
         else
            write (iout,50)
   50       format (/,' Enter the Potential Surface Smoothing',
     &                 ' Parameter [0.0] :  ',$)
         end if
         read (input,60)  record
   60    format (a80)
         read (record,*,err=30,end=70)  deform
   70    continue
      end if
c
c     get keywords containing diffusion coefficients
c
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:16) .eq. 'DIFFUSE-TORSION ') then
            string = record(next:80)
            read (string,*,err=80)  difft
         else if (keyword(1:12) .eq. 'DIFFUSE-VDW ') then
            string = record(next:80)
            read (string,*,err=80)  diffv
         else if (keyword(1:15) .eq. 'DIFFUSE-CHARGE ') then
            string = record(next:80)
            read (string,*,err=80)  diffc
         end if
   80    continue
      end do
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)  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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'linmin.i'
      include 'math.i'
      include 'minima.i'
      include 'output.i'
      include 'scales.i'
      include 'usage.i'
      integer i,j,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 xx(maxvar)
      real*8 g(maxvar)
      real*8 d(maxvar)
      real*8 derivs(3,maxatm)
      logical exist,done
      character*9 status
      character*60 minfile
      character*80 string
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
      call makeref
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 (f20.0)
      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     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, n
         if (use(i)) then
            do j = 1, 3
               nvar = nvar + 1
               scale(nvar) = scaler
            end do
         end if
      end do
c
c     scale the coordinates of each active atom
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            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 if
      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
      dowhile (.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, 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
               call makeref
               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 writeout (xx,niter)
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
c
c     write out final function value and gradient
c
      call gradient (minimum,derivs)
      gnorm = 0.0d0
      do i = 1, n
         if (use(i)) then
            do j = 1, 3
               gnorm = gnorm + derivs(j,i)**2
            end do
         end if
      end do
      gnorm = sqrt(gnorm)
      grms = gnorm / rms
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'scales.i'
      include 'usage.i'
      integer i,nvar
      real*8 sniffer1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(3,maxatm)
c
c
c     translate 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     compute and store the energy and gradient
c
      call gradient (e,derivs)
      sniffer1 = e
c
c     store atom gradients as optimization gradient, also
c     translate the coordinates of each active atom; the
c     latter may be needed when using periodic boundaries
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            xx(nvar) = x(i) * scale(nvar)
            g(nvar) = derivs(1,i) / scale(nvar)
            nvar = nvar + 1
            xx(nvar) = y(i) * scale(nvar)
            g(nvar) = derivs(2,i) / scale(nvar)
            nvar = nvar + 1
            xx(nvar) = z(i) * scale(nvar)
            g(nvar) = derivs(3,i) / scale(nvar)
         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 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
      dowhile (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
         dowhile (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
      dowhile (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
         dowhile (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
      dowhile (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
         dowhile (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
      dowhile (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
         dowhile (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
      dowhile (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
         dowhile (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
      dowhile (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
         dowhile (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
      dowhile (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
         dowhile (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
      dowhile (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
         dowhile (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 text strings  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "sort9" 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 sort9 (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
      dowhile (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
         dowhile (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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kvdws.i'
      include 'math.i'
      include 'usage.i'
      integer i,ixyz,next
      integer mode,frame
      integer freeunit
      real*8 volume,area,value
      real*8 probe,exclude
      real*8 radius(maxatm)
      logical exist,query
      character*1 answer
      character*60 xyzfile
      character*80 record
      character*80 string
c
c
c     get the Cartesian coordinates for the system
c
      call initial
      call getxyz
c
c     determine the atoms to be used in computation;
c     radii can be changed via the keyword mechanism
c
      call field
      call active
      call katom
      call kvdw
c
c     turn on extra printing of output information
c
      debug = .true.
      verbose = .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
      probe = 0.0d0
      exclude = 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)  probe = 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 (a80)
         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     set each atomic radius to the Lennard-Jones sigma value
c
      do i = 1, n
         if (use(i)) then
            radius(i) = rad(class(i)) / twosix
         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')
      call version (xyzfile,'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
      dowhile (.not. abort)
         frame = frame + 1
         if (frame .gt. 1) then
            write (iout,100)  frame
  100       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 (volume,area,radius,probe,exclude)
c
c     print out the values of the total surface area and volume
c
         write (iout,110)  area
  110    format (/,' Total Area :',f20.3,' Square Angstroms')
         write (iout,120)  volume
  120    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 any final tasks before program exit
c
      close (unit=ixyz)
      debug = .false.
      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
      implicit none
      include 'files.i'
      include 'iounit.i'
      include 'math.i'
      include 'units.i'
      integer maxvel,maxfreq
      parameter (maxvel=20000)
      parameter (maxfreq=5000)
      integer i,k,nsamp
      integer ivel,nvel
      integer freeunit
      real*8 factor,aver,norm
      real*8 step,freq,time
      real*8 vel(0:maxvel)
      real*8 intense(maxfreq)
      logical exist,done
      character*60 velfile
      character*80 record
      character*80 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')
         call version (velfile,'old')
         inquire (file=velfile,exist=exist)
      end if
c
c     ask for the velocity autocorrelation data filename
c
      dowhile (.not. exist)
         write (iout,10)
   10    format (/,' Enter Name of Velocity Autocorrelation',
     &              ' File :  ',$)
         read (input,20)  velfile
   20    format (a60)
         call basefile (velfile)
         call suffix (velfile,'vel')
         call version (velfile,'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.
      dowhile (.not. done)
         read (ivel,60)  record
   60    format (a80)
         if (record(4:13) .eq. 'Separation') then
            done = .true.
            read (ivel,70)
   70       format ()
         end if
      end do
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 (a80)
         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
      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
c     the IMSL routine BCLSF and More's Minpack routine LMDER; the
c     Jacobian is estimated by finite differences and bounds can
c     be specified for the variables to be refined
c
c     arguments and variables :
c
c     n        number of variables to optimize
c     m        number of residual functions
c     xlo      vector of length n containing the lower bounds for
c                the variables
c     xhi      vector of length n containing the upper bounds for
c                the variables
c     xscale   vector of length n containing the diagonal scaling
c                matrix for the variables
c     xc       vector of length n containing the variable values
c                at the approximate solution
c     fc       vector of length m containing the residuals at the
c                approximate solution
c     fp       vector of length m containing the updated residual
c     xp       vector of length n containing the updated point
c     sc       vector of length n containing the last step taken
c     gc       vector of length n containing an estimate of
c                the gradient at the approximate solution
c     fjac     real m by n matrix containing an estimate of
c                the Jacobian at the approximate solution
c     mdim     leading dimension of fjac exactly as specified in
c                the dimension statement of the calling program
c     iactive  integer vector of length n indicating if xc(i) had
c                to be moved to an upper or lower bound
c     ipvt     vector of length n containing the permutation matrix
c                used in the QR factorization of the Jacobian at
c                the approximate solution
c     stpmax   real scalar containing the maximum allowed step size
c     delta    real scalar containing the trust region radius
c
c     required external routines :
c
c     rsdvalue   subroutine to evaluate residual function values
c     writeout   subroutine to write out info about current status
c
c
      subroutine square (m,n,xlo,xhi,xc,fc,gc,fjac,mdim,
     &                      grdmin,rsdvalue,writeout)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'minima.i'
      integer maxlsq,maxrsd
      parameter (maxlsq=50)
      parameter (maxrsd=100)
      integer i,j,k
      integer icode,next
      integer niter,ncalls
      integer nactive
      integer m,n,mdim
      integer nbigstp,ndigit
      integer iactive(maxlsq)
      integer ipvt(maxlsq)
      real*8 amu,delta,epsfcn
      real*8 fcnorm,fpnorm
      real*8 gcnorm,ganorm
      real*8 precise,eps
      real*8 grdmin,stpnorm
      real*8 stpmax,stpmin
      real*8 rftol,faketol
      real*8 xtemp,stepsz
      real*8 sum,temp
      real*8 xc(maxlsq)
      real*8 xlo(maxlsq)
      real*8 xhi(maxlsq)
      real*8 fc(maxrsd),gc(maxlsq)
      real*8 fjac(mdim,maxlsq)
      real*8 xp(maxlsq),fp(maxrsd)
      real*8 ga(maxlsq),gs(maxlsq)
      real*8 sc(maxlsq),sa(maxlsq)
      real*8 ftemp(maxrsd)
      real*8 xscale(maxlsq)
      real*8 xsa(maxlsq)
      real*8 rdiag(maxlsq)
      real*8 qtf(maxlsq)
      real*8 work(maxlsq)
      logical done,first
      logical gauss,bigstp
      character*20 keyword
      character*80 record
      external rsdvalue
      external writeout
      external precise
c
c
c     check for too many variables or residuals
c
      if (n .gt. maxlsq) then
         write (iout,10)
   10    format (/,' SQUARE  --  Too many Parameters,',
     &              ' Increase value of MAXLSQ')
         return
      else if (m .gt. maxrsd) then
         write (iout,20)
   20    format (/,' SQUARE  --  Too many Residuals,',
     &              ' Increase value of MAXRSD')
         return
      end if
c
c     initialize various counters and status code
c
      niter = 0
      ncalls = 0
      nbigstp = 0
      done = .false.
c
c     setup the default tolerances and parameter values
c
      eps = precise (2)
      ndigit = 10
      if (eps .lt. 10.0d0**(-ndigit)) then
         eps = 10.0d0**(-ndigit)
      end if
      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)
      epsfcn = sqrt(eps)
      delta = 0.0d0
      stpmax = 1000.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)
         if (keyword(1:7) .eq. 'FCTMIN ') then
            read (record(next:80),*,err=30)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (record(next:80),*,err=30)  maxiter
         else if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (record(next:80),*,err=30)  iprint
         else if (keyword(1:9) .eq. 'WRITEOUT ') then
            read (record(next:80),*,err=30)  iwrite
         end if
   30    continue
      end do
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 (m,n,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 = epsfcn * abs(xc(j))
         if (stepsz .lt. epsfcn)  stepsz = epsfcn
         if (xc(j) .lt. 0.0d0)  stepsz = -stepsz
         xtemp = xc(j)
         xc(j) = xtemp + stepsz
         ncalls = ncalls + 1
         call rsdvalue (m,n,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/n)
      if (nactive .ne. 0)  ganorm = sqrt(ganorm/nactive)
c
c     print out information about initial conditions
c
      if (iprint .gt. 0) then
         write (iout,40)
   40    format (/,' Levenberg-Marquardt Nonlinear Least Squares :')
         write (iout,50)
   50    format (/,' LS Iter    F Value      Total G     Active G',
     &              '    N Active   F Calls',/)
         if (max(fcnorm,gcnorm) .lt. 10000000.0d0) then
            write (iout,60)  niter,fcnorm,gcnorm,ganorm,nactive,ncalls
   60       format (i6,3f13.4,2i10)
         else
            write (iout,70)  niter,fcnorm,gcnorm,ganorm,nactive,ncalls
   70       format (i6,3d13.4,2i10)
         end if
      end if
c
c     write out the parameters, derivatives and residuals
c
      if (iwrite .eq. 1) then
         if (.not. done)  call writeout (niter,xc,gs,m,fc)
      end if
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     start of the main body of least squares iteration
c
   80 continue
      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
      call qrfact (m,nactive,fjac,mdim,.true.,ipvt,rdiag,work)
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.
      dowhile (icode .ge. 4)
         call lmstep (nactive,ga,fjac,mdim,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 (rsdvalue,m,n,xc,fcnorm,gc,fjac,mdim,ipvt,sc,sa,
     &               xscale,gauss,stpmax,delta,icode,xp,fc,fp,fpnorm,
     &               bigstp,ncalls,xlo,xhi,nactive,stpmin,rftol,faketol)
      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     update the active vs inactive status of the variables;
c     in a true active set strategy, at most one constraint
c     is added to the active set per iteration
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
c              goto 110
            else if (abs(xc(j)-xhi(j)) .le. eps) then
               nactive = nactive - 1
               iactive(j) = 1
c              goto 110
            end if
         end if
      end do
   90 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 = epsfcn * 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 (m,n,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) = 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/n)
      if (nactive .ne. 0)  ganorm = sqrt(ganorm/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,100)  niter,fcnorm,gcnorm,ganorm,nactive,ncalls
  100       format (i6,3f13.4,2i10)
         else
            write (iout,110)  niter,fcnorm,gcnorm,ganorm,nactive,ncalls
  110       format (i6,3d13.4,2i10)
         end if
      end if
c
c     check stopping criteria at the new point; test the absolute
c     function value, the gradient norm and step 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/n)
      if (stpnorm .le. stpmin)  done = .true.
c
c     check for inactive variables that can be made active;
c     in a true active set strategy, variables are released
c     one at a time at a minimum of the current active set
c
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.
c                 goto 140
            else if (iactive(j).eq.1 .and. gc(j).gt.0.0d0) then
               nactive = nactive + 1
               iactive(j) = 0
               done = .false.
c                 goto 140
            end if
         end do
  120    continue
      end if
c     end if
c
c     if still done, then normal termination has been achieved
c
      if (done) then
         write (iout,130)
  130    format (/,' SQUARE  --  Normal Termination of Least Squares')
      end if
c
c     check the limit on the number of iterations
c
      if (niter .ge. maxiter) then
         done = .true.
         write (iout,140)
  140    format (/,' SQUARE  --  Maximum Number of Allowed Iterations')
      end if
c
c     check relative function convergence and false convergence
c
      if (icode .eq. 2) then
         done = .true.
         write (iout,150)
  150    format (/,' SQUARE  --  Relative Function Convergence',
     &           //,' Both the scaled actual and predicted',
     &              ' reductions in the function',
     &           /,' are less than or equal to the relative',
     &              ' convergence tolerance')
      else if (icode .eq. 3) then
         done = .true.
         write (iout,160)
  160    format (/,' SQUARE  --  Possible False Convergence',
     &           //,' 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
      if (bigstp) then
         nbigstp = nbigstp + 1
         if (nbigstp .eq. 5) then
            done = .true.
            write (iout,170)
  170       format (/,' SQUARE  --  Five Consecutive Maximum',
     &                 ' Length Steps',
     &              //,' Either the function is unbounded below,',
     &                 ' or has a finite',
     &              /,' asymptote in some direction, or STEPMAX',
     &                 ' is too small')
         end if
      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 writeout (niter,xc,gs,m,fc)
      end if
c
c     continue with the next iteration if not finished
c
      if (.not. done)  goto 80
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine lmstep  --  finds Levenberg-Marquardt step  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "lmstep" computes the Levenberg-Marquardt step during a
c     nonlinear least squares calculation; this version is based
c     upon ideas from the Minpack routine LMPAR together with
c     with the internal doubling strategy of Dennis and Schnabel
c
c     arguments and variables :
c
c     n        dimension of the problem
c     ga       real vector of length n containing the gradient
c                of the residual vector
c     a        real n by n array which on input contains in the full
c                upper triangle the upper triangle of the matrix r
c                resulting from the QR factorization of the Jacobian;
c                on output the full upper triangle is unaltered, and
c                the strict lower triangle contains the strict lower
c                triangle of the lower triangular matrix l which is
c                equal to the Cholesky factor of (j**t)*j + amu*xscale
c     lda      leading dimension of a exactly as specified in the
c                dimension statement of the calling program
c     ipvt     integer array of length n containing the pivoting
c                infomation from the QR factorization routine
c     xscale   real vector of length n containing the diagonal
c                scaling matrix for the variables
c     qtf      real vector containing the first n elements of
c                Q(transpose) * (the scaled residual vector)
c     amu      scalar containing an initial estimate of the
c                Levenberg-Marquardt parameter on input; on
c                output, amu contains the final estimate of
c                the Levenberg-Marquardt parameter
c     first    logical variable set true only if this is the first
c                call to this routine in this iteration
c     sa       real vector of length n containing the
c                Levenberg-Marquardt step
c     gnstep   real vector of length n containing the
c                Gauss-Newton step
c     gauss    logical variable which is true if the Gauss-Newton
c                step is acceptable, and is false otherwise
c     diag     vector of length n containing the diagonal elements
c                of the Cholesky factor of (j**t)*j + amu*xscale
c
c
      subroutine lmstep (n,ga,a,lda,ipvt,xscale,qtf,stpmax,
     &                       delta,amu,first,sa,gauss)
      implicit none
      integer maxlsq,maxrsd
      parameter (maxlsq=50)
      parameter (maxrsd=100)
      integer i,j,k,n
      integer lda,nsing
      integer ipvt(maxlsq)
      real*8 stpmax,delta,amu
      real*8 alow,alpha
      real*8 amulow,amuhi
      real*8 beta,small,sum
      real*8 deltap,gnleng
      real*8 phi,phip,phipi
      real*8 sgnorm,precise
      real*8 high,tiny
      real*8 stplen,temp
      real*8 ga(maxlsq)
      real*8 a(lda,maxlsq)
      real*8 xscale(maxlsq)
      real*8 qtf(maxlsq)
      real*8 sa(maxlsq)
      real*8 gnstep(maxlsq)
      real*8 diag(maxlsq)
      real*8 work1(maxlsq)
      real*8 work2(maxlsq)
      logical first,gauss
      logical done
      save deltap,nsing
      save phi,phip
      external precise
c
c
c     set smallest floating point magnitude and spacing
c
      tiny = precise (1)
      small = precise (2)
c
c     if initial trust region is not provided by the user,
c     compute and use the length of the Cauchy step given
c     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. tiny) then
            delta = alpha * sqrt(alpha)
         else
            delta = alpha * sqrt(alpha)/beta
         end if
         delta = min(delta,stpmax)
      end if
c
c     the following is done only on the first time through
c     this iteration: (1) compute the Gauss-Newton step;
c     if the Jacobian is rank-deficient, obtain a least
c     squares solution, (2) compute the length of the scaled
c     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 the bounds on the computed step
c
      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
c     system of 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
         done = .false.
         dowhile (.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 for the value of the
c     Levenberg-Marquardt step using More's Minpack technique
c
            call qrsolve (n,a,lda,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. tiny) 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 to see if the step is acceptable; if not,
c     update amulow, amuhi and amu for next iteration
c
            if ((stplen.ge.alow*delta.and.stplen.le.high*delta)
     &            .or. (amuhi-amulow).le.small) 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
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine qrfact  --  QR factorization of a matrix  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "qrfact" performs Householder transformations with column
c     pivoting (optional) to compute a QR factorization of the
c     m by n matrix a; the routine determines an orthogonal
c     matrix q, a permutation matrix p, and an upper trapezoidal
c     matrix r with diagonal elements of nonincreasing magnitude,
c     such that a*p = q*r; the Householder transformation for
c     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     m        positive integer input variable set to
c                the number of rows of a
c     n        positive integer input variable set to
c                the number of columns of a
c     a        m by n array; on input a contains the matrix for
c                which the QR factorization is to be computed; on
c                output the strict upper trapezoidal part contains
c                the strict upper trapezoidal part of r, the lower
c                trapezoidal part contains a factored form of q
c                (non-trivial elements of u vectors described above)
c     lda      positive integer input variable not less than m
c                which specifies the leading dimension of array a
c     pivot    logical input variable; if pivot is set true,
c                then column pivoting is enforced; if pivot is
c                set false, then no column pivoting is done
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    an output array of length n which contains
c                the diagonal elements of r
c
c
      subroutine qrfact (m,n,a,lda,pivot,ipvt,rdiag,work)
      implicit none
      integer i,j,k,jmax
      integer m,n,lda
      integer minmn,itemp
      integer ipvt(n)
      real*8 aknorm,temp
      real*8 rdiag(n),work(n)
      real*8 a(lda,n)
      logical pivot
c
c
c     find the initial column norms and initialize some arrays
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     reduce the matrix with Householder transformations
c
      minmn = min(m,n)
      do k = 1, minmn
c
c     bring the column of largest norm into the pivot position
c
         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 the transformation to the remaining columns
c     and update the 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
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine qrsolve  --  get least squares via QR factors  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "qrsolve" solves a*x=b and d*x=0 in the least squares sense;
c     normally used in combination with routine "qrfact" to solve
c     least squares problems
c
c     arguments and variables :
c
c     n        number of rows and columns in the matrix r
c     r        an n by n array containing 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     ldr      leading dimension of r exactly as specified in
c                the dimension statement of the calling program
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, d*x = 0
c     sdiag    vector of length n containing the diagonal elements
c                of the upper triangular matrix s
c
c
      subroutine qrsolve (n,r,ldr,ipvt,diag,qtb,x,sdiag,work)
      implicit none
      integer i,j,k,jj
      integer nsing,n,ldr
      integer ipvt(n)
      real*8 sine,cosine
      real*8 tangent
      real*8 cotangent
      real*8 qtbpj,temp
      real*8 diag(n),qtb(n)
      real*8 x(n),sdiag(n)
      real*8 work(n)
      real*8 r(ldr,n)
c
c
c     copy r and (q transpose)*b to preserve input and
c     initialize s; in particular, save the diagonal
c     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)
         work(j) = qtb(j)
      end do
c
c     eliminate the diagonal matrix d using a Givens rotation
c
      do j = 1, n
c
c     prepare the row of d to be eliminated, locating
c     the diagonal element using p from the QR factorization
c
         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     the transformations to eliminate the row of d modify
c     only a single element of (q transpose)*b beyond the
c     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*work(k) + sine*qtbpj
                  qtbpj = -sine*work(k) + cosine*qtbpj
                  work(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 element of r
c
         sdiag(j) = r(j,j)
         r(j,j) = x(j)
      end do
c
c     solve the triangular system for z; 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)  work(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)*work(i)
               end do
            end if
            work(j) = (work(j)-temp) / sdiag(j)
         end do
      end if
c
c     permute the components of z back to components of x
c
      do j = 1, n
         k = ipvt(j)
         x(k) = work(j)
      end do
      return
      end
c
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine trust  --  update the model trust region  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "trust" updates the model trust region for a nonlinear
c     least squares calculation; this version is based on the
c     ideas found in NL2SOL and in Dennis and Schnabel's book
c
c     arguments and variables :
c
c     m        number of functions
c     n        number of variables
c     xc       vector of length n containing the current iterate
c     fcnorm   real scalar containing the norm of f(xc)
c     gc       vector of length n containing 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     lda      leading dimension of A exactly as specified in
c                the dimension statement of the calling program
c     ipvt     integer vector of length n containing the permutation
c                matrix from QR factorization of the Jacobian
c     sc       vector of length n containing the Newton step
c     sa       vector of length n containing current step
c     xscale   vector of length n containing the diagonal
c                scaling matrix for x
c     gauss    logical variable equal is true when the Gauss-Newton
c                step is taken
c     stpmax   maximum allowable step size
c     delta    trust region radius with value retained between calls
c     icode    return code set upon exit
c                0  means xp accepted as next iterate, delta
c                     is trust region for next iteration
c                1  means the algorithm was unable to find a
c                     satisfactory xp sufficiently distinct from xc
c                2  means both the scaled actual and predicted
c                     function reductions are smaller than rftol
c                3  means that false convergence is detected
c                4  means fpnorm is too large, current iteration is
c                     continued with a new, reduced trust region
c                5  means fpnorm is sufficiently small, but the
c                     chance of taking a longer successful step
c                     seems good that the current iteration is to
c                     be continued with a new, doubled trust region
c     xpprev   vector of length n containing the value of xp
c                at the previous call within this iteration
c     fpprev   vector of length m containing f(xpprev)
c     xp       vector of length n containing the new iterate
c     fp       vector of length m containing the functions at xp
c     fpnorm   scalar containing the norm of f(xp)
c     bigstp   logical variable; true, if maximum step length was taken,
c                false  otherwise
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 (rsdvalue,m,n,xc,fcnorm,gc,a,lda,ipvt,sc,sa,
     &                  xscale,gauss,stpmax,delta,icode,xp,fc,fp,
     &                  fpnorm,bigstp,ncalls,xlo,xhi,nactive,stpmin,
     &                  rftol,faketol)
      implicit none
      integer maxlsq,maxrsd
      parameter (maxlsq=50)
      parameter (maxrsd=100)
      integer i,j,k,m,n
      integer lda,icode
      integer ncalls,nactive
      integer ipvt(maxlsq)
      real*8 fcnorm,stpmax
      real*8 delta,fpnorm,fpnrmp
      real*8 reduce,predict
      real*8 rellen,slope,tiny
      real*8 stplen,stpmin
      real*8 rftol,faketol
      real*8 alpha,temp,precise
      real*8 xc(maxlsq),gc(maxlsq)
      real*8 a(lda,maxlsq)
      real*8 sc(maxlsq),sa(maxlsq)
      real*8 xp(maxlsq)
      real*8 fc(maxrsd),fp(maxrsd)
      real*8 xlo(maxlsq),xhi(maxlsq)
      real*8 xscale(maxlsq)
      real*8 xpprev(maxlsq)
      real*8 fpprev(maxrsd)
      logical gauss,bigstp
      logical feas,ltemp
      save xpprev,fpprev
      save fpnrmp
      external rsdvalue
      external precise
c
c
c     set value of alpha, logicals and step length
c
      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 (m,n,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
            tiny = precise (1)
            if (abs(reduce-slope) .gt. tiny) then
               temp = -slope*stplen / (2.0d0*(reduce-slope))
            else
               temp = -slope*stplen / 2.0d0
            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; the step is acceptable compute
c     the predicted reduction as predict = g(T)*s + (1/2)*s(T)*h*s
c     with h = p * r**t * r * p**t
c
      else
         predict = slope
         do i = 1, nactive
            k = ipvt(i)
            temp = 0.0d0
            do j = i, nactive
               temp = temp + sa(k)*a(i,j)
            end do
            predict = predict + 0.5d0*temp**2
         end do
         ltemp = (abs(predict-reduce) .le. 0.1d0*abs(reduce))
c
c     if reduce and predict agree to within relative error of 0.1
c     or if negative curvature is indicated, and a longer step is
c     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*predict) then
               delta = 0.5d0 * delta
            else if (reduce .le. 0.75d0*predict) 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*predict) then
            if (abs(reduce).le.rftol*abs(fcnorm) .and.
     &          abs(predict).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)  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
c     extension, and appends an extension if none is found
c
c
      subroutine suffix (filename,extension)
      implicit none
      integer i,leng,lext
      integer last,trimtext
      logical exist
      character*1 letter
      character*(*) filename
      character*(*) extension
c
c
c     get the length of the current filename
c
      leng = trimtext (filename)
      lext = trimtext (extension)
c
c     check for an extension on the current filename
c
      last = leng
      do i = 1, leng
         letter = filename(i:i)
         if (letter .eq. '/')  last = leng
c        if (letter .eq. '\')  last = leng
         if (ichar(letter) .eq. 92)  last = leng
         if (letter .eq. ']')  last = leng
         if (letter .eq. ':')  last = leng
         if (letter .eq. '~')  last = leng
         if (letter .eq. '.')  last = i - 1
      end do
      if (last .ne. leng)  return
c
c     append extension if current name does not exist
c
      exist = .false.
      if (leng .ne. 0)  inquire (file=filename(1:leng),exist=exist)
      if (.not. exist) then
         filename = filename(1:leng)//'.'//extension(1:lext)
      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
      implicit none
      include 'sizes.i'
      include 'align.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'titles.i'
      integer i,ixyz,next
      integer n1,i1,n2,i2
      integer leng1,leng2
      integer ifile1,ifile2
      integer frame1,frame2
      integer start,stop
      integer option,delta
      integer trimtext,freeunit
      integer range(4)
      integer atomic1(maxatm)
      integer atomic2(maxatm)
      real*8 dist,cutoff
      real*8 rmsvalue
      real*8 mass1(maxatm)
      real*8 mass2(maxatm)
      real*8 x1(maxatm),x2(maxatm)
      real*8 y1(maxatm),y2(maxatm)
      real*8 z1(maxatm),z2(maxatm)
      logical header,exist
      logical query,skip,same
      character*1 answer
      character*3 name1(maxatm)
      character*3 name2(maxatm)
      character*60 file1,file2
      character*60 coordfile
      character*80 record
      character*80 string
c
c
c     get atom names and masses for the first structure type
c
      call initial
      call getxyz
      call field
      call katom
      file1 = filename
      leng1 = trimtext(file1)
      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 type
c
      call getxyz
      call field
      call katom
      file2 = filename
      leng2 = trimtext(file2)
      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',
     &              ' [<CR>=1,0,0]) :  ',$)
         read (input,40)  record
   40    format (a80)
         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     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 (a80)
            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
         dowhile (.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 (a80)
            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 weighting to use for the coordinates
c
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,140)
  140    format (/,' Use Mass- or Unit-Weighted Coordinates',
     &              ' (M or [U]) :  ',$)
         read (input,150)  record
  150    format (a80)
         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
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,160)
  160    format (/,' Write Best-Fit Coordinates of 2nd Molecule',
     &              ' [N] :  ',$)
         read (input,170)  record
  170    format (a80)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
c
c     chose cutoff value for output of atom pair deviations
c
      cutoff = -1.0d0
      call nextarg (string,exist)
      if (exist)  read (string,*,err=180,end=180)  cutoff
  180 continue
      if (cutoff .lt. 0.0d0) then
         write (iout,190)
  190    format (/,' Cutoff Value for Listing RMS Deviations',
     &              ' [0.0] :  ',$)
         read (input,200)  cutoff
  200    format (f20.0)
      end if
c
c     information about structures to be superimposed
c
      write (iout,210)  file1(1:leng1)
  210 format (/,' Structure File 1 :  ',a)
      write (iout,220)  file2(1:leng2)
  220 format (/,' Structure File 2 :  ',a)
c
c     reopen the coordinate files with structures to superimpose
c
      ifile1 = freeunit ()
      call suffix (file1,'xyz')
      call version (file1,'old')
      open (unit=ifile1,file=file1,status ='old')
      rewind (unit=ifile1)
      if (file1 .eq. file2) then
         same = .true.
         ifile2 = ifile1
      else
         same = .false.
         ifile2 = freeunit ()
         call suffix (file2,'xyz')
         call version (file2,'old')
         open (unit=ifile2,file=file2,status ='old')
         rewind (unit=ifile2)
      end if
c
c     read initial structure set from the first coordinate file
c
      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
      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
      dowhile (.not. abort)
         write (iout,230)  frame1,frame2
  230    format (/,' File 1 Frame :',i6,13x,'File 2 Frame :',i6)
         write (iout,240)
  240    format (/,' Summary of Results from Structural',
     &              ' Superposition :')
         verbose = .true.
         call impose (n1,x1,y1,z1,n2,x2,y2,z2,rmsvalue)
         write (iout,250)  rmsvalue,frame1,frame2
  250    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)
            dist = sqrt((x1(i1)-x2(i2))**2 + (y1(i1)-y2(i2))**2
     &                         + (z1(i1)-z2(i2))**2)
            if (dist .ge. cutoff) then
               if (header) then
                  header = .false.
                  write (iout,260)
  260             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,270)  i1,name1(i1),i2,name2(i2),dist,wfit(i)
  270          format (5x,i5,'-',a3,11x,i5,'-',a3,7x,f13.6,4x,f12.4)
            end if
         end do
         if (.not. header) then
            write (iout,280)  rmsvalue
  280       format (/,' Root Mean Square Distance :',11x,f15.6)
         end if
c
c     create output file for superimposed second structure
c
         if (answer .eq. 'Y') then
            do i = 1, n
               x(i) = x2(i)
               y(i) = y2(i)
               z(i) = z2(i)
            end do
            ixyz = freeunit ()
            coordfile = file2(1:leng)//'.xyz'
            call version (coordfile,'new')
            open (unit=ixyz,file=coordfile,status='new')
            call prtxyz (ixyz)
            close (unit=ixyz)
         end if
c
c     attempt to get next structure pair from coordinate files
c
         frame2 = frame2 + 1
         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 (same) 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
               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 any final tasks before program exit
c
      close (unit=ifile1)
      if (.not. same)  close (unit=ifile2)
      call final
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine surface  --  accessible surface area & derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "surface" 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
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     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     radius   radii of the individual atoms
c     weight   weight assigned to each atom's area; if set to
c                1.0, return is actual area in square Angstroms
c     probe    radius of the probe sphere
c     delta    tolerance used in the tests for sphere overlaps
c                and for colinearity
c     rmove    connectivity errors can usually be avoided if the
c                offending atom is shifted by this small amount
c
c
      subroutine surface (total,area,darea,radius,weight,probe)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'usage.i'
      integer maxarc
      parameter (maxarc=300)
      integer i,j,k,l,m
      integer ii,ib,jb
      integer in,io,ir
      integer mi,ni,narc
      integer ider(maxarc)
      integer sign_yder(maxarc)
      integer key(maxarc)
      integer intag(maxarc)
      integer intag1(maxarc)
      real*8 total,wght
      real*8 delta,delta2
      real*8 eps,rmove
      real*8 probe,arcsum,cosine
      real*8 dsql,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 area(maxatm)
      real*8 darea(3,maxatm)
      real*8 radius(maxatm)
      real*8 r(maxatm)
      real*8 weight(maxatm)
      real*8 ux(maxarc),uy(maxarc)
      real*8 uz(maxarc)
      real*8 xc(maxarc),yc(maxarc)
      real*8 zc(maxarc)
      real*8 xc1(maxarc),yc1(maxarc)
      real*8 zc1(maxarc)
      real*8 dsq(maxarc),bsq(maxarc)
      real*8 b(maxarc)
      real*8 arci(maxarc),arcf(maxarc)
      real*8 ex(maxarc),lt(maxarc)
      real*8 kent(maxarc),kout(maxarc)
      real*8 bg(maxarc),ther(maxarc)
      real*8 ri(maxarc),risq(maxarc)
      real*8 b1(maxarc),dsq1(maxarc)
      real*8 bsq1(maxarc),gr(maxarc)
      logical moved,top,komit
      logical skip(maxatm)
      logical omit(maxarc)
c
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) = radius(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 = pi / 2.0d0
      delta = 1.0d-8
      delta2 = delta**2
      eps = 1.0d-8
      rmove = 1.0d-8
      do i = 1, maxarc
         ider(i) = 0
         sign_yder(i) = 0
      end do
c
c     set the "skip" array to exclude all inactive atoms
c     that do not overlap any of the current active atoms
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**2
         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 overlap of spheres by testing center to
c     center 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 (/,' SURFACE  --  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 = tk2
                        tf = tk1
                     end if
                     narc = narc + 1
                     if (narc .ge. maxarc) then
                        write (iout,70)
   70                   format (/,' SURFACE  --  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 (/,' SURFACE  --  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 (/,' SURFACE  --  Connectivity Error at Atom',i6)
         else
            moved = .true.
            xr = xr + rmove
            yr = yr + rmove
            zr = zr + rmove
            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 (/,' SURFACE  --  Negative Area at Atom',i6)
            else
               moved = .true.
               xr = xr + rmove
               yr = yr + rmove
               zr = zr + rmove
               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
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'math.i'
      integer maxarc
      parameter (maxarc=300)
      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)
      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(maxatm)
      real*8 ri(maxarc),risq(maxarc)
      real*8 ux(maxarc),uy(maxarc),uz(maxarc)
      real*8 xc(maxarc),yc(maxarc),zc(maxarc)
      real*8 xc1(maxarc),yc1(maxarc),zc1(maxarc)
      real*8 dsq(maxarc),bsq(maxarc)
      real*8 dsq1(maxarc),bsq1(maxarc)
      real*8 arci(maxarc),arcf(maxarc)
      real*8 ex(maxarc),lt(maxarc),gr(maxarc)
      real*8 b(maxarc),b1(maxarc),bg(maxarc)
      real*8 kent(maxarc),kout(maxarc)
      real*8 ther(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     ##  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)
      implicit none
      include 'cutoff.i'
      include 'shunt.i'
      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 .eq. 'CHARGE') then
         off = chgcut
         cut = chgtaper
      else if (mode .eq. 'CHGDPL') then
         off = sqrt(chgcut*dplcut)
         cut = sqrt(chgtaper*dpltaper)
      else if (mode .eq. 'DIPOLE') then
         off = dplcut
         cut = dpltaper
      else if (mode(1:5) .eq. 'MPOLE') then
         off = mpolecut
         cut = mpoletaper
      else if (mode(1:5) .eq. 'EWALD') then
         off = ewaldcut
         cut = ewaldcut
      else
         off = min(vdwcut,chgcut,dplcut,mpolecut)
         cut = min(vdwtaper,chgtaper,dpltaper,mpoletaper)
      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
      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.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)  1995  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program sybylxyz  --  Sybyl MOL2 to Cartesian coordinates  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "sybylxyz" takes as input a Sybyl MOL2 coordinates file,
c     converts to and then writes out Cartesian coordinates
c
c
      program sybylxyz
      implicit none
      include 'files.i'
      include 'iounit.i'
      include 'titles.i'
      integer ixyz,freeunit
      character*60 xyzfile
c
c
c     get and read the Sybyl 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)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine temper  --  constant temperature via coupling  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "temper" maintains a constant desired temperature via either
c     Berendsen's velocity scaling coupled to an external temperature
c     bath or Andersen's stochastic collision method
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     H. C. Andersen, "Molecular Dynamics Simulations at Constant
c     Pressure and/or Temperature", Journal of Chemical Physics,
c     72, 2384-2393 (1980)
c
c
      subroutine temper (dt,temp)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bath.i'
      include 'group.i'
      include 'mdstuf.i'
      include 'moldyn.i'
      include 'rgddyn.i'
      include 'usage.i'
      integer i,j
      real*8 dt,temp,scale
      real*8 maxwell,random
      real*8 trial,rate
      real*8 speed,vec(3)
c
c
c     couple to external temperature bath via Berendsen scaling
c
      if (thermostat .eq. 'BERENDSEN') then
         if (temp .eq. 0.0d0)  temp = 0.1d0
         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, n
               if (use(i)) then
                  do j = 1, 3
                     v(j,i) = scale * v(j,i)
                  end do
               end if
            end do
         end if
c
c     select random velocities via Andersen stochastic collisions
c
      else if (thermostat .eq. 'ANDERSEN') then
         rate = 1000.0d0 * collide * dt / dble(nuse)**(2.0d0/3.0d0)
         do i = 1, n
            if (use(i)) then
               trial = random ()
               if (trial .lt. rate) then
                  speed = maxwell (mass(i),kelvin)
                  call ranvec (vec)
                  do j = 1, 3
                     v(j,i) = speed * vec(j)
                  end do
               end if
            end if
         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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'energi.i'
      include 'inform.i'
      include 'inter.i'
      include 'iounit.i'
      include 'solute.i'
      include 'usage.i'
      integer i,j,next
      real*8 etot,f,f0,eps,eps0,old,energy
      real*8 eb0,ea0,eba0,eub0,eaa0,eopb0
      real*8 eopd0,eid0,eit0,et0,ebt0,ett0
      real*8 ev0,ec0,ecd0,ed0,em0,ep0
      real*8 er0,es0,elf0,eg0,ex0
      real*8 ndeb(3,maxatm),ndea(3,maxatm)
      real*8 ndeba(3,maxatm),ndeub(3,maxatm)
      real*8 ndeaa(3,maxatm),ndeopb(3,maxatm)
      real*8 ndeopd(3,maxatm),ndeid(3,maxatm)
      real*8 ndeit(3,maxatm),ndet(3,maxatm)
      real*8 ndebt(3,maxatm),ndett(3,maxatm)
      real*8 ndev(3,maxatm),ndec(3,maxatm)
      real*8 ndecd(3,maxatm),nded(3,maxatm)
      real*8 ndem(3,maxatm),ndep(3,maxatm)
      real*8 nder(3,maxatm),ndes(3,maxatm)
      real*8 ndelf(3,maxatm),ndeg(3,maxatm)
      real*8 ndex(3,maxatm)
      real*8 detot(3,maxatm),ndetot(3,maxatm)
      real*8 denorm(maxatm),ndenorm(maxatm)
      real*8 totnorm,ntotnorm,rms,nrms
      logical exist,query
      logical doanalyt,donumer,dofull
      character*1 answer,axis(3)
      character*80 record,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 (a80)
         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 (a80)
         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 = 1.0d-5
         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 a Numerical Stepsize [',d7.1,
     &                 ' Ang] :  ',$)
            read (input,70)  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 (a80)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  dofull = .true.
      end if
c
c     compute the analytical gradient components
c
      if (doanalyt) then
         call gradient (etot,detot)
      end if
c
c     print the total potential energy of the system
c
      if (doanalyt) then
         if (digits .ge. 8) then
            write (iout,100)  etot
  100       format (/,' Total Potential Energy :',8x,f20.8,' Kcal/mole')
         else if (digits .ge. 6) then
            write (iout,110)  etot
  110       format (/,' Total Potential Energy :',8x,f18.6,' Kcal/mole')
         else
            write (iout,120)  etot
  120       format (/,' Total Potential Energy :',8x,f16.4,' Kcal/mole')
         end if
c
c     print the energy breakdown over individual components
c
         write (iout,130)
  130    format (/,' Potential Energy Breakdown by Individual',
     &              ' Components :')
         if (digits .ge. 8) then
            write (iout,140)
  140       format (/,'  Energy',7x,'EB',14x,'EA',14x,'EBA',13x,'EUB',
     &              /,'  Terms',8x,'EAA',13x,'EOPB',12x,'EOPD',
     &                 12x,'EID',
     &              /,15x,'EIT',13x,'ET',14x,'EBT',13x,'ETT',
     &              /,15x,'EV',14x,'EC',14x,'ECD',13x,'ED',
     &              /,15x,'EM',14x,'EP',14x,'ER',14x,'ES',
     &              /,15x,'ELF',13x,'EG',14x,'EX')
            write (iout,150)  eb,ea,eba,eub,eaa,eopb,eopd,eid,
     &                        eit,et,ebt,ett,ev,ec,ecd,ed,em,
     &                        ep,er,es,elf,eg,ex
  150       format (/,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,
     &                 /,6x,4f16.8,/,6x,3f16.8)
         else if (digits .ge. 6) then
            write (iout,160)
  160       format (/,'  Energy',6x,'EB',12x,'EA',12x,'EBA',11x,'EUB',
     &                 11x,'EAA',
     &              /,'  Terms',7x,'EOPB',10x,'EOPD',10x,'EID',
     &                 11x,'EIT',11x,'ET',
     &              /,14x,'EBT',11x,'ETT',11x,'EV',12x,'EC',12x,'ECD',
     &              /,14x,'ED',12x,'EM',12x,'EP',12x,'ER',12x,'ES',
     &              /,14x,'ELF',11x,'EG',12x,'EX')
            write (iout,170)  eb,ea,eba,eub,eaa,eopb,eopd,eid,
     &                        eit,et,ebt,ett,ev,ec,ecd,ed,em,
     &                        ep,er,es,elf,eg,ex
  170       format (/,6x,5f14.6,/,6x,5f14.6,/,6x,5f14.6,/,6x,5f14.6,
     &                 /,6x,3f14.6)
         else
            write (iout,180)
  180       format (/,'  Energy',6x,'EB',10x,'EA',10x,'EBA',9x,'EUB',
     &                 9x,'EAA',9x,'EOPB',
     &              /,'  Terms',7x,'EOPD',8x,'EID',9x,'EIT',9x,'ET',
     &                 10x,'EBT',9x,'ETT',
     &              /,14x,'EV',10x,'EC',10x,'ECD',9x,'ED',10x,'EM',
     &                 10x,'EP',
     &              /,14x,'ER',10x,'ES',10x,'ELF',9x,'EG',10x,'EX')
            write (iout,190)  eb,ea,eba,eub,eaa,eopb,eopd,eid,
     &                        eit,et,ebt,ett,ev,ec,ecd,ed,em,
     &                        ep,er,es,elf,eg,ex
  190       format (/,6x,6f12.4,/,6x,6f12.4,/,6x,6f12.4,/,6x,5f12.4)
         end if
      end if
c
c     print a header for the gradients of individual potentials
c
      if (dofull) then
         write (iout,200)
  200    format (/,' Cartesian Gradient Breakdown by Individual',
     &                 ' Components :')
         if (digits .ge. 8) then
            write (iout,210)
  210       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 EBT',
     &                 11x,'d ETT',
     &              /,15x,'d EV',12x,'d EC',12x,'d ECD',11x,'d ED',
     &              /,15x,'d EM',12x,'d EP',12x,'d ER',12x,'d ES',
     &              /,15x,'d ELF',11x,'d EG',12x,'d EX')
         else if (digits .ge. 6) then
            write (iout,220)
  220       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 EBT',9x,'d ETT',9x,'d EV',
     &                 10x,'d EC',10x,'d ECD',
     &              /,14x,'d ED',10x,'d EM',10x,'d EP',10x,'d ER',
     &                 10x,'d ES',
     &              /,14x,'d ELF',9x,'d EG',10x,'d EX')
         else
            write (iout,230)
  230       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 EBT',7x,'d ETT',
     &              /,2x,'Type',6x,'d EV',8x,'d EC',8x,'d ECD',
     &                 7x,'d ED',8x,'d EM',8x,'d EP',
     &              /,12x,'d ER',8x,'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
               ebt0 = ebt
               ett0 = ett
               ev0 = ev
               ec0 = ec
               ecd0 = ecd
               ed0 = ed
               em0 = em
               ep0 = ep
               er0 = er
               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
               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
               ndebt(j,i) = (ebt - ebt0) / eps
               ndett(j,i) = (ett - ett0) / eps
               ndev(j,i) = (ev - ev0) / 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
               nder(j,i) = (er - er0) / 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
               ndetot(j,i) = (f - f0) / 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,240)  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),debt(j,i),
     &                                 dett(j,i),dev(j,i),dec(j,i),
     &                                 decd(j,i),ded(j,i),dem(j,i),
     &                                 dep(j,i),der(j,i),des(j,i),
     &                                 delf(j,i),deg(j,i),dex(j,i)
  240                format (/,i6,4f16.8,/,5x,a1,4f16.8,
     &                          /,' Anlyt',4f16.8,/,6x,4f16.8,
     &                          /,6x,4f16.8,/,6x,3f16.8)
                  else if (digits .ge. 6) then
                     write (iout,250)  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),debt(j,i),
     &                                 dett(j,i),dev(j,i),dec(j,i),
     &                                 decd(j,i),ded(j,i),dem(j,i),
     &                                 dep(j,i),der(j,i),des(j,i),
     &                                 delf(j,i),deg(j,i),dex(j,i)
  250                format (/,i6,5f14.6,/,5x,a1,5f14.6,/,' Anlyt',
     &                          5f14.6,/,6x,5f14.6,/,6x,3f14.6)
                  else
                     write (iout,260)  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),debt(j,i),
     &                                 dett(j,i),dev(j,i),dec(j,i),
     &                                 decd(j,i),ded(j,i),dem(j,i),
     &                                 dep(j,i),der(j,i),des(j,i),
     &                                 delf(j,i),deg(j,i),dex(j,i)
  260                format (/,i6,6f12.4,/,5x,a1,6f12.4,/,' Anlyt',
     &                          6f12.4,/,6x,5f12.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,270)  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),
     &                                 ndebt(j,i),ndett(j,i),ndev(j,i),
     &                                 ndec(j,i),ndecd(j,i),nded(j,i),
     &                                 ndem(j,i),ndep(j,i),nder(j,i),
     &                                 ndes(j,i),ndelf(j,i),ndeg(j,i),
     &                                 ndex(j,i)
  270                format (/,i6,4f16.8,/,5x,a1,4f16.8,
     &                          /,' Numer',4f16.8,/,6x,4f16.8,
     &                          /,6x,4f16.8,/,6x,3f16.8)
                  else if (digits .ge. 6) then
                     write (iout,280)  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),
     &                                 ndebt(j,i),ndett(j,i),ndev(j,i),
     &                                 ndec(j,i),ndecd(j,i),nded(j,i),
     &                                 ndem(j,i),ndep(j,i),nder(j,i),
     &                                 ndes(j,i),ndelf(j,i),ndeg(j,i),
     &                                 ndex(j,i)
  280                format (/,i6,5f14.6,/,5x,a1,5f14.6,/,' Numer',
     &                          5f14.6,/,6x,5f14.6,/,6x,3f14.6)
                  else
                     write (iout,290)  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),
     &                                 ndebt(j,i),ndett(j,i),ndev(j,i),
     &                                 ndec(j,i),ndecd(j,i),nded(j,i),
     &                                 ndem(j,i),ndep(j,i),nder(j,i),
     &                                 ndes(j,i),ndelf(j,i),ndeg(j,i),
     &                                 ndex(j,i)
  290                format (/,i6,6f12.4,/,5x,a1,6f12.4,/,' Numer',
     &                          6f12.4,/,6x,5f12.4)
                  end if
               end if
            end do
         end if
      end do
c
c     print the total gradient components for each atom
c
      write (iout,300)
  300 format (/,' Cartesian Gradient Breakdown over Individual Atoms :')
      if (digits .ge. 8) then
         write (iout,310)
  310    format (/,2x,'Type',4x,'Atom',10x,'dE/dX',11x,'dE/dY',
     &              11x,'dE/dZ',11x,'Norm',/)
      else if (digits .ge. 6) then
         write (iout,320)
  320    format (/,2x,'Type',6x,'Atom',11x,'dE/dX',9x,'dE/dY',
     &              9x,'dE/dZ',11x,'Norm',/)
      else
         write (iout,330)
  330    format (/,2x,'Type',6x,'Atom',14x,'dE/dX',7x,'dE/dY',
     &              7x,'dE/dZ',10x,'Norm',/)
      end if
      totnorm = 0.0d0
      ntotnorm = 0.0d0
      do i = 1, n
         if (doanalyt .and. use(i)) then
            denorm(i) = detot(1,i)**2 + detot(2,i)**2 +
     &                       detot(3,i)**2
            totnorm = totnorm + denorm(i)
            denorm(i) = sqrt(denorm(i))
            if (digits .ge. 8) then
               write (iout,340)  i,(detot(j,i),j=1,3),denorm(i)
  340          format (' Anlyt',i8,1x,3f16.8,f16.8)
            else if (digits .ge. 6) then
               write (iout,350)  i,(detot(j,i),j=1,3),denorm(i)
  350          format (' Anlyt',2x,i8,3x,3f14.6,2x,f14.6)
            else
               write (iout,360)  i,(detot(j,i),j=1,3),denorm(i)
  360          format (' Anlyt',2x,i8,7x,3f12.4,2x,f12.4)
            end if
         end if
         if (donumer .and. use(i)) then
            ndenorm(i) = ndetot(1,i)**2 + ndetot(2,i)**2 +
     &                        ndetot(3,i)**2
            ntotnorm = ntotnorm + ndenorm(i)
            ndenorm(i) = sqrt(ndenorm(i))
            if (digits .ge. 8) then
               write (iout,370)  i,(ndetot(j,i),j=1,3),ndenorm(i)
  370          format (' Numer',i8,1x,3f16.8,f16.8)
            else if (digits .ge. 6) then
               write (iout,380)  i,(ndetot(j,i),j=1,3),ndenorm(i)
  380          format (' Numer',2x,i8,3x,3f14.6,2x,f14.6)
            else
               write (iout,390)  i,(ndetot(j,i),j=1,3),ndenorm(i)
  390          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
      write (iout,400)
  400 format (/,' Total Gradient Norm and RMS Gradient per Atom :')
      if (doanalyt) then
         totnorm = sqrt(totnorm)
         if (digits .ge. 8) then
            write (iout,410)  totnorm
  410       format (/,' Anlyt',6x,'Total Gradient Norm Value',6x,f20.8)
         else if (digits .ge. 6) then
            write (iout,420)  totnorm
  420       format (/,' Anlyt',6x,'Total Gradient Norm Value',6x,f18.6)
         else
            write (iout,430)  totnorm
  430       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,440)  ntotnorm
  440       format (' Numer',6x,'Total Gradient Norm Value',6x,f20.8)
         else if (digits .ge. 6) then
            write (iout,450)  ntotnorm
  450       format (' Numer',6x,'Total Gradient Norm Value',6x,f18.6)
         else
            write (iout,460)  ntotnorm
  460       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) then
         rms = totnorm / sqrt(dble(nuse))
         if (digits .ge. 8) then
            write (iout,470)  rms
  470       format (/,' Anlyt',6x,'RMS Gradient over All Atoms',
     &                 4x,f20.8)
         else if (digits .ge. 6) then
            write (iout,480)  rms
  480       format (/,' Anlyt',6x,'RMS Gradient over All Atoms',
     &                 4x,f18.6)
         else
            write (iout,490)  rms
  490       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,500)  nrms
  500       format (' Numer',6x,'RMS Gradient over All Atoms',4x,f20.8)
         else if (digits .ge. 6) then
            write (iout,510)  nrms
  510       format (' Numer',6x,'RMS Gradient over All Atoms',4x,f18.6)
         else
            write (iout,520)  nrms
  520       format (' Numer',6x,'RMS Gradient over All Atoms',4x,f16.4)
         end if
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'hescut.i'
      include 'inform.i'
      include 'iounit.i'
      include 'usage.i'
      integer maxnum
      parameter (maxnum=300)
      integer i,j,k,m,ii,jj,ihes
      integer index,next,freeunit
      integer hinit(3,maxatm)
      integer hstop(3,maxatm)
      integer hindex(maxhess)
      real*8 energy,e,old,eps,eps0
      real*8 diff,delta,sum
      real*8 g(3,maxatm),g0(3,maxatm)
      real*8 h(maxhess),hdiag(3,maxatm)
      real*8 nhess(3,maxnum,3,maxnum)
      logical doanalyt,donumer
      logical dograd,dofull
      logical exist,query
      logical identical
      character*1 answer,axis(3)
      character*60 hessfile
      character*80 record,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 = 1.0d-4
      if (digits .ge. 6)  delta = 1.0d-6
      if (digits .ge. 8)  delta = 1.0d-8
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 (a80)
         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.
      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 (a80)
            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
      if (donumer) then
         dograd = .true.
         call nextarg (answer,exist)
         if (.not. exist) then
            write (iout,50)
   50       format (/,' Numerical Hessian from Gradient',
     &                 ' or Function [G] :  ',$)
            read (input,60)  record
   60       format (a80)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'F')  dograd = .false.
c
c     get the stepsize for numerical Hessian calculation
c
         eps = -1.0d0
         eps0 = 1.0d-3
         if (dograd)  eps0 = 1.0d-5
         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 a Numerical Stepsize [',d7.1,
     &                 ' Ang] :  ',$)
            read (input,90)  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 (a80)
            next = 1
            call gettext (record,answer,next)
         end if
         call upcase (answer)
         if (answer .eq. 'Y')  dofull = .true.
      end if
c
c     get the analytical Hessian matrix elements
c
      identical = .true.
      if (doanalyt) then
         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.
                     if (digits .ge. 8) then
                        write (iout,120)
  120                   format (/,' Comparison of Analytical and',
     &                            ' Numerical Hessian Elements :',
     &                          //,3x,' First Atom',5x,'Second Atom',
     &                            14x,'Analytical',11x,'Numerical',/)
                     else if (digits .ge. 6) then
                        write (iout,130)
  130                   format (/,' Comparison of Analytical and',
     &                            ' Numerical Hessian Elements :',
     &                          //,3x,' First Atom',5x,'Second Atom',
     &                            12x,'Analytical',9x,'Numerical',/)
                     else
                        write (iout,140)
  140                   format (/,' Comparison of Analytical and',
     &                            ' Numerical Hessian Elements :',
     &                          //,3x,' First Atom',5x,'Second Atom',
     &                            10x,'Analytical',7x,'Numerical',/)
                     end if
                  end if
                  if (digits .ge. 8) then
                     write (iout,150)  i,axis(j),i,axis(j),
     &                                 hdiag(j,i),nhess(j,i,j,i)
  150                format (3x,i6,' (',a1,') ',5x,i6,' (', a1,') ',
     &                          4x,2f20.8)
                  else if (digits .ge. 6) then
                     write (iout,160)  i,axis(j),i,axis(j),
     &                                 hdiag(j,i),nhess(j,i,j,i)
  160                format (3x,i6,' (',a1,') ',5x,i6,' (', a1,') ',
     &                          4x,2f18.6)
                  else
                     write (iout,170)  i,axis(j),i,axis(j),
     &                                 hdiag(j,i),nhess(j,i,j,i)
  170                format (3x,i6,' (',a1,') ',5x,i6,' (', a1,') ',
     &                          4x,2f16.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.
                        if (digits .ge. 8) then
                           write (iout,180)
  180                      format (/,' Comparison of Analytical and',
     &                               ' Numerical Hessian Elements :',
     &                             //,3x,' First Atom',5x,'Second Atom',
     &                               14x,'Analytical',11x,'Numerical',/)
                        else if (digits .ge. 6) then
                           write (iout,190)
  190                      format (/,' Comparison of Analytical and',
     &                               ' Numerical Hessian Elements :',
     &                             //,3x,' First Atom',5x,'Second Atom',
     &                               12x,'Analytical',9x,'Numerical',/)
                        else
                           write (iout,200)
  200                      format (/,' Comparison of Analytical and',
     &                               ' Numerical Hessian Elements :',
     &                             //,3x,' First Atom',5x,'Second Atom',
     &                               10x,'Analytical',7x,'Numerical',/)
                        end if
                     end if
                     if (digits .ge. 8) then
                        write (iout,210)  i,axis(j),ii,axis(jj),
     &                                    h(k),nhess(jj,ii,j,i)
  210                   format (3x,i6,' (',a1,') ',5x,i6,' (', a1,') ',
     &                             4x,2f20.8)
                     else if (digits .ge. 6) then
                        write (iout,220)  i,axis(j),ii,axis(jj),
     &                                    h(k),nhess(jj,ii,j,i)
  220                   format (3x,i6,' (',a1,') ',5x,i6,' (', a1,') ',
     &                             4x,2f18.6)
                     else
                        write (iout,230)  i,axis(j),ii,axis(jj),
     &                                    h(k),nhess(jj,ii,j,i)
  230                   format (3x,i6,' (',a1,') ',5x,i6,' (', a1,') ',
     &                             4x,2f16.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,240)
  240       format (/,' Analytical and Numerical Hessian Elements',
     &                 ' are Identical')
         end if
      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,250)  sum
  250       format (/,' Sum of Diagonal Hessian Elements :',6x,f20.8)
         else if (digits .ge. 6) then
            write (iout,260)  sum
  260       format (/,' Sum of Diagonal Hessian Elements :',6x,f18.6)
         else
            write (iout,270)  sum
  270       format (/,' Sum of Diagonal Hessian Elements :',6x,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,280)  i,k
  280          format (/,' 3x3 Hessian Block for Atoms :',3x,2i8,/)
               do j = 1, 3
                  if (digits .ge. 8) then
                     write (iout,290)  (nhess(m,i,j,k),m=1,3)
  290                format (' Numer',5x,3f20.8)
                  else if (digits .ge. 6) then
                     write (iout,300)  (nhess(m,i,j,k),m=1,3)
  300                format (' Numer',5x,3f18.6)
                  else
                     write (iout,310)  (nhess(m,i,j,k),m=1,3)
  310                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,320)  hessfile
  320    format (/,' Hessian Matrix written to File :  ',a40)
         write (ihes,330)
  330    format (/,' Diagonal Hessian Elements  (3 per Atom)',/)
         if (digits .ge. 8) then
            write (ihes,340)  ((hdiag(j,i),j=1,3),i=1,n)
  340       format (4f16.8)
         else if (digits .ge. 6) then
            write (ihes,350)  ((hdiag(j,i),j=1,3),i=1,n)
  350       format (5f14.6)
         else
            write (ihes,360)  ((hdiag(j,i),j=1,3),i=1,n)
  360       format (6f12.4)
         end if
         do i = 1, n
            do j = 1, 3
               if (hinit(j,i) .le. hstop(j,i)) then
                  write (ihes,370)  i,axis(j)
  370             format (/,' Off-diagonal Hessian Elements for Atom',
     &                       i6,1x,a1,/)
                  if (digits .ge. 8) then
                     write (ihes,380)  (h(k),k=hinit(j,i),hstop(j,i))
  380                format (4f16.8)
                  else if (digits .ge. 6) then
                     write (ihes,390)  (h(k),k=hinit(j,i),hstop(j,i))
  390                format (5f14.6)
                  else
                     write (ihes,400)  (h(k),k=hinit(j,i),hstop(j,i))
  400                format (6f12.4)
                  end if
               end if
            end do
         end do
         close (unit=ihes)
      end if
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 testlight  --  time different neighbor schemes  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "testlight" performs a set of timing tests to compare the
c     evaluation of potential energy and energy/gradient using
c     the method of lights with a double loop over all atom pairs
c
c
      program testlight
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'cutoff.i'
      include 'deriv.i'
      include 'energi.i'
      include 'iounit.i'
      include 'potent.i'
      include 'vdwpot.i'
      integer i,j,k
      integer ncalls,npair
      integer map(maxlight)
      real*8 xi,yi,zi,r2
      real*8 elapsed,eps
      real*8 cev(3,maxatm)
      real*8 cec(3,maxatm)
      real*8 xsort(maxlight)
      real*8 ysort(maxlight)
      real*8 zsort(maxlight)
      logical exist,query
      logical identical
      character*80 string
c
c
c     read the molecular system and setup molecular mechanics
c
      call initial
      call getxyz
      call mechanic
c
c     get the number 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)  ncalls
   30    format (i10)
      end if
      if (ncalls .eq. 0)  ncalls = 1
c
c     get the timing for setup of method of lights
c
      call setime
      do k = 1, ncalls
         do i = 1, n
            xsort(i) = x(i)
            ysort(i) = y(i)
            zsort(i) = z(i)
         end do
         call lights (n,map,xsort,ysort,zsort)
      end do
      call getime (elapsed)
      write (iout,40)  ncalls
   40 format (/,' Computation Overhead :',11x,'Time',
     &           7x,i5,' Evaluations')
      write (iout,50)  elapsed
   50 format (/,' Method of Lights',11x,f10.3)
c
c     get the timing for setup of double nested loop
c
      call setime
      npair = 0
      do k = 1, ncalls
         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. 100.0d0)  npair = npair + 1
            end do
         end do
      end do
      call getime (elapsed)
      write (iout,60)  elapsed
   60 format (' Double Nest Loop',11x,f10.3)
c
c     get the timing for energy terms via method of lights
c
      use_lights = .true.
      call setime
      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_charge)  call echarge
      end do
      call getime (elapsed)
      write (iout,70)
   70 format (/,' Potential Energy Only :',10x,'Time',14x,'EV',10x,'EC'))
      write (iout,80)  elapsed,ev,ec
   80 format (/,' Method of Lights',11x,f10.3,6x,2f12.4)
c
c     get the timing for energy terms via double nested loop
c
      use_lights = .false.
      call setime
      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_charge)  call echarge
      end do
      call getime (elapsed)
      write (iout,90)  elapsed,ev,ec
   90 format (' Double Nest Loop',11x,f10.3,6x,2f12.4)
c
c     get the timing for gradient via method of lights
c
      use_lights = .true.
      call setime
      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_charge)  call echarge1
      end do
      call getime (elapsed)
      write (iout,100)
  100 format (/,' Energy and Gradient :',12x,'Time')
      write (iout,110)  elapsed
  110 format (/,' Method of Lights',11x,f10.3)
c
c     store the method of lights gradient
c
      do i = 1, n
         do j = 1, 3
            cev(j,i) = dev(j,i)
            cec(j,i) = dec(j,i)
         end do
      end do
c
c     get the timing for gradient via double nested loop
c
      use_lights = .false.
      call setime
      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_charge)  call echarge1
      end do
      call getime (elapsed)
      write (iout,120)  elapsed
  120 format (' Double Nest Loop',11x,f10.3)
c
c     compare method of lights and double loop vdw gradient
c
      identical = .true.
      eps = 1.0d-4
      if (use_vdw) then
         do i = 1, n
            do j = 1, 3
               if (abs(cev(j,i)-dev(j,i)) .gt. eps) then
                  if (identical) then
                     identical = .false.
                     write (iout,130)
  130                format ()
                  end if
                  write (iout,140)  i,j,cev(j,i),dev(j,i)
  140             format (' TESTLIGHT  --  DEV Error at',2i8,2f12.4)
               end if
            end do
         end do
      end if
c
c     compare method of lights and double loop charge gradient
c
      if (use_charge) then
         do i = 1, n
            do j = 1, 3
               if (abs(cec(j,i)-dec(j,i)) .gt. eps) then
                  if (identical) then
                     identical = .false.
                     write (iout,150)
  150                format ()
                  end if
                  write (iout,160)  i,j,cec(j,i),dec(j,i)
  160             format (' TESTLIGHT  --  DEC Error at',2i8,2f12.4)
               end if
            end do
         end do
      end if
c
c     success if method of lights and double loop give same gradient
c
      if (identical) then
         write (iout,170)
  170    format (/,' Method of Lights and Double Loop Gradients',
     &              ' are Identical')
      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 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
      implicit none
      include 'sizes.i'
      include 'domega.i'
      include 'energi.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      include 'omega.i'
      include 'zcoord.i'
      integer i
      real*8 e,e0,etot,energy
      real*8 delta,delta0,eps
      real*8 eb0,ea0,eba0
      real*8 eub0,eaa0,eopb0
      real*8 eopd0,eid0,eit0
      real*8 et0,ebt0,ett0
      real*8 ev0,ec0,ecd0,ed0
      real*8 em0,ep0,er0
      real*8 es0,elf0,eg0,ex0
      real*8 derivs(maxrot)
      real*8 nderiv(maxrot)
      logical exist,query
      character*80 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 Numerical Derivative Stepsize [',d7.1,
     &              ' Deg] :  ',$)
         read (input,30)  delta
   30    format (f20.0)
      end if
      if (delta .le. 0.0d0)  delta = delta0
      eps = -delta / radian
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,'EBT',13x,'ETT',
     &           /,15x,'EV',14x,'EC',14x,'ECD',13x,'ED',
     &           /,15x,'EM',14x,'EP',14x,'ER',14x,'ES',
     &           /,15x,'ELF',13x,'EG',14x,'EX')
         write (iout,90)  eb,ea,eba,eub,eaa,eopb,eopd,eid,
     &                    eit,et,ebt,ett,ev,ec,ecd,ed,em,
     &                    ep,er,es,elf,eg,ex
   90    format (/,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,
     &              /,6x,4f16.8,/,6x,3f16.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,'EBT',11x,'ETT',11x,'EV',12x,'EC',12x,'ECD',
     &           /,14x,'ED',12x,'EM',12x,'EP',12x,'ER',12x,'ES',
     &           /,14x,'ELF',11x,'EG',12x,'EX')
         write (iout,110)  eb,ea,eba,eub,eaa,eopb,eopd,eid,
     &                     eit,et,ebt,ett,ev,ec,ecd,ed,em,
     &                     ep,er,es,elf,eg,ex
  110    format (/,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,'EBT',9x,'ETT',
     &           /,14x,'EV',10x,'EC',10x,'ECD',9x,'ED',10x,'EM',
     &              10x,'EP',
     &           /,14x,'ER',10x,'ES',10x,'ELF',9x,'EG',10x,'EX')
         write (iout,130)  eb,ea,eba,eub,eaa,eopb,eopd,eid,
     &                     eit,et,ebt,ett,ev,ec,ecd,ed,em,
     &                     ep,er,es,elf,eg,ex
  130    format (/,6x,6f12.4,/,6x,6f12.4,/,6x,6f12.4,/,6x,5f12.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 EBT',
     &              11x,'d ETT',
     &           /,15x,'d EV',12x,'d EC',12x,'d ECD',11x,'d ED',
     &           /,15x,'d ED',12x,'d EM',12x,'d EP',12x,'d ER',
     &           /,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 EBT',9x,'d ETT',9x,'d E14',
     &              9x,'d EV',10x,'d EC',
     &           /,14x,'d ECD',9x,'d ED',10x,'d EM',10x,'d EP',
     &              10x,'d ER',
     &           /,14x,'d ES',10x,'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 EBT',7x,'d ETT',
     &           /,2x,'Type',6x,'d EV',8x,'d EC',8x,'d ECD',
     &              7x,'d ED',8x,'d EM',8x,'d EP',
     &           /,12x,'d ER',8x,'d ES',8x,'d ELF',7x,'d EG',
     &              8x,'d EX')
      end if
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
         ebt0 = ebt
         ett0 = ett
         ev0 = ev
         ec0 = ec
         ecd0 = ecd
         ed0 = ed
         em0 = em
         ep0 = ep
         er0 = er
         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),tebt(i),tett(i),
     &                        tev(i),tec(i),tecd(i),ted(i),tem(i),
     &                        tep(i),ter(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,3f16.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),tebt(i),tett(i),
     &                        tev(i),tec(i),tecd(i),ted(i),tem(i),
     &                        tep(i),ter(i),tes(i),telf(i),teg(i),tex(i)
  190       format (/,i6,5f14.6,/,i6,5f14.6,/,' Anlyt',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),tebt(i),tett(i),
     &                        tev(i),tec(i),tecd(i),ted(i),tem(i),
     &                        tep(i),ter(i),tes(i),telf(i),teg(i),tex(i)
  200       format (/,i6,6f12.4,/,i6,6f12.4,/,' Anlyt',6f12.4,
     &                 /,6x,5f12.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,(ebt-ebt0)/eps,
     &                        (ett-ett0)/eps,(ev-ev0)/eps,(ec-ec0)/eps,
     &                        (ecd-ecd0)/eps,(ed-ed0)/eps,(em-em0)/eps,
     &                        (ep-ep0)/eps,(er-er0)/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,3f16.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,(ebt-ebt0)/eps,
     &                        (ett-ett0)/eps,(ev-ev0)/eps,(ec-ec0)/eps,
     &                        (ecd-ecd0)/eps,(ed-ed0)/eps,(em-em0)/eps,
     &                        (ep-ep0)/eps,(er-er0)/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,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,(ebt-ebt0)/eps,
     &                        (ett-ett0)/eps,(ev-ev0)/eps,(ec-ec0)/eps,
     &                        (ecd-ecd0)/eps,(ed-ed0)/eps,(em-em0)/eps,
     &                        (ep-ep0)/eps,(er-er0)/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,5f12.4)
         end if
      end do
c
c     print a header for the analytical vs. numerical comparison
c
      if (digits .ge. 8) then
         write (iout,240)
  240    format (//,5x,'Torsion',19x,'Anlyt Deriv',9x,'Numer Deriv',/)
      else if (digits .ge. 6) then
         write (iout,250)
  250    format (//,5x,'Torsion',18x,'Anlyt Deriv',7x,'Numer Deriv',/)
      else
         write (iout,260)
  260    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,270)  iomega(2,i),iomega(1,i),derivs(i),
     &                        nderiv(i)
  270       format (1x,i5,'-',i5,10x,2f20.8)
         end do
      else if (digits .ge. 6) then
         do i = 1, nomega
            write (iout,280)  iomega(2,i),iomega(1,i),derivs(i),
     &                        nderiv(i)
  280       format (1x,i5,'-',i5,10x,2f18.6)
         end do
      else
         do i = 1, nomega
            write (iout,290)  iomega(2,i),iomega(1,i),derivs(i),
     &                        nderiv(i)
  290       format (1x,i5,'-',i5,10x,2f16.4)
         end do
      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 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
      implicit none
      include 'sizes.i'
      include 'hescut.i'
      include 'inform.i'
      include 'iounit.i'
      integer i,ncalls,next
      integer hinit(3,maxatm)
      integer hstop(3,maxatm)
      integer hindex(maxhess)
      real*8 value,energy,elapsed
      real*8 derivs(3,maxatm)
      real*8 h(maxhess)
      real*8 hdiag(3,maxatm)
      logical exist,query
      logical do_hessian
      character*1 answer
      character*80 record
      character*80 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
      do_hessian = .true.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,40)
   40    format (/,' Include Timing for Hessian Evaluations [Y] :  ',$)
         read (input,50)  record
   50    format (a80)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'N')  do_hessian = .false.
c
c     get the timing for setup of the calculation
c
      call setime
      call mechanic
      call getime (elapsed)
      write (iout,60)  elapsed
   60 format (/,' Computation Set-up :',f15.3,' Seconds')
c
c     set a large Hessian cutoff and turn off extra printing
c
      hesscut = 100.0d0
      verbose = .false.
c
c     run the potential energy only timing experiment
c
      call setime
      do i = 1, ncalls
         value = energy ()
      end do
      call getime (elapsed)
      write (iout,70)  elapsed,ncalls
   70 format (/,' Potential Energy :  ',f15.3,' Seconds for',
     &           i5,' Evaluations')
c
c     run the energy and gradient timing experiment
c
      call setime
      do i = 1, ncalls
         call gradient (value,derivs)
      end do
      call getime (elapsed)
      write (iout,80)  elapsed,ncalls
   80 format (/,' Energy & Gradient : ',f15.3,' Seconds for',
     &           i5,' Evaluations')
c
c     run the Hessian matrix only timing experiment
c
      if (do_hessian) then
         call setime
         do i = 1, ncalls
            call hessian (h,hinit,hstop,hindex,hdiag)
         end do
         call getime (elapsed)
         write (iout,90)  elapsed,ncalls
   90    format (/,' Hessian Matrix :    ',f15.3,' Seconds for',
     &              i5,' Evaluations')
      end if
c
c     repeat the potential energy only timing experiment
c
      call setime
      do i = 1, ncalls
         value = energy ()
      end do
      call getime (elapsed)
      write (iout,100)  elapsed,ncalls
  100 format (/,' Potential Energy :  ',f15.3,' Seconds for',
     &           i5,' Evaluations')
c
c     repeat the energy and gradient timing experiment
c
      call setime
      do i = 1, ncalls
         call gradient (value,derivs)
      end do
      call getime (elapsed)
      write (iout,110)  elapsed,ncalls
  110 format (/,' Energy & Gradient : ',f15.3,' Seconds for',
     &           i5,' Evaluations')
c
c     repeat the Hessian matrix only timing experiment
c
      if (do_hessian) then
         call setime
         do i = 1, ncalls
            call hessian (h,hinit,hstop,hindex,hdiag)
         end do
         call getime (elapsed)
         write (iout,120)  elapsed,ncalls
  120    format (/,' Hessian Matrix :    ',f15.3,' Seconds for',
     &              i5,' Evaluations')
      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 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
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      integer i,ncalls,next
      real*8 energy,value,elapsed
      real*8 derivs(maxrot)
      real*8 hrot(maxrot,maxrot)
      logical exist,query
      logical do_hessian
      character*1 answer
      character*80 record
      character*80 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 setime
      call mechanic
      call initrot
      call getime (elapsed)
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
      do_hessian = .true.
      call nextarg (answer,exist)
      if (.not. exist) then
         write (iout,40)
   40    format (/,' Include Timing for Hessian Evaluations [Y] :  ',$)
         read (input,50)  record
   50    format (a80)
         next = 1
         call gettext (record,answer,next)
      end if
      call upcase (answer)
      if (answer .eq. 'N')  do_hessian = .false.
c
c     print the time required for the computation setup
c
      write (iout,60)  elapsed
   60 format (/,' Computation Set-up :',f15.3,' Seconds')
c
c     run the potential energy only timing experiment
c
      call setime
      do i = 1, ncalls
         value = energy ()
      end do
      call getime (elapsed)
      write (iout,70)  elapsed,ncalls
   70 format (/,' Potential Energy :  ',f15.3,' Seconds for',
     &           i5,' Evaluations')
c
c     run the energy and gradient timing experiment
c
      call setime
      do i = 1, ncalls
         call gradrot (value,derivs)
      end do
      call getime (elapsed)
      write (iout,80)  elapsed,ncalls
   80 format (/,' Energy & Gradient : ',f15.3,' Seconds for',
     &           i5,' Evaluations')
c
c     run the Hessian matrix only timing experiment
c
      if (do_hessian) then
         call setime
         do i = 1, ncalls
            call hessrot ('full',hrot)
         end do
         call getime (elapsed)
         write (iout,90)  elapsed,ncalls
   90    format (/,' Hessian Matrix :    ',f15.3,' Seconds for',
     &              i5,' Evaluations')
      end if
c
c     repeat the potential energy only timing experiment
c
      call setime
      do i = 1, ncalls
         value = energy ()
      end do
      call getime (elapsed)
      write (iout,100)  elapsed,ncalls
  100 format (/,' Potential Energy :  ',f15.3,' Seconds for',
     &           i5,' Evaluations')
c
c     repeat the energy and gradient timing experiment
c
      call setime
      do i = 1, ncalls
         call gradrot (value,derivs)
      end do
      call getime (elapsed)
      write (iout,110)  elapsed,ncalls
  110 format (/,' Energy & Gradient : ',f15.3,' Seconds for',
     &           i5,' Evaluations')
c
c     repeat the Hessian matrix only timing experiment
c
      if (do_hessian) then
         call setime
         do i = 1, ncalls
            call hessrot ('full',hrot)
         end do
         call getime (elapsed)
         write (iout,120)  elapsed,ncalls
  120    format (/,' Hessian Matrix :    ',f15.3,' Seconds for',
     &              i5,' Evaluations')
      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     ##  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     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     x          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     writeout   subroutine to write out info about current status
c
c
      subroutine tncg (mode,method,nvar,x,minimum,grdmin,
     &                     fgvalue,hmatrix,writeout)
      implicit none
      include 'sizes.i'
      include 'hescut.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'linmin.i'
      include 'math.i'
      include 'minima.i'
      include 'output.i'
      include 'piorbs.i'
      include 'potent.i'
      integer i,nvar,fg_call
      integer iter_tn,iter_cg
      integer next,newhess
      integer h_init(maxvar)
      integer h_stop(maxvar)
      integer h_index(maxhess)
      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 x(maxvar)
      real*8 x_old(maxvar)
      real*8 g(maxvar),p(maxvar)
      real*8 h(maxhess)
      real*8 h_diag(maxvar)
      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*80 record
      save h_index,h
      external fgvalue
      external hmatrix
      external writeout
c
c
c     check number of variables and get type of optimization
c
      if (nvar .gt. maxvar) then
         write (iout,10)
   10    format (/,' TNCG  --  Too many Parameters,',
     &              ' Increase value of MAXVAR')
         return
      end if
      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 = -1000000.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
      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 (cappa .eq. 0.0d0)  cappa = 0.1d0
      if (stpmin .eq. 0.0d0)  stpmin = 1.0d-20
      if (stpmax .eq. 0.0d0)  stpmax = 5.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)
         if (keyword(1:7) .eq. 'FCTMIN ') then
            read (record(next:80),*,err=20)  fctmin
         else if (keyword(1:8) .eq. 'MAXITER ') then
            read (record(next:80),*,err=20)  maxiter
         else if (keyword(1:9) .eq. 'NEXTITER ') then
            read (record(next:80),*,err=20)  nextiter
         else if (keyword(1:9) .eq. 'PRINTOUT ') then
            read (record(next:80),*,err=20)  iprint
         else if (keyword(1:9) .eq. 'WRITEOUT ') then
            read (record(next:80),*,err=20)  iwrite
         else if (keyword(1:8) .eq. 'NEWHESS ') then
            read (record(next:80),*,err=20)  newhess
         else if (keyword(1:12) .eq. 'SADDLEPOINT ') then
            negtest = .false.
         else if (keyword(1:6) .eq. 'CAPPA ') then
            read (record(next:80),*,err=20)  cappa
         else if (keyword(1:8) .eq. 'STEPMIN ') then
            read (record(next:80),*,err=20)  stpmin
         else if (keyword(1:8) .eq. 'STEPMAX ') then
            read (record(next:80),*,err=20)  stpmax
         else if (keyword(1:7) .eq. 'ANGMAX ') then
            read (record(next:80),*,err=20)  angmax
         else if (keyword(1:7) .eq. 'INTMAX ') then
            read (record(next:80),*,err=20)  intmax
         end if
   20    continue
      end do
c
c     initialize the function call and iteration counters
c
      fg_call = 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,30)
   30       format (/,' Full-Newton Conjugate-Gradient',
     &                 ' Optimization :')
         else if (mode .eq. 'tncg') then
            write (iout,40)
   40       format (/,' Truncated-Newton Conjugate-Gradient',
     &                 ' Optimization :')
         else if (mode .eq. 'dtncg') then
            write (iout,50)
   50       format (/,' Finite-Difference Truncated-Newton',
     &                 ' Conjugate-Gradient Optimization :')
         else if (mode .eq. 'auto') then
            write (iout,60)
   60       format (/,' Variable-Mode Truncated-Newton',
     &                 ' Conjugate-Gradient Optimization :')
         end if
         write (iout,70)  mode,method,grdmin
   70    format (/,' Algorithm : ',a6,5x,'Preconditioning : ',a6,5x,
     &              ' RMS Grad : ',d8.2)
         write (iout,80)
   80    format (/,' TN Iter   F Value       G RMS     F Move  ',
     &              '  X Move   CG Iter   Solve   FG Call',/)
      end if
c
c     compute and print initial function and gradient values
c
      iter_cg = 0
      fg_call = fg_call + 1
      f = fgvalue (x,g)
      f_old = f
      g_norm = 0.0d0
      do i = 1, nvar
         x_old(i) = x(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
      if (iprint .gt. 0) then
         if (f.lt.1.0d6 .and. f.gt.-1.0d5 .and. g_rms.lt.1.0d6) then
            write (iout,90)  iter_tn,f,g_rms,fg_call
   90       format (i6,f12.4,f12.4,41x,i7)
         else
            write (iout,100)  iter_tn,f,g_rms,fg_call
  100       format (i6,d12.4,d12.4,41x,i7)
         end if
      end if
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,110)
  110       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,120)
  120       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,130)
  130       format (/,' TNCG  --  Incomplete Convergence',
     &                 ' due to IterLimit')
         end if
      end if
c
c     beginning of the outer truncated Newton iteration
c
      dowhile (.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 piscf
            fg_call = fg_call + 1
            f = fgvalue (x,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,x,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,x,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,x,p,f_move,angle,fg_call,
     &                fgvalue,info_search)
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 + (x(i)-x_old(i))**2
            x_old(i) = x(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     set warning if the line search encountered problems
c
         if (info_search .ne. ' Success ') then
            info_solve = info_search
         end if
c
c     print the 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.0d6 .and. f.gt.-1.0d5 .and.
     &             g_rms.lt.1.0d6 .and. f_move.lt.1.0d5) then
                  write (iout,140)  iter_tn,f,g_rms,f_move,x_move,
     &                              iter_cg,info_solve,fg_call
  140             format (i6,f12.4,f12.4,f11.4,f10.4,i8,3x,a9,i7)
               else
                  write (iout,150)  iter_tn,f,g_rms,f_move,x_move,
     &                              iter_cg,info_solve,fg_call
  150             format (i6,d12.4,d12.4,d11.4,f10.4,i8,3x,a9,i7)
               end if
            end if
         end if
         if (iwrite .gt. 0) then
            if (done .or. mod(iter_tn,iwrite) .eq. 0) then
               call writeout (x,iter_tn)
            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,160)  status
  160             format (/,' TNCG  --  Normal Termination due to ',a9)
               else
                  write (iout,170)  status
  170             format (/,' TNCG  --  Incomplete Convergence',
     &                       ' due to ',a9)
               end if
            end if
         end if
      end do
      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,x,g,h,
     &                    h_init,h_stop,h_index,h_diag,cycle,
     &                    iter_cg,fg_call,fgvalue,status)
      implicit none
      include 'sizes.i'
      include 'output.i'
      integer i,j,k,nvar,cycle
      integer iter,iter_cg
      integer fg_call,maxiter
      integer h_init(maxvar)
      integer h_stop(maxvar)
      integer h_index(maxhess)
      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 x(maxvar),g(maxvar)
      real*8 p(maxvar),q(maxvar)
      real*8 m(maxvar),r(maxvar)
      real*8 s(maxvar),d(maxvar)
      real*8 x_sigma(maxvar)
      real*8 g_sigma(maxvar)
      real*8 h_diag(maxvar)
      real*8 h(maxhess)
      logical negtest
      character*6 mode,method
      character*9 status
      external fgvalue
c
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
      dowhile (.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) = x(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
      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     reference for incomplete Cholesky factorization :
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 method 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)
      implicit none
      include 'sizes.i'
      include 'inform.i'
      include 'iounit.i'
      integer i,j,k,ii,kk
      integer iii,kkk,iter
      integer nvar,nblock
      integer ix,iy,iz,icount
      integer h_init(maxvar)
      integer h_stop(maxvar)
      integer c_init(maxvar)
      integer c_stop(maxvar)
      integer h_index(maxhess)
      integer c_index(maxhess)
      integer c_value(maxhess)
      real*8 f_i,f_k
      real*8 omega,factor
      real*8 maxalpha,alpha
      real*8 diag(maxvar)
      real*8 f(maxhess)
      real*8 f_diag(maxvar)
      real*8 h(maxhess)
      real*8 h_diag(maxvar)
      real*8 r(maxvar)
      real*8 s(maxvar)
      real*8 a(6),b(3)
      logical stable
      character*6 method
      save c_index,c_value
      save f,f_diag,stable
c
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)
                  dowhile (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
      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(6)
      real*8 vt(6),st(6)
      real*8 ampli(6),phase(6)
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
         dowhile (phase(i) .lt. -180.0d0)
            phase(i) = phase(i) + 360.0d0
         end do
         dowhile (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 .eq. 0) then
            goto 10
         else if (k .le. 6) then
            vt(k) = ampli(i)
            st(k) = phase(i)
         end if
      end do
   10 continue
      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 dihedral angles and
c     the numbers of the four atoms defining each dihedral angle
c
c
      subroutine torsions
      implicit none
      include 'sizes.i'
      include 'bond.i'
      include 'couple.i'
      include 'iounit.i'
      include 'tors.i'
      integer i,j,k
      integer ia,ib,ic,id
c
c
c     loop over all bonds, storing the atoms 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
                     if (ntors .gt. maxtors) then
                        write (iout,10)
   10                   format (/,' TORSIONS  --  Too many Torsional',
     &                             ' Angles; Increase MAXTORS')
                        call fatal
                     end if
                     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)  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,len
      integer last,trimtext
      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
      null = char(0)
      size = len(string)
      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     ##  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
      implicit none
      include 'sizes.i'
      include 'bound.i'
      include 'boxes.i'
      include 'iounit.i'
      include 'keys.i'
      integer i,next
      real*8 boxmax
      character*20 keyword
      character*80 record
      character*80 string
c
c
c     set the default values for periodic boundary conditions
c
      use_bounds = .false.
      use_image = .false.
      use_replica = .false.
c
c     set the default values for the unitcell variables
c
      xbox = 0.0d0
      ybox = 0.0d0
      zbox = 0.0d0
      alpha = 0.0d0
      beta = 0.0d0
      gamma = 0.0d0
      orthogonal = .false.
      monoclinic = .false.
      triclinic = .false.
      octahedron = .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:80)
         if (keyword(1:7) .eq. 'A-AXIS ') then
            read (string,*,err=10)  xbox
         else if (keyword(1:7) .eq. 'B-AXIS ') then
            read (string,*,err=10)  ybox
         else if (keyword(1:7) .eq. 'C-AXIS ') then
            read (string,*,err=10)  zbox
         else if (keyword(1:6) .eq. 'ALPHA ') then
            read (string,*,err=10)  alpha
         else if (keyword(1:5) .eq. 'BETA ') then
            read (string,*,err=10)  beta
         else if (keyword(1:6) .eq. 'GAMMA ') then
            read (string,*,err=10)  gamma
         else if (keyword(1:11) .eq. 'OCTAHEDRON ') then
            octahedron = .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) then
         use_bounds = .true.
         use_image = .true.
      end if
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 = xbox
         if (zbox .eq. 0.0d0)  zbox = xbox
         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 (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     check for proper use of truncated octahedron boundary
c
      if (octahedron) then
         if (xbox.eq.ybox .and. xbox.eq.zbox .and. orthogonal) then
            orthogonal = .false.
         else
            write (iout,20)
   20       format (/,' UNITCELL  --  Truncated Octahedron',
     &                 ' Incompatible with Defined Cell')
            call fatal
         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 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,length
      integer code,ichar
      character*1 char
      character*(*) string
c
c
c     convert lower case to upper case letters one at a time
c
      length = len(string)
      do i = 1, length
         code = ichar(string(i:i))
         if (code.ge.97 .and. code.le.122)
     &      string(i:i) = char(code-32)
      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 verlet  --  Verlet molecular dynamics step  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "verlet" performs a single molecular dynamics time step
c     by means of the velocity Verlet multistep recursion formula
c
c
      subroutine verlet (istep,dt)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bath.i'
      include 'mdstuf.i'
      include 'moldyn.i'
      include 'shake.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,istep
      real*8 dt,dt_2,dt2_2
      real*8 etot,ekin,epot
      real*8 temp,pres
      real*8 xold(maxatm)
      real*8 yold(maxatm)
      real*8 zold(maxatm)
      real*8 derivs(3,maxatm)
c
c
c     set some time values for the dynamics integration
c
      dt_2 = dt / 2.0d0
      dt2_2 = dt * dt_2
c
c     store the current atom positions, then find new atom
c     positions and half-step velocities via Verlet recursion
c
      do i = 1, n
         if (use(i)) then
            xold(i) = x(i)
            yold(i) = y(i)
            zold(i) = z(i)
            x(i) = x(i) + v(1,i)*dt + a(1,i)*dt2_2
            y(i) = y(i) + v(2,i)*dt + a(2,i)*dt2_2
            z(i) = z(i) + v(3,i)*dt + a(3,i)*dt2_2
            do j = 1, 3
               v(j,i) = v(j,i) + a(j,i)*dt_2
            end do
         end if
      end do
c
c     apply "rattle" to correct atom positions and velocities
c
      if (use_rattle)  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, n
         if (use(i)) then
            do j = 1, 3
               a(j,i) = -convert * derivs(j,i) / mass(i)
               v(j,i) = v(j,i) + a(j,i)*dt_2
            end do
         end if
      end do
c
c     use "rattle" method to get corrected full-step velocities
c
      if (use_rattle)  call rattle2 (dt)
c
c     sum the total kinetic energy over all atoms
c
      ekin = 0.0d0
      do i = 1, n
         if (use(i)) then
            do j = 1, 3
               ekin = ekin + mass(i)*v(j,i)**2
            end do
         end if
      end do
      ekin = 0.5d0 * ekin / convert
c
c     determine the system temperature and total energy
c
      temp = 2.0d0 * ekin / (dble(nfree) * gasconst)
      etot = ekin + epot
c
c     control temperature and pressure via external bath coupling
c
      if (isothermal)  call temper (dt,temp)
      if (isobaric)  call pressure (dt,pres,ekin)
c
c     compute statistics and save trajectory for this step
c
      call mdstat (istep,dt,etot,epot,ekin,temp,pres)
      call mdsave (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 (filename,status)
      implicit none
      include 'iounit.i'
      include 'output.i'
      integer i,leng,trimtext
      integer thousand,hundred
      integer tens,ones
      logical exist
      character*1 digit(0:9)
      character*3 status
      character*60 filename
      character*60 oldfile
      character*60 newfile
      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 (filename)
c
c     no change is needed if the file doesn't exist
c
      exist = .false.
      if (leng .ne. 0)  inquire (file=filename(1:leng),exist=exist)
      if (.not. exist)  return
c
c     set initial values for the current and next versions
c
      newfile = filename
      oldfile = filename
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
         dowhile (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 = filename(1:leng)//'_'//digit(thousand)
     &                      //digit(hundred)//digit(tens)//digit(ones)
            else if (hundred .ne. 0) then
               newfile = filename(1:leng)//'_'//digit(hundred)
     &                      //digit(tens)//digit(ones)
            else if (tens .ne. 0) then
               newfile = filename(1:leng)//'_'//digit(tens)//digit(ones)
            else
               newfile = filename(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
         filename = oldfile
      else if (status .eq. 'new') then
         filename = newfile
         inquire (file=filename,exist=exist)
         if (exist) then
            call nextarg (filename,exist)
            if (exist) then
               inquire (file=filename,exist=exist)
            else
               exist = .true.
            end if
            dowhile (exist)
               write (iout,20)
   20          format (/,' Enter File Name for Coordinate Output :  ',$)
               read (input,30)  filename
   30          format (a60)
               inquire (file=filename,exist=exist)
            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     ##  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
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'files.i'
      include 'hescut.i'
      include 'iounit.i'
      include 'math.i'
      include 'units.i'
      integer i,j,k,m
      integer ixyz,ihess
      integer lext,freeunit
      integer nfreq,ndummy
      integer nvib,ivib,nview
      integer hinit(3,maxatm)
      integer hstop(3,maxatm)
      integer hindex(maxhess)
      real*8 factor,vnorm,ratio
      real*8 h(maxhess),hdiag(3,maxatm)
      real*8 xref(maxatm),yref(maxatm)
      real*8 zref(maxatm)
      real*8 mass2(maxatm)
      real*8 matrix((maxvib+1)*maxvib/2)
      real*8 eigen(maxvib)
      real*8 vects(maxvib,maxvib)
      real*8 a(maxvib+1),b(maxvib+1)
      real*8 p(maxvib+1),w(maxvib+1)
      real*8 ta(maxvib+1),tb(maxvib+1)
      real*8 ty(maxvib+1)
      logical exist,query
      character*1 eigunits(maxvib)
      character*7 ext
      character*60 coordfile
      character*60 string
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
c
c     initialize various things needed for vibrations
c
      nfreq = 3 * n
      ndummy = 0
      if (nfreq.gt.maxvib .or. nfreq**2.gt.maxhess) then
         write (iout,10)
   10    format (/,' VIBRATE  --  Too many Atoms in the Molecule')
         call fatal
      end if
      do i = 1, n
         if (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
         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     perform diagonalization to get Hessian eigenvalues
c
      call diagq (nfreq,maxvib,nfreq,matrix,eigen,vects,
     &                     a,b,p,w,ta,tb,ty)
      write (iout,20)
   20 format (/,' Eigenvalues of the Hessian Matrix :',/)
      write (iout,30)  (i,eigen(i),i=1,nvib)
   30 format (5(i5,f9.3,1x))
      write (iout,40)
   40 format ()
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     diagonalize to get vibrational frequencies and normal modes
c
      call diagq (nfreq,maxvib,nfreq,matrix,eigen,vects,
     &                     a,b,p,w,ta,tb,ty)
      factor = sqrt(convert) / (2.0d0*pi*lightspd)
      do i = 1, nvib
         if (eigen(i) .lt. 0) then
            eigunits(i) = 'I'
         else
            eigunits(i) = ' '
         end if
         eigen(i) = factor * sqrt(abs(eigen(i)))
      end do
      write (iout,50)
   50 format (/,' Vibrational Frequencies (cm-1) :',/)
      write (iout,60)  (i,eigen(i),eigunits(i),i=1,nvib)
   60 format (5(i5,f9.3,a1))
c
c     form Cartesian coordinate displacements from normal modes
c
      do i = 1, nvib
         vnorm = 0.0d0
         do j = 1, nfreq
            k = (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     decide upon the vibrations to be output to a disk file
c
      query = .true.
   70 continue
      ivib = 0
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=80,end=80)  ivib
         query = .false.
      end if
   80 continue
      if (query) then
         write (iout,90)
   90    format (/,' Enter the Number of the Vibration',
     &              ' to be Output :  ',$)
         read (input,100)  ivib
  100    format (i10)
      end if
c
c     print the vibrational frequency and normal mode
c
      if (ivib.ge.1 .and. ivib.le.nvib) then
         write (iout,110)  ivib,eigen(ivib),eigunits(ivib)
  110    format (/,' Vibrational Normal Mode',i5,' with Frequency',
     &              f10.2,a1,' cm-1',
     &           //,5x,'Atom',5x,'Delta X',5x,'Delta Y',5x,'Delta Z',/)
         do i = 1, n
            j = 3 * (i-1)
            write (iout,120)  i,vects(j+1,ivib),vects(j+2,ivib),
     &                        vects(j+3,ivib)
  120       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)
         coordfile = filename(1:leng)//'.'//ext(1:lext)
         ixyz = freeunit ()
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,status='new')
c
c     store the original atomic coordinates
c
         do i = 1, n
            xref(i) = x(i)
            yref(i) = y(i)
            zref(i) = z(i)
         end do
c
c     make file with plus and minus the current vibration
c
         nview = 3
         do i = -nview, nview
            ratio = i / dble(nview)
            do k = 1, n
               j = 3 * (k-1)
               x(k) = xref(k) + ratio*vects(j+1,ivib)
               y(k) = yref(k) + ratio*vects(j+2,ivib)
               z(k) = zref(k) + ratio*vects(j+3,ivib)
            end do
            call prtxyz (ixyz)
         end do
         close (unit=ixyz)
c
c     restore the original coordinates; get next vibration
c
         do i = 1, n
            x(i) = xref(i)
            y(i) = yref(i)
            z(i) = zref(i)
         end do
         goto 70
      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 vibrot  --  vibrational analysis over torsions  ##
c     ##                                                          ##
c     ##############################################################
c
c
      program vibrot
      implicit none
      include 'sizes.i'
      include 'iounit.i'
      include 'omega.i'
      integer i,j,ihess
      real*8 hrot(maxrot,maxrot)
      real*8 matrix((maxrot+1)*maxrot/2)
      real*8 eigen(maxrot)
      real*8 vects(maxrot,maxrot)
      real*8 a(maxrot+1),b(maxrot+1)
      real*8 p(maxrot+1),w(maxrot+1)
      real*8 ta(maxrot+1),tb(maxrot+1)
      real*8 ty(maxrot+1)
c
c
c     compute torsional Hessian matrix elements
c
      call initial
      call getint
      call mechanic
      call initrot
      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)  (hrot(i,i),i=1,nomega)
   20 format (6f13.4)
c
c     write out the torsional Hessian elements
c
      write (iout,30)
   30 format (/,' Torsional Hessian Matrix Elements :',/)
      do i = 1, nomega
         write (iout,40)  (hrot(j,i),j=1,nomega)
   40    format (6f13.4)
      end do
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,maxrot,nomega,matrix,eigen,vects,
     &                      a,b,p,w,ta,tb,ty)
      write (iout,50)
   50 format (/,' Eigenvalues of the Hessian Matrix :',/)
      write (iout,60)  (eigen(i),i=1,nomega)
   60 format (6d13.4)
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 volume  --  excluded volume term via Connolly  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "volume" calculates the excluded volume via the Connolly
c     analytical volume and surface area algorithm
c
c
      subroutine volume (volume_tot,radius,exclude)
      implicit none
      include 'sizes.i'
      real*8 exclude,probe
      real*8 volume_tot,area_tot
      real*8 radius(maxatm)
c
c
c     make call to the volume and surface area routine
c
      probe = 0.0d0
      call connolly (volume_tot,area_tot,radius,probe,exclude)
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 1990 by Craig Kundrot & Jay William Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine volume1  --  Cartesian excluded volume derivs  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "volume1" calculates first derivatives of the total excluded
c     volume with respect to the Cartesian coordinates of each atom
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 volume1 (radius,probe,dex)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'math.i'
      integer maxcube,maxarc
      parameter (maxcube=15)
      parameter (maxarc=300)
      integer i,j,k,m
      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 itab(maxatm)
      integer inov(maxarc)
      integer cube(2,maxcube,maxcube,maxcube)
      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 xr,yr,zr
      real*8 dist2,vdwsum
      real*8 probe,zstep
      real*8 dex(3,maxatm)
      real*8 radius(maxatm)
      real*8 vdwrad(maxatm)
      real*8 arci(maxarc)
      real*8 arcf(maxarc)
      real*8 dx(maxarc),dy(maxarc)
      real*8 dsq(maxarc),d(maxarc)
      logical skip(maxatm)
c
c
c     fix the stepsize in the z-direction; this value sets
c     the accuracy of the numerical derivatives; zstep=0.06
c     is a good balance between compute time and accuracy
c
      zstep = 0.0601d0
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     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
         vdwrad(i) = radius(i)
         if (vdwrad(i) .eq. 0.0d0) then
            skip(i) = .true.
         else
            skip(i) = .false.
            vdwrad(i) = vdwrad(i) + probe
            if (vdwrad(i) .gt. rmax)  rmax = vdwrad(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 (/,' VOLUME1  --  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 = vdwrad(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 (/,' VOLUME1  --  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+vdwrad(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
            dowhile (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 = vdwrad(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 (/,' VOLUME1  --  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
                  dowhile (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
      return
      end
c
c
c     ################################################################
c     ##  COPYRIGHT (C) 1990 by Craig Kundrot & Jay William Ponder  ##
c     ##                    All Rights Reserved                     ##
c     ################################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine volume2  --  Cartesian excluded volume Hessian  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "volume2" calculates second derivatives of the total excluded
c     volume with respect to the Cartesian coordinates of the atoms
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 volume2 (iatom,radius,probe,xhess,yhess,zhess)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'iounit.i'
      include 'math.i'
      integer maxarc
      parameter (maxarc=300)
      integer i,j,k,m
      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 probe,zstep,xr,yr,zr
      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),dy(maxarc)
      real*8 dsq(maxarc),d(maxarc)
      real*8 radius(maxatm)
      real*8 vdwrad(maxatm)
      real*8 xhess(3,maxatm)
      real*8 yhess(3,maxatm)
      real*8 zhess(3,maxatm)
      logical covered
c
c
c     fix the stepsize in the z-direction; this value sets
c     the accuracy of the numerical derivatives; zstep=0.06
c     is a good balance between compute time and accuracy
c
      zstep = 0.0601d0
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 (radius(iatom) .eq. 0.0d0)  return
      pix2 = 2.0d0 * pi
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
         vdwrad(i) = radius(i)
         if (vdwrad(i) .ne. 0.0d0)  vdwrad(i) = vdwrad(i) + probe
      end do
c
c     set the radius and coordinates for current atom
c
      rr = vdwrad(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. vdwrad(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 = (vdwrad(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 (/,' VOLUME2  --  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
         dowhile (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.
            dowhile (.not.covered .and. k.lt.nnear
     &                   .and. narc.lt.maxarc)
               k = k + 1
               in = inear(k)
               rinsq = vdwrad(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 (/,' VOLUME2  -- 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
               dowhile (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(vdwrad(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
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine writeout  --  update the optimization results  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "writeout" is used by each of the optimization routines
c     to save imtermediate atomic coordinates to a disk file
c
c
      subroutine writeout (xx,ncycle)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'files.i'
      include 'math.i'
      include 'omega.i'
      include 'output.i'
      include 'scales.i'
      include 'usage.i'
      include 'zcoord.i'
      integer i,iwrt
      integer lext,freeunit
      integer nvar,ncycle
      real*8 xx(maxvar)
      character*3 status
      character*7 ext
      character*60 coordfile
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
            do i = 1, 3*n
               scale(i) = 1.0d0
            end do
         else if (coordtype .eq. 'internal') then
            do i = 1, nomega
               scale(i) = 1.0d0
            end do
         end if
      end if
c
c     transform optimization parameters back to coordinates
c
      if (coordtype .eq. 'cartesian') then
         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
      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     get the name to be used for the coordinates file
c
      if (cyclesave) then
         lext = 3
         call numeral (ncycle,ext,lext)
         coordfile = filename(1:leng)//'.'//ext(1:lext)
         status = 'new'
      else
         coordfile = outfile
         status = 'old'
      end if
c
c     open and then update the coordinates file
c
      iwrt = freeunit ()
      call version (coordfile,status)
      open (unit=iwrt,file=coordfile,status=status)
      if (status .eq. 'old')  rewind (unit=iwrt)
      if (coordtype .eq. 'cartesian') then
         call prtxyz (iwrt)
      else if (coordtype .eq. 'internal') then
         call prtint (iwrt)
      else if (coordtype .eq. 'rigidbody') then
         call prtxyz (iwrt)
      end if
      close (unit=iwrt)
      return
      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 crystal structures  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "xtalfit" computes an optimized set of potential energy
c     parameters for user specified van der Waals and electrostatic
c     interactions by fitting to crystal structure, lattice energy
c     and monomer dipole moment data
c
c
      program xtalfit
      implicit none
      include 'sizes.i'
      integer maxlsq,maxrsd
      parameter (maxlsq=50)
      parameter (maxrsd=100)
      include 'files.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'potent.i'
      include 'xtals.i'
      integer i,atom1,atom2
      integer nresid,ixtal,prmtyp
      real*8 grdmin,xx(maxlsq)
      real*8 xhi(maxlsq),xlo(maxlsq)
      real*8 f(maxrsd),g(maxlsq)
      real*8 jacobian(maxrsd,maxlsq)
      logical exist,query
      character*20 label(6)
      character*80 record,string
      external xtalerr,xtalwrt
c
c
c     initialize some variables and print the header information
c
      call initial
      nvary = 0
      nresid = 0
      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')
c
c     get the types of potential parameters to be optimized
c
      query = .true.
      dowhile (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 Type(s) :  ',$)
            read (input,40)  record
   40       format (a80)
            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
            if (prmtyp .lt. 5) then
               vary(1,nvary) = atom1
            else
               vary(1,nvary) = min(atom1,atom2)
               vary(2,nvary) = max(atom1,atom2)
            end if
         end if
      end do
c
c     get the 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 number of crystal structures to include 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 Crystals to be Used [1] :  ',$)
         read (input,110)  nxtal
  110    format (i10)
      end if
      if (nxtal .eq. 0)  nxtal = 1
c
c     get the structural data for each crystal in turn
c
      do ixtal = 1, nxtal
         call getxyz
         call mechanic
c
c     get an ideal value for the crystal lattice energy
c
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=120,end=120)  e0_lattice
            query = .false.
         end if
  120    continue
         if (query) then
            write (iout,130)
  130       format (/,' Enter Lattice Energy Value [<CR> to omit]',
     &                 ' :  ',$)
            read (input,140)  e0_lattice
  140       format (f20.0)
         end if
         if (e0_lattice .gt. 0.0d0)  e0_lattice = -e0_lattice
c
c     get an ideal value for the monomer dipole moment
c
         query = .true.
         call nextarg (string,exist)
         if (exist) then
            read (string,*,err=150,end=150)  moment_0
            query = .false.
         end if
  150    continue
         if (query) then
            write (iout,160)
  160       format (/,' Enter Dipole Moment Value [<CR> to omit]',
     &                 ' :   ',$)
            read (input,170)  moment_0
  170       format (f20.0)
         end if
c
c     set the types of residuals for use in optimization
c
         do i = 1, 6
            iresid(nresid+i) = ixtal
         end do
         rsdtyp(nresid+1) = 'Force a-Axis'
         rsdtyp(nresid+2) = 'Force b-Axis'
         rsdtyp(nresid+3) = 'Force c-Axis'
         rsdtyp(nresid+4) = 'Force Alpha'
         rsdtyp(nresid+5) = 'Force Beta'
         rsdtyp(nresid+6) = 'Force Gamma'
         nresid = nresid + 6
c
c     print molecules per unit cell, lattice energy and dipole
c
         write (iout,180)  ixtal,filename(1:35),nmol
  180    format (/,' File Name of Crystal Structure',i4,' :  ',5x,a35,
     &           /,' Number of Molecules per Unit Cell :',i13)
         if (e0_lattice .ne. 0.0d0) then
            nresid = nresid + 1
            iresid(nresid) = ixtal
            rsdtyp(nresid) = 'Lattice Energy'
            write (iout,190)  e0_lattice
  190       format (' Value of Crystal Lattice Energy :  ',f13.2)
         end if
         if (moment_0 .ne. 0.0d0) then
            nresid = nresid + 1
            iresid(nresid) = ixtal
            rsdtyp(nresid) = 'Dipole Moment'
            write (iout,200)  moment_0
  200       format (' Value of Molecular Dipole Moment : ',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
      use_bond = .false.
      use_angle = .false.
      use_strbnd = .false.
      use_urey = .false.
      use_angang = .false.
      use_improp = .false.
      use_imptor = .false.
      use_tors = .false.
      use_strtor = .false.
      use_solv = .false.
      use_geom = .false.
      use_extra = .false.
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'
      do i = 1, nvary
         vartyp(i) = label(ivary(i))
      end do
c
c     print the initial parameter values
c
      write (iout,210)
  210 format (/,' Initial Values of the Parameters :',/)
      do i = 1, nvary
         if (ivary(i) .lt. 5) then
            write (iout,220)  i,vartyp(i),vary(1,i),xx(i)
  220       format (3x,'(',i2,')',2x,a20,'Atom Type',i4,4x,f12.4)
         else
            write (iout,230)  i,vartyp(i),vary(1,i),vary(2,i),xx(i)
  230       format (3x,'(',i2,')',2x,a20,'Bond Type',2i4,f12.4)
         end if
      end do
c
c     set upper and lower bounds based on the parameter type
c
      do i = 1, nvary
         if (ivary(i) .eq. 1) then
            xlo(i) = 0.9d0 * xx(i)
            xhi(i) = 1.1d0 * xx(i)
         else if (ivary(i) .eq. 2) then
            xlo(i) = 0.8d0 * xx(i)
            xhi(i) = 1.2d0 * xx(i)
         else if (ivary(i) .eq. 3) then
            xlo(i) = 0.8d0 * xx(i)
            xhi(i) = 1.2d0 * xx(i)
            if (xhi(i) .gt. 1.0d0)  xhi(i) = 1.0d0
         else if (ivary(i) .eq. 4) then
            xlo(i) = min(xx(i)-0.2d0*abs(xx(i)),xx(i)-0.2d0)
            xhi(i) = max(xx(i)+0.2d0*abs(xx(i)),xx(i)+0.2d0)
         else if (ivary(i) .eq. 5) then
            xlo(i) = min(xx(i)-0.2d0*abs(xx(i)),xx(i)-0.2d0)
            xhi(i) = max(xx(i)+0.2d0*abs(xx(i)),xx(i)+0.2d0)
         else if (ivary(i) .eq. 6) then
            xlo(i) = 0.8d0 * xx(i)
            xhi(i) = 1.2d0 * xx(i)
            if (xlo(i) .lt. 0.2d0)  xhi(i) = 0.2d0
            if (xhi(i) .gt. 0.8d0)  xhi(i) = 0.8d0
         end if
      end do
c
c     use nonlinear least squares to refine the parameters
c
      call square (nresid,nvary,xlo,xhi,xx,f,g,jacobian,
     &                maxrsd,grdmin,xtalerr,xtalwrt)
c
c     print the final parameter values
c
      write (iout,240)
  240 format (/,' Final Values of the Parameters and Scaled',
     &            ' Derivatives :',/)
      do i = 1, nvary
         if (ivary(i) .lt. 5) then
            write (iout,250)  i,vartyp(i),vary(1,i),xx(i),g(i)
  250       format (3x,'(',i2,')',2x,a20,'Atom Type',i4,4x,2f12.4)
         else
            write (iout,260)  i,vartyp(i),vary(1,i),vary(2,i),xx(i),g(i)
  260       format (3x,'(',i2,')',2x,a20,'Bond Type',2i4,2f12.4)
         end if
      end do
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 crystal structure; used
c     to make a previously stored structure the currently active
c     structure, or to store a structure for later use; only
c     the intermolecular energy terms are provided for
c
c
      subroutine xtalprm (mode,ixtal,xx)
      implicit none
      include 'sizes.i'
      integer maxxtal,maxlsq,maxrsd
      parameter (maxxtal=10)
      parameter (maxlsq=50)
      parameter (maxrsd=100)
      include 'atoms.i'
      include 'atmtyp.i'
      include 'boxes.i'
      include 'charge.i'
      include 'couple.i'
      include 'dipole.i'
      include 'fracs.i'
      include 'kvdws.i'
      include 'molcul.i'
      include 'vdw.i'
      include 'xtals.i'
      integer i,j,k
      integer ixtal,prmtyp
      integer atom1,atom2
      integer ns(maxxtal)
      integer types(maxatm,maxxtal)
      integer n12s(maxatm,maxxtal)
      integer i12s(4,maxatm,maxxtal)
      integer n13s(maxatm,maxxtal)
      integer i13s(12,maxatm,maxxtal)
      integer n14s(maxatm,maxxtal)
      integer i14s(36,maxatm,maxxtal)
      integer nvdws(maxxtal)
      integer ivdws(maxatm,maxxtal)
      integer ireds(maxatm,maxxtal)
      integer nions(maxxtal)
      integer iions(maxatm,maxxtal)
      integer ndipoles(maxxtal)
      integer idpls(2,maxbnd,maxxtal)
      real*8 xx(maxlsq)
      real*8 xs(maxatm,maxxtal)
      real*8 ys(maxatm,maxxtal)
      real*8 zs(maxatm,maxxtal)
      real*8 masses(maxatm,maxxtal)
      real*8 pchgs(maxatm,maxxtal)
      real*8 bdpls(maxbnd,maxxtal)
      real*8 sdpls(maxbnd,maxxtal)
      real*8 kreds(maxatm,maxxtal)
      real*8 e0_lattices(maxxtal)
      real*8 moment_0s(maxxtal)
      real*8 xmid,ymid,zmid
      real*8 xfracs(maxatm,maxxtal)
      real*8 yfracs(maxatm,maxxtal)
      real*8 zfracs(maxatm,maxxtal)
      real*8 xboxs(maxxtal)
      real*8 yboxs(maxxtal)
      real*8 zboxs(maxxtal)
      real*8 alphas(maxxtal)
      real*8 betas(maxxtal)
      real*8 gammas(maxxtal)
      character*3 names(maxatm,maxxtal)
      character*5 mode
      save ns,types,names
      save nvdws,ivdws
      save ireds,kreds
      save nions,iions
      save ndipoles,idpls
      save n12s,n13s,n14s
      save i12s,i13s,i14s
      save xs,ys,zs,masses
      save pchgs,bdpls,sdpls
      save e0_lattices,moment_0s
      save xfracs,yfracs,zfracs
      save xboxs,yboxs,zboxs
      save alphas,betas,gammas
c
c
c     number of atoms and their coordinates and types
c
      if (mode .eq. 'store') then
         ns(ixtal) = n
         do i = 1, n
            xs(i,ixtal) = x(i)
            ys(i,ixtal) = y(i)
            zs(i,ixtal) = z(i)
            types(i,ixtal) = type(i)
            names(i,ixtal) = name(i)
            masses(i,ixtal) = mass(i)
         end do
      else if (mode .eq. 'reset') then
         n = ns(ixtal)
         do i = 1, n
            x(i) = xs(i,ixtal)
            y(i) = ys(i,ixtal)
            z(i) = zs(i,ixtal)
            type(i) = types(i,ixtal)
            name(i) = names(i,ixtal)
            mass(i) = masses(i,ixtal)
         end do
      end if
c
c     neighbor attachment lists
c
      if (mode .eq. 'store') then
         do i = 1, n
            n12s(i,ixtal) = n12(i)
            do j = 1, n12(i)
               i12s(j,i,ixtal) = i12(j,i)
            end do
            n13s(i,ixtal) = n13(i)
            do j = 1, n13(i)
               i13s(j,i,ixtal) = i13(j,i)
            end do
            n14s(i,ixtal) = n14(i)
            do j = 1, n14(i)
               i14s(j,i,ixtal) = i14(j,i)
            end do
         end do
      else if (mode .eq. 'reset') then
         do i = 1, n
            n12(i) = n12s(i,ixtal)
            do j = 1, n12(i)
               i12(j,i) = i12s(j,i,ixtal)
            end do
            n13(i) = n13s(i,ixtal)
            do j = 1, n13(i)
               i13(j,i) = i13s(j,i,ixtal)
            end do
            n14(i) = n14s(i,ixtal)
            do j = 1, n14(i)
               i14(j,i) = i14s(j,i,ixtal)
            end do
         end do
      end if
c
c     lattice type and unit cell parameters
c
      if (mode .eq. 'store') then
         xboxs(ixtal) = xbox
         yboxs(ixtal) = ybox
         zboxs(ixtal) = zbox
         alphas(ixtal) = alpha
         betas(ixtal) = beta
         gammas(ixtal) = gamma
      else if (mode .eq. 'reset') then
         xbox = xboxs(ixtal)
         ybox = yboxs(ixtal)
         zbox = zboxs(ixtal)
         alpha = alphas(ixtal)
         beta = betas(ixtal)
         gamma = gammas(ixtal)
      end if
c
c     find number of molecules and atoms in molecules;
c     type of crystal lattice; enforce periodic bounds
c
      if (mode .eq. 'reset') then
         call molecule
         call lattice
         call bounds
      end if
c
c     fractional coordinates of molecular center of mass
c
      if (mode .eq. 'store') then
         do i = 1, nmol
            xmid = 0.0d0
            ymid = 0.0d0
            zmid = 0.0d0
            do j = imol(1,i), imol(2,i)
               k = kmol(j)
               xmid = xmid + x(k)*mass(k)
               ymid = ymid + y(k)*mass(k)
               zmid = zmid + z(k)*mass(k)
            end do
            zmid = zmid / gamma_term
            ymid = (ymid - zmid*beta_term) / gamma_sin
            xmid = xmid - ymid*gamma_cos - zmid*beta_cos
            xfracs(i,ixtal) = xmid / (xbox * molmass(i))
            yfracs(i,ixtal) = ymid / (ybox * molmass(i))
            zfracs(i,ixtal) = zmid / (zbox * molmass(i))
         end do
      else if (mode .eq. 'reset') then
         do i = 1, nmol
            xfrac(i) = xfracs(i,ixtal)
            yfrac(i) = yfracs(i,ixtal)
            zfrac(i) = zfracs(i,ixtal)
         end do
      end if
c
c     number and types of van der Waals sites
c
      if (mode .eq. 'store') then
         nvdws(ixtal) = nvdw
         do i = 1, n
            ivdws(i,ixtal) = ivdw(i)
            ireds(i,ixtal) = ired(i)
            kreds(i,ixtal) = kred(i)
         end do
      else if (mode .eq. 'reset') then
         nvdw = nvdws(ixtal)
         do i = 1, n
            ivdw(i) = ivdws(i,ixtal)
            ired(i) = ireds(i,ixtal)
            kred(i) = kreds(i,ixtal)
         end do
      end if
c
c     number and types of atomic partial charges
c
      if (mode .eq. 'store') then
         nions(ixtal) = nion
         do i = 1, nion
            iions(i,ixtal) = iion(i)
            pchgs(i,ixtal) = pchg(i)
         end do
      else if (mode .eq. 'reset') then
         nion = nions(ixtal)
         do i = 1, nion
            iion(i) = iions(i,ixtal)
            pchg(i) = pchgs(i,ixtal)
         end do
      end if
c
c     number and types of bond dipole moments
c
      if (mode .eq. 'store') then
         ndipoles(ixtal) = ndipole
         do i = 1, ndipole
            idpls(1,i,ixtal) = idpl(1,i)
            idpls(2,i,ixtal) = idpl(2,i)
            bdpls(i,ixtal) = bdpl(i)
            sdpls(i,ixtal) = sdpl(i)
         end do
      else if (mode .eq. 'reset') then
         ndipole = ndipoles(ixtal)
         do i = 1, ndipole
            idpl(1,i) = idpls(1,i,ixtal)
            idpl(2,i) = idpls(2,i,ixtal)
            bdpl(i) = bdpls(i,ixtal)
            sdpl(i) = sdpls(i,ixtal)
         end do
      end if
c
c     values of ideal lattice energy and dipole moment
c
      if (mode .eq. 'store') then
         e0_lattices(ixtal) = e0_lattice
         moment_0s(ixtal) = moment_0
      else if (mode .eq. 'reset') then
         e0_lattice = e0_lattices(ixtal)
         moment_0 = moment_0s(ixtal)
      end if
c
c     store or reset values of the optimization variables
c
      do j = 1, nvary
         prmtyp = ivary(j)
         atom1 = vary(1,j)
         if (prmtyp .eq. 1) then
            if (mode .eq. 'store') then
               xx(j) = rad(atom1)
            else if (mode .eq. 'reset') then
               rad(atom1) = xx(j)
               do i = 1, maxtyp
                  radmin(i,atom1) = rad(i) + rad(atom1)
                  radmin(atom1,i) = radmin(i,atom1)
               end do
            end if
         else if (prmtyp .eq. 2) then
            if (mode .eq. 'store') then
               xx(j) = eps(atom1)
            else if (mode .eq. 'reset') then
               eps(atom1) = abs(xx(j))
               do i = 1, maxtyp
                  epsilon(i,atom1) = sqrt(eps(i) * eps(atom1))
                  epsilon(atom1,i) = epsilon(i,atom1)
               end do
            end if
         else if (prmtyp .eq. 3) then
            if (mode .eq. 'store') then
               do i = 1, n
                  if (type(i) .eq. atom1) then
                     xx(j) = kred(i)
                     goto 10
                  end if
               end do
            else if (mode .eq. 'reset') then
               do i = 1, n
                  if (type(i) .eq. atom1)  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. atom1) then
                     xx(j) = pchg(i)
                     goto 10
                  end if
               end do
            else if (mode .eq. 'reset') then
               do i = 1, n
                  if (type(iion(i)) .eq. atom1)  pchg(i) = xx(j)
               end do
            end if
         else if (prmtyp .eq. 5) then
            atom2 = vary(2,j)
            if (mode .eq. 'store') then
               do i = 1, ndipole
                  if (type(idpl(1,i)).eq.atom1 .and.
     &                type(idpl(2,i)).eq.atom2) 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.atom1 .and.
     &                type(idpl(2,i)).eq.atom2)  bdpl(i) = xx(j)
               end do
            end if
         else if (prmtyp .eq. 6) then
            atom2 = vary(2,j)
            if (mode .eq. 'store') then
               do i = 1, ndipole
                  if (type(idpl(1,i)).eq.atom1 .and.
     &                type(idpl(2,i)).eq.atom2) 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.atom1 .and.
     &                type(idpl(2,i)).eq.atom2)  sdpl(i) = xx(j)
               end do
            end if
         end if
   10    continue
      end do
      return
      end
c
c
c     ##########################################################
c     ##                                                      ##
c     ##  subroutine xtalerr  --  error function for xtalfit  ##
c     ##                                                      ##
c     ##########################################################
c
c
      subroutine xtalerr (nresid,nvaried,xx,resid)
      implicit none
      include 'sizes.i'
      integer maxlsq,maxrsd
      parameter (maxlsq=50)
      parameter (maxrsd=100)
      include 'atoms.i'
      include 'boxes.i'
      include 'bound.i'
      include 'charge.i'
      include 'dipole.i'
      include 'math.i'
      include 'molcul.i'
      include 'vdw.i'
      include 'xtals.i'
      integer i,i1,i2,ixtal
      integer nresid,nvaried
      integer n_old,nvdw_old
      integer ndipole_old,nion_old
      real*8 energy,eps,temp
      real*8 e_xtal,e_monomer
      real*8 e_lattice,moment
      real*8 xi,yi,zi,fik
      real*8 x_dpm,y_dpm,z_dpm
      real*8 e_xbox,e_ybox,e_zbox
      real*8 e_alpha,e_beta,e_gamma
      real*8 g_xbox,g_ybox,g_zbox
      real*8 g_alpha,g_beta,g_gamma
      real*8 xx(maxlsq),resid(maxrsd)
c
c
c     zero out the number of residual functions
c
      nresid = 0
c
c     set the values of the potential energy parameters
c     and get the energy of the base structure
c
      do ixtal = 1, nxtal
         call xtalprm ('reset',ixtal,xx)
         e_xtal = energy ()
c
c     get energy derivative with respect to lattice a-axis
c
         eps = 0.00001d0
         temp = xbox
         xbox = xbox + eps
         call xtalmove
         e_xbox = energy ()
         xbox = temp
         g_xbox = (e_xbox - e_xtal) / eps
c
c     get energy derivative with respect to lattice b-axis
c
         temp = ybox
         ybox = ybox + eps
         call xtalmove
         e_ybox = energy ()
         ybox = temp
         g_ybox = (e_ybox - e_xtal) / eps
c
c     get energy derivative with respect to lattice c-axis
c
         temp = zbox
         zbox = zbox + eps
         call xtalmove
         e_zbox = energy ()
         zbox = temp
         g_zbox = (e_zbox - e_xtal) / eps
c
c     get energy derivative with respect to lattice alpha
c
         temp = alpha
         alpha = alpha + radian*eps
         call xtalmove
         e_alpha = energy ()
         alpha = temp
         g_alpha = (e_alpha - e_xtal) / eps
c
c     get energy derivative with respect to lattice beta
c
         temp = beta
         beta = beta + radian*eps
         call xtalmove
         e_beta = energy ()
         beta = temp
         g_beta = (e_beta - e_xtal) / eps
c
c     get energy derivative with respect to lattice gamma
c
         temp = gamma
         gamma = gamma + radian*eps
         call xtalmove
         e_gamma = energy ()
         gamma = temp
         g_gamma = (e_gamma - e_xtal) / eps
         call xtalmove
c
c     setup to compute properties of monomer; assumes that
c     molecules are contiguous in the coordinates file
c
         use_image = .false.
         use_replica = .false.
         n_old = n
         nvdw_old = nvdw
         nion_old = nion
         ndipole_old = ndipole
         n = n / nmol
         nvdw = nvdw / nmol
         nion = nion / nmol
         ndipole = ndipole / nmol
c
c     compute the crystal lattice energy
c
         e_monomer = energy ()
         e_lattice = (e_xtal - nmol*e_monomer) / dble(nmol)
c
c     compute the dipole moment of the monomer
c
         x_dpm = 0.0d0
         y_dpm = 0.0d0
         z_dpm = 0.0d0
         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)
            fik = bdpl(i) / sqrt(xi*xi + yi*yi + zi*zi)
            x_dpm = x_dpm - xi*fik
            y_dpm = y_dpm - yi*fik
            z_dpm = z_dpm - zi*fik
         end do
         moment = sqrt(x_dpm**2 + y_dpm**2 + z_dpm**2)
c
c     convert back from monomer to full crystal
c
         n = n_old
         nvdw = nvdw_old
         nion = nion_old
         ndipole = ndipole_old
         use_image = .true.
         use_replica = .true.
c
c     compute the residual vector as a collection
c     of the forces on the crystal lattice, plus any
c     lattice energy and dipole moment deviations
c
         nresid = nresid + 1
         resid(nresid) = g_xbox
         nresid = nresid + 1
         resid(nresid) = g_ybox
         nresid = nresid + 1
         resid(nresid) = g_zbox
         nresid = nresid + 1
         resid(nresid) = g_alpha
         nresid = nresid + 1
         resid(nresid) = g_beta
         nresid = nresid + 1
         resid(nresid) = g_gamma
         if (e0_lattice .ne. 0.0d0) then
            nresid = nresid + 1
            resid(nresid) = e_lattice - e0_lattice
         end if
         if (moment_0 .ne. 0.0d0) then
            nresid = nresid + 1
            resid(nresid) = 2.0d0 * (moment-moment_0)
         end if
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine xtalmove  --  translation of rigid molecules  ##
c     ##                                                           ##
c     ###############################################################
c
c
      subroutine xtalmove
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'centre.i'
      include 'fracs.i'
      include 'molcul.i'
      integer i,j,k
      real*8 xmid,ymid,zmid
c
c
c     get values for fractional coordinate interconversion
c
      call lattice
c
c     convert fractional center of mass to Cartesian
c
      do i = 1, nmol
         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     position the molecule based upon center of mass
c
         do j = imol(1,i), imol(2,i)
            k = kmol(j)
            x(k) = xmid + xcm(k)
            y(k) = ymid + ycm(k)
            z(k) = zmid + zcm(k)
         end do
      end do
      return
      end
c
c
c     ########################################################
c     ##                                                    ##
c     ##  subroutine xtalwrt  --  write current parameters  ##
c     ##                                                    ##
c     ########################################################
c
c
      subroutine xtalwrt (niter,xx,gs,nresid,f)
      implicit none
      integer maxlsq,maxrsd
      parameter (maxlsq=50)
      parameter (maxrsd=100)
      include 'iounit.i'
      include 'xtals.i'
      integer i,niter,nresid
      real*8 xx(maxlsq)
      real*8 gs(maxlsq)
      real*8 f(maxrsd)
c
c
c     write the values of parameters and scaled derivatives
c
      write (iout,10)  niter
   10 format (/,' Parameters and Scaled Derivatives at',
     &          ' Iteration',i4,' :',/)
      do i = 1, nvary
         if (ivary(i) .lt. 5) then
            write (iout,20)  i,vartyp(i),vary(1,i),xx(i),gs(i)
   20       format (3x,'(',i2,')',2x,a20,'Atom Type',i4,4x,2f12.4)
         else
            write (iout,30)  i,vartyp(i),vary(1,i),vary(2,i),xx(i),gs(i)
   30       format (3x,'(',i2,')',2x,a20,'Bond Type',2i4,2f12.4)
         end if
      end do
c
c     write the values of the residual functions
c
      write (iout,40)  niter
   40 format (/,' Residual Error Function Values at Iteration',
     &           i4,' :',/)
      do i = 1, nresid
         write (iout,50)  i,rsdtyp(i),iresid(i),f(i)
   50    format (3x,'(',i2,')',2x,a20,2x,'Crystal',i4,4x,f12.4)
      end do
      write (iout,60)
   60 format ()
      return
      end
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  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     alternating cycles of truncated Newton optimization over
c     atomic coordinates with variable metric optimization over
c     the six lattice dimensions and angles
c
c
      program xtalmin
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'boxes.i'
      include 'files.i'
      include 'iounit.i'
      include 'minima.i'
      include 'output.i'
      integer i,j,imin,nvar
      integer ncycle,freeunit
      real*8 minimum,grdmin
      real*8 gnorm,grms
      real*8 anorm,arms
      real*8 xx(maxvar)
      real*8 derivs(3,maxatm)
      real*8 x_lat(6),g_lat(6)
      real*8 xtalmol1,xtallat1
      logical exist,done
      character*6 mode,method
      character*60 minfile
      character*80 string
      external xtalmol1,xtalmol2
      external xtallat1,writeout
c
c
c     set up the structure and mechanics calculation
c
      call initial
      call getxyz
      call mechanic
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.1] :  ',$)
         read (input,30)  grdmin
   30    format (f20.0)
      end if
      if (grdmin .le. 0.0d0)  grdmin = 0.1d0
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 a cycle of optimization on atomic coordinates
c
      done = .false.
      ncycle = 0
      dowhile (.not. done)
         ncycle = ncycle + 1
         mode = 'dtncg '
         method = 'auto  '
         coordtype = 'cartesian'
         maxiter = 1
         nextiter = ncycle
         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
         call lattice
         call tncg (mode,method,nvar,xx,minimum,grdmin,
     &                  xtalmol1,xtalmol2,writeout)
         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
         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(nvar/3))
         if (grms .lt. grdmin) then
            done = .true.
            arms = grms
            anorm = gnorm
         end if
c
c     write out the current values of the lattice parameters
c
         write (iout,40)  xbox,ybox,zbox,alpha,beta,gamma
   40    format (/,' Unit Cell Dimensions :      a    =',f10.4,
     &           /,'                             b    =',f10.4,
     &           /,'                             c    =',f10.4,
     &           /,'                            Alpha =',f10.4,
     &           /,'                            Beta  =',f10.4,
     &           /,'                            Gamma =',f10.4)
c
c     perform a few optimization cycles on lattice parameters
c
         coordtype = 'none'
         maxiter = 3
         nextiter = 1
         hguess = 0.1d0
         nvar = 6
         x_lat(1) = xbox
         x_lat(2) = ybox
         x_lat(3) = zbox
         x_lat(4) = alpha
         x_lat(5) = beta
         x_lat(6) = gamma
         if (done) then
            minimum = xtallat1 (x_lat,g_lat)
            gnorm = 0.0d0
            do i = 1, nvar
               gnorm = gnorm + g_lat(i)**2
            end do
            gnorm = sqrt(gnorm)
            grms = gnorm / sqrt(dble(nvar))
            if (grms .gt. grdmin) then
               done = .false.
               maxiter = 6
            end if
         end if
         if (.not. done) then
            call ocvm (nvar,x_lat,minimum,grdmin,xtallat1,writeout)
            xbox = x_lat(1)
            ybox = x_lat(2)
            zbox = x_lat(3)
            alpha = x_lat(4)
            beta = x_lat(5)
            gamma = x_lat(6)
         end if
      end do
c
c     write out the final potential energy value and gradients
c
      if (arms.gt.0.0001d0 .and. grms.gt.0.0001d0) then
         write (iout,50)  minimum,arms,anorm,grms,gnorm
   50    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,60)  minimum,arms,anorm,grms,gnorm
   60    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
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 xtalmol1  --  energy and gradient for atoms  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "xtalmol1" is a service routine that computes the energy and
c     gradient with respect to the atomic Cartesian coordinates for
c     a crystal energy minimization
c
c
      function xtalmol1 (xx,g)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'usage.i'
      integer i,nvar
      real*8 xtalmol1,e
      real*8 xx(maxvar)
      real*8 g(maxvar)
      real*8 derivs(3,maxatm)
c
c
c     translate optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            x(i) = xx(nvar)
            nvar = nvar + 1
            y(i) = xx(nvar)
            nvar = nvar + 1
            z(i) = xx(nvar)
         end if
      end do
c
c     compute and store the energy and gradient
c
      call gradient (e,derivs)
      xtalmol1 = e
c
c     store atom gradients as optimization gradient, also
c     translate the coordinates of each active atom; the
c     latter may be needed when using periodic boundaries
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            xx(nvar) = x(i)
            g(nvar) = derivs(1,i)
            nvar = nvar + 1
            xx(nvar) = y(i)
            g(nvar) = derivs(2,i)
            nvar = nvar + 1
            xx(nvar) = z(i)
            g(nvar) = derivs(3,i)
         end if
      end do
      return
      end
c
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine xtalmol2  --  Hessian values for the atoms  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "xtalmol2" is a service routine that computes the sparse
c     matrix Hessian elements with respect to the atomic Cartesian
c     coordinates for a crystal energy minimization
c
c
      subroutine xtalmol2 (mode,xx,h,hinit,hstop,hindex,hdiag)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'usage.i'
      integer i,j,k,nvar
      integer hinit(maxvar)
      integer hstop(maxvar)
      integer hindex(maxhess)
      integer hvar(maxvar)
      integer huse(maxvar)
      real*8 xx(maxvar)
      real*8 hdiag(maxvar)
      real*8 h(maxhess)
      character*4 mode
c
c
c     translate optimization parameters to atomic coordinates
c
      if (mode .eq. 'none')  return
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            x(i) = xx(nvar)
            nvar = nvar + 1
            y(i) = xx(nvar)
            nvar = nvar + 1
            z(i) = xx(nvar)
         end if
      end do
c
c     compute and store the Hessian elements
c
      call hessian (h,hinit,hstop,hindex,hdiag)
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     translate the coordinates of each active atom;
c     this may be needed when using periodic boundaries
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            xx(nvar) = x(i)
            nvar = nvar + 1
            xx(nvar) = y(i)
            nvar = nvar + 1
            xx(nvar) = z(i)
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function xtallat1  --  energy and gradient for lattice  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "xtalmol1" is a service routine that computes the energy and
c     numerical gradient with respect to the six lattice lengths
c     and angles for a crystal energy minimization
c
c
      function xtallat1 (xx,g)
      implicit none
      include 'boxes.i'
      real*8 xtallat1,energy
      real*8 e,e0,old,eps
      real*8 xx(6),g(6)
c
c
c     translate optimization variables to lattice parameters
c
      xbox = xx(1)
      ybox = xx(2)
      zbox = xx(3)
      alpha = xx(4)
      beta = xx(5)
      gamma = xx(6)
c
c     compute and store the base potential energy value
c
      call lattice
      e0 = energy ()
      xtallat1 = e0
c
c     find derivatives with respect to lattice dimensions
c
      eps = 0.00001d0
      old = xbox
      xbox = xbox - 0.5d0*eps
      call lattice
      e0 = energy ()
      xbox = xbox + eps
      call lattice
      e = energy ()
      g(1) = (e - e0) / eps
      xbox = old
      old = ybox
      ybox = ybox - 0.5d0*eps
      call lattice
      e0 = energy ()
      ybox = ybox + eps
      call lattice
      e = energy ()
      g(2) = (e - e0) / eps
      ybox = old
      old = zbox
      zbox = zbox - 0.5d0*eps
      call lattice
      e0 = energy ()
      zbox = zbox + eps
      call lattice
      e = energy ()
      g(3) = (e - e0) / eps
      zbox = old
c
c     find derivatives with respect to lattice angles
c
      eps = 0.0001d0
      old = alpha
      alpha = alpha - 0.5d0*eps
      call lattice
      e0 = energy ()
      alpha = alpha + eps
      call lattice
      e = energy ()
      g(4) = (e - e0) / eps
      alpha = old
      old = beta
      beta = beta - 0.5d0*eps
      call lattice
      e0 = energy ()
      beta = beta + eps
      call lattice
      e = energy ()
      g(5) = (e - e0) / eps
      beta = old
      old = gamma
      gamma = gamma - 0.5d0*eps
      call lattice
      e0 = energy ()
      gamma = gamma + eps
      call lattice
      e = energy ()
      g(6) = (e - e0) / eps
      gamma = old
      return
      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)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'math.i'
      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))
         if (abs(cosine) .ge. 1.0d0) then
            write (iout,10)  i
   10       format (/,' XYZATM  --  Undefined Dihedral',
     &                 ' Angle at Atom',i6)
         end if
         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)
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  --  Defining Atoms Colinear',
     &                 ' 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  --  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 a Cartesian coordinates file
c
c
      program xyzedit
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'couple.i'
      include 'cutoff.i'
      include 'files.i'
      include 'iounit.i'
      include 'math.i'
      include 'refer.i'
      include 'titles.i'
      include 'units.i'
      include 'usage.i'
      integer i,j,k,natom
      integer it,jt,ixyz
      integer nmode,mode
      integer offset,origin
      integer oldtype,newtype
      integer nlist,nmolecule
      integer freeunit
      integer list(maxatm)
      integer keep(maxatm)
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 xran,yran,zran
      real*8 xbox,ybox,zbox
      real*8 xorig,yorig,zorig
      real*8 xcm,ycm,zcm
      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 a(3,3)
      logical write
      character*60 coordfile
      character*80 record
      external merge
c
c
c     initialize various constants and the write flag
c
      call initial
      offset = 0
      write = .false.
c
c     read in the coordinates and force field definition
c
      call getxyz
      call field
      call katom
c
c     get the desired type of coordinate file modification
c
      write (iout,10)
   10 format (/,' The TINKER XYZedit Facility can Provide :',
     &        //,4x,'(1) Offset the Numbers of the Current Atoms',
     &        /,4x,'(2) Deletion of Individual Specified Atoms',
     &        /,4x,'(3) Deletion of Specified Types of Atoms',
     &        /,4x,'(4) Deletion of Atoms outside Cutoff Range',
     &        /,4x,'(5) Insertion of Individual Specified Atoms',
     &        /,4x,'(6) Replace Old Atom Type with a New Type',
     &        /,4x,'(7) Assign Connectivities based on Distance',
     &        /,4x,'(8) Convert Units from Bohrs to Angstroms',
     &        /,4x,'(9) Invert thru Origin to give Mirror Image',
     &        /,3x,'(10) Translate Center of Mass to the Origin',
     &        /,3x,'(11) Translate a Specified Atom to the Origin',
     &        /,3x,'(12) Translate and Rotate to Inertial Frame',
     &        /,3x,'(13) Move to Specified Rigid Body Coordinates',
     &        /,3x,'(14) Create and Fill a Periodic Boundary Box',
     &        /,3x,'(15) Soak Current Molecule in Box of Solvent',
     &        /,3x,'(16) Append another XYZ file to Current One')
   20 continue
      nmode = 16
      mode = 0
      write (iout,30)
   30 format (/,' Enter the Number of the Desired Choice :  ',$)
      read (input,40,err=20)  mode
   40 format (i10)
      if (mode.lt.0 .or. mode.gt.nmode)  goto 20
c
c     get the offset value to be used in atom renumbering
c
      if (mode .eq. 1) then
   50    continue
         write (iout,60)
   60    format (/,' Offset used to Renumber the Current Atoms :  ',$)
         read (input,70,err=50)  offset
   70    format (i10)
         write = .true.
      end if
c
c     remove a specified list of individual atoms
c
      if (mode .eq. 2) then
         nlist = 0
         do i = 1, maxatm
            list(i) = 0
         end do
         write (iout,80)
   80    format (/,' Numbers of the Atoms to be Removed :  ',$)
         read (input,90)  record
   90    format (a80)
         read (record,*,err=100,end=100)  (list(i),i=1,maxatm)
  100    continue
         dowhile (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 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
         write = .true.
         goto 20
      end if
c
c     remove all atoms with any of a specified list of atom types
c
      if (mode .eq. 3) then
         nlist = 0
         do i = 1, maxatm
            list(i) = 0
         end do
         write (iout,110)
  110    format (/,' Atom Types to be Removed :  ',$)
         read (input,120)  record
  120    format (a80)
         read (record,*,err=130,end=130)  (list(i),i=1,maxatm)
  130    continue
         dowhile (list(nlist+1) .ne. 0)
            nlist = nlist + 1
         end do
         natom = n
         do i = natom, 1, -1
            it = type(i)
            do j = 1, nlist
               if (list(j) .eq. it) then
                  call delete (i)
                  goto 140
               end if
            end do
  140       continue
         end do
         write = .true.
         goto 20
      end if
c
c     remove all atoms that are inactive and lie outside all cutoffs
c
      if (mode .eq. 4) then
         call active
         call cutoffs
         nlist = 0
         do i = 1, n
            keep(i) = 0
         end do
         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
         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 150
                     dist2 = (x(j)-xi)**2 +(y(j)-yi)**2 +(z(j)-zi)**2
                     if (dist2 .le. cut2)  goto 150
                  end if
               end do
               nlist = nlist + 1
               list(nlist) = i
  150          continue
            end if
         end do
         do i = nlist, 1, -1
            call delete (list(i))
         end do
         write = .true.
         goto 20
      end if
c
c     insert a specified list of individual atoms
c
      if (mode .eq. 5) then
         nlist = 0
         do i = 1, maxatm
            list(i) = 0
         end do
         write (iout,160)
  160    format (/,' Numbers of the Atoms to be Inserted :  ',$)
         read (input,170)  record
  170    format (a80)
         read (record,*,err=180,end=180)  (list(i),i=1,maxatm)
  180    continue
         dowhile (list(nlist+1) .ne. 0)
            nlist = nlist + 1
         end do
         call sort4 (nlist,list)
         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
         write = .true.
         goto 20
      end if
c
c     get an old atom type and new atom type for replacement
c
      if (mode .eq. 6) then
  190    continue
         oldtype = 0
         newtype = 0
         write (iout,200)
  200    format (/,' Numbers of the Old and New Atom Types :  ',$)
         read (input,210)  record
  210    format (a80)
         read (record,*,err=190)  oldtype,newtype
         do i = 1, n
            if (type(i) .eq. oldtype)  type(i) = newtype
         end do
         call katom
         write = .true.
         goto 20
      end if
c
c     assign atom connectivities based on interatomic distances
c
      if (mode .eq. 7) then
         call unitcell
         call lattice
         do i = 1, n
            n12(i) = 0
         end do
         do i = 1, n-1
            xi = x(i)
            yi = y(i)
            zi = z(i)
            it = atomic(i)
            do j = i+1, n
               jt = atomic(j)
               xr = x(j) - xi
               yr = y(j) - yi
               zr = z(j) - zi
               if (use_image)  call image (xr,yr,zr,0)
               dist2 = xr*xr + yr*yr + zr*zr
               if (it.ne.1 .and. jt.ne.1) then
                  if (dist2 .lt. 4.0d0) then
                     n12(i) = n12(i) + 1
                     i12(n12(i),i) = j
                     n12(j) = n12(j) + 1
                     i12(n12(j),j) = i
                  end if
               else if (it.ne.1 .or. jt.ne.1) then
                  if (dist2 .lt. 2.25d0) then
                     n12(i) = n12(i) + 1
                     i12(n12(i),i) = j
                     n12(j) = n12(j) + 1
                     i12(n12(j),j) = i
                  end if
               end if
            end do
         end do
         do i = 1, n
            call sort (n12(i),i12(1,i))
         end do
         write = .true.
         goto 20
      end if
c
c     convert the coordinate units from Bohrs to Angstroms
c
      if (mode .eq. 8) then
         do i = 1, n
            x(i) = x(i) * bohr
            y(i) = y(i) * bohr
            z(i) = z(i) * bohr
         end do
         write = .true.
         goto 20
      end if
c
c     get mirror image by inverting coordinates through origin
c
      if (mode .eq. 9) then
         do i = 1, n
            x(i) = -x(i)
            y(i) = -y(i)
            z(i) = -z(i)
         end do
         write = .true.
         goto 20
      end if
c
c     translate the center of mass to the coordinate origin
c
      if (mode .eq. 10) then
         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
         do i = 1, n
            x(i) = x(i) - xcm
            y(i) = y(i) - ycm
            z(i) = z(i) - zcm
         end do
         write = .true.
         goto 20
      end if
c
c     translate to place a specified atom at the origin
c
      if (mode .eq. 11) then
         write (iout,220)
  220    format (/,' Number of the Atom to Move to the Origin :  ',$)
         read (input,230)  origin
  230    format (i10)
         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
         write = .true.
         goto 20
      end if
c
c     translate and rotate into standard orientation
c
      if (mode .eq. 12) then
         call inertia (2)
         write = .true.
         goto 20
      end if
c
c     translate and rotate to specified rigid body coordinates
c
      if (mode .eq. 13) then
         xcm = 0.0d0
         ycm = 0.0d0
         zcm = 0.0d0
         phi = 0.0d0
         theta = 0.0d0
         psi = 0.0d0
         write (iout,240)
  240    format (/,' Enter Rigid Body Coordinates :  ',$)
         read (input,250)  record
  250    format (a80)
         read (record,*,err=260,end=260)  xcm,ycm,zcm,phi,theta,psi
  260    continue
         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 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
         write = .true.
         goto 20
      end if
c
c     create a random box full of the current coordinates file
c
      if (mode .eq. 14) then
         write (iout,270)
  270    format (/,' Enter Number of Molecules in Box :  ',$)
         read (input,280)  nmolecule
  280    format (i10)
         xbox = 0.0d0
         ybox = 0.0d0
         zbox = 0.0d0
         dowhile (xbox .eq. 0.0d0)
            write (iout,290)
  290       format (/,' Enter Periodic Box Dimensions (X,Y,Z) :  ',$)
            read (input,300)  record
  300       format (a80)
            read (record,*,err=310,end=310)  xbox,ybox,zbox
  310       continue
            if (ybox .eq. 0.0d0)  ybox = xbox
            if (zbox .eq. 0.0d0)  zbox = xbox
         end do
         ixyz = freeunit ()
         coordfile = filename(1:leng)//'.xyz'
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,status='new')
         if (ltitle .eq. 0) then
            write (ixyz,320)  n*nmolecule
  320       format (i6)
         else
            write (ixyz,330)  n*nmolecule,title(1:ltitle)
  330       format (i6,2x,a)
         end if
         do k = 1, nmolecule
            offset = (k-1) * n
            xran = xbox * random ()
            yran = ybox * random ()
            zran = zbox * random ()
            do i = 1, n
               write (ixyz,340)  i+offset,name(i),x(i)+xran,
     &                           y(i)+yran,z(i)+zran,type(i),
     &                           (i12(j,i)+offset,j=1,n12(i))
  340          format (i6,2x,a3,3f12.6,5i6)
            end do
         end do
         close (unit=ixyz)
         write (iout,350)  coordfile
  350    format (/,' New Coordinates written to :  ',a)
         write = .false.
      end if
c
c     solvate the current system by insertion into a solvent box
c
      if (mode .eq. 15) then
         call soak
         write = .true.
      end if
c
c     append a second file to the current coordinates file
c
      if (mode .eq. 16) then
         call makeref
         call getxyz
         call merge
         write = .true.
         goto 20
      end if
c
c     write out the new coordinates file in its new format
c
      if (write) then
         ixyz = freeunit ()
         coordfile = filename(1:leng)//'.xyz'
         call version (coordfile,'new')
         open (unit=ixyz,file=coordfile,status='new')
         if (offset .eq. 0) then
            call prtxyz (ixyz)
         else
            if (ltitle .eq. 0) then
               write (ixyz,360)  n
  360          format (i6)
            else
               write (ixyz,370)  n,title(1:ltitle)
  370          format (i6,2x,a)
            end if
            do i = 1, n
               write (ixyz,380)  i+offset,name(i),x(i),y(i),z(i),
     &                           type(i),(i12(j,i)+offset,j=1,n12(i))
  380          format (i6,2x,a3,3f12.6,5i6)
            end do
         end if
         close (unit=ixyz)
         write (iout,390)  coordfile
  390    format (/,' New Coordinates written to File :  ',a)
      end if
c
c     perform any final tasks before program exit
c
      call final
      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
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'iounit.i'
      include 'molcul.i'
      include 'refer.i'
      integer i,k,isolv
      integer ntot,freeunit
      real*8 xi,yi,zi
      real*8 xr,yr,zr,rik2
      real*8 close,close2
      logical remove(maxatm)
      character*60 solvfile
      external merge
c
c
c     make a copy of the solute coordinates and connectivities
c
      call makeref
c
c     read the coordinates for the solvent box
c
   10 continue
      write (iout,20)
   20 format (/,' Enter Name of Solvent Box Coordinates :  ',$)
      read (input,30)  solvfile
   30 format (a60)
      call suffix (solvfile,'xyz')
      call version (solvfile,'old')
      isolv = freeunit ()
      open (unit=isolv,file=solvfile,status='old',err=10)
      rewind (unit=isolv)
      call readxyz (isolv)
      close (unit=isolv)
c
c     combine solute and solvent into a single coordinate set
c
      call merge
c
c     count number of molecules and set lattice parameters
c
      call molecule
      call unitcell
      call lattice
c
c     initialize the list of solvent molecules to be deleted
c
      do i = 1, nmol
         remove(i) = .false.
      end do
c
c     search for close contacts between solute and solvent
c
      close = 1.5d0
      close2 = close * close
      do i = 1, nref
         xi = x(i)
         yi = y(i)
         zi = z(i)
         do k = nref+1, n
            xr = x(k) - xi
            yr = y(k) - yi
            zr = z(k) - zi
            if (use_image)  call image (xr,yr,zr,0)
            rik2 = xr*xr + yr*yr + zr*zr
            if (rik2 .lt. close2)  remove(molcule(k)) = .true.
         end do
      end do
c
c     remove solvent molecules that are too close to the solute
c
      ntot = n
      do i = ntot, nref+1, -1
         if (remove(molcule(i)))  call delete (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     ##  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
      implicit none
      include 'files.i'
      include 'iounit.i'
      include 'titles.i'
      integer izmt,mode
      integer next,freeunit
      logical exist
      character*1 answer
      character*60 intfile
      character*80 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 (a80)
         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)  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 Cartesian coordinates file,
c     then converts to and writes out a Protein Data Bank file
c
c
      program xyzpdb
      implicit none
      include 'files.i'
      integer ipdb,freeunit
      character*60 pdbfile
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 field
      call katom
      call molecule
c
c     convert from Cartesian coordinates to PDB format
c
      call makepdb
c
c     write out the Protein Data Bank file
c
      pdbfile = filename(1:leng)//'.pdb'
      call version (pdbfile,'new')
      ipdb = freeunit ()
      open (unit=ipdb,file=pdbfile,status='new')
      call prtpdb (ipdb)
      close (unit=ipdb)
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 xyzsybyl  --  convert Cartesian to Sybyl MOL2 file  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "xyzsybyl" takes as input a Cartesian coordinates file,
c     converts to and then writes out a Sybyl MOL2 file
c
c
      program xyzsybyl
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'iounit.i'
      include 'titles.i'
      integer isyb,freeunit
      character*60 sybylfile
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     get a list of the bonds in the structure
c
      call bonds
c
c     open a new version of the Sybyl MOL2 file
c
      isyb = freeunit ()
      sybylfile = filename(1:leng)//'.mol2'
      call version (sybylfile,'new')
      open (unit=isyb,file=sybylfile,status='new')
c
c     output the coordinates into Sybyl MOL2 format
c
      call prtmol2 (isyb)
      close (unit=isyb)
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 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)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'fields.i'
      include 'iounit.i'
      include 'katoms.i'
      include 'zclose.i'
      include 'zcoord.i'
      integer bionum
      integer iz1,iz2
      integer iz3,iz4
      real*8 bond,angle
      real*8 dihed
c
c
c     fill various arrays with information for this atom
c
      if (bionum .gt. 0) then
         type(n) = biotyp(bionum)
         if (type(n) .ne. 0) then
            name(n) = symbol(type(n))
         else
            name(n) = '   '
         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     increment atom counter and check for too many atoms
c
         n = n + 1
         if (n .gt. maxatm) then
            write (iout,10)  maxatm
   10       format (/,' ZATOM  --  The Maximum of',i6,' 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
