c
c******************************************************************************
c  MLGHOOK
c******************************************************************************
c
      subroutine mlghook(progrms, geom, mcinp, mgswit, hfmoinp, mcoptl,
     *   sacinp, mcsinp, ibinp, mcoinp, mnminp, mutinp, g2inp, mg2inp,
     *  g3inp, mg3inp, mqcinp, mcomp2inp, mccoinp,g3sxmp3inp,mc3bbinp,  0710PJ00
     *  mc3mpwinp,limohc, imohcinp, ltest, tmeth, tbas, toptl, ierr)
c  
c     Subroutine mlghook
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:  Feb 24, 2002 by B. J. Lynch
c     Purpose:  To call the appropriate gradient subhook
c
c     Called by:  main
c     Calls:  hfmoghk, mcghk, imohcghk, g2ghk, g3ghk, mg2ghk, mg3ghk, mqcghk, mcomp2ghk,
c             mccoghk, mc3bbghk, g3sxmp3ghk   
c          
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mctype, mgtype, hfmoinf, mcinf,
     *                   ginf, mginf, imoinf, proglist
      use files, only : outfile
      use optimize, only : ener, grad
      use caltyp, only : tgrad
      use energy, only : eso, ecc, erel

      implicit none

c
      type (proglist) :: progrms
      integer ierr, lmg2, lmg3, limohc, ltest, n3tm
      type (cartgeom) :: geom
      type (mctype)   :: mcinp
      type (mgtype)   :: mgswit
      type (hfmoinf)  :: hfmoinp
      character*20    :: tmeth, tbas
      character*80    :: mcoptl(5), toptl(5)
      type (mcinf)    :: sacinp, mcsinp, ibinp, mcoinp, mnminp, mutinp   
      type (ginf)     :: g2inp, g3inp
      type (mginf)    :: mg2inp, mg3inp, mqcinp,                        0110PF00
     *                   mcomp2inp, mccoinp, mc3bbinp, g3sxmp3inp,      0712BL02
     *                   mc3mpwinp 
      type (imoinf)   :: imohcinp

      n3tm = 3*geom%natoms

      lmg2 = 0
      lmg3 = 0
c
c  Make calls to subhooks depending on activated switches
c
c  TEST
c
      if (ltest.eq.1)  then
         call progghk(1, progrms%testprog,tmeth,tbas, geom , toptl, 
     *                ener, grad(:n3tm), ierr, 'null')
         ener = ener + eso + ecc + erel

c
         call testdisp( geom%natoms, tgrad )
      endif
c
c  IMOHC
c
      if (limohc .eq. 1) then
         call imohcghk(progrms%imohlprog, progrms%imollprog, geom, 
     *          imohcinp, ierr)
      endif
c     
c  HFMO
c
      if (hfmoinp%lhfmo .eq. 1) then
         call hfmoghk(progrms%hfprog, progrms%moprog, geom, 
     *          hfmoinp, ierr)
      endif
c
c  SAC, MCSAC, IB, or MCCM
c     
       if (mcinp%lcoop.eq.1)  then
         if (mcinp%lib.eq.1 .or. mcinp%lsac.eq.1
     *          .or. mcinp%lmcsac.eq.1 .or. mcinp%lmccmco.eq.1
     *          .or. mcinp%lmccmnm.eq.1 .or. mcinp%lmccmut.eq.1) then
            call mcghk(progrms%mcprog, geom, mcinp, mcoptl, sacinp,
     *                mcsinp, ibinp, mcoinp, mnminp, mutinp, ierr)
         endif
      else
         if (mcinp%lmccmco.eq.1) then
            call mcoghk(progrms%mcprog,geom,mcoinp,mcoptl)
         endif
         if (mcinp%lmccmnm.eq.1) then
            call mnmghk(progrms%mcprog,geom,mnminp,mcoptl)
         endif
         if (mcinp%lmccmut.eq.1) then
            call mutghk(progrms%mcprog,geom,mutinp,mcoptl)
         endif
         if (mcinp%lib.eq.1) then
            call ibghk(progrms%mcprog,geom,ibinp,mcoptl)
         endif
         if (mcinp%lmcsac.eq.1) then
            call mcsghk(progrms%mcprog,geom,mcsinp,mcoptl)
         endif
         if (mcinp%lsac.eq.1) then
            call sacghk(progrms%mcprog,geom,sacinp,mcoptl)
         endif
      endif   
c
c  MCG2
c
      if (mgswit%lmcg2.eq.1) then
         call mg2ghk(progrms%g2prog,geom,mg2inp,ierr)
         lmg2 = 1
      endif
c
c  G2
c
      if (mgswit%lg2.eq.1) then
         call g2ghk(progrms%g2prog,geom,lmg2,g2inp,ierr)
      endif
c
c  MCG3
c
      if (mgswit%lmcg3.eq.1) then
         call mg3ghk(progrms%g3prog,geom,mg3inp,ierr)
         lmg3 = 1
      endif
c
c  MC-QCISD
c
      if (mgswit%lmqcisd.eq.1) then                                     0110PF00
         call mqcghk(progrms%g3prog,geom,lmg3,mqcinp,ierr)              0110PF00
      endif                                                             0110PF00
c
c  MCOMP2
c
      if (mgswit%lmcomp2.eq.1) then                                     0710PJ00
         call mcomp2ghk(progrms%g3prog,geom,lmg3,mcomp2inp,ierr)        0710PJ00
      endif                                                             0710PJ00

c
c  MCCO
c
      if (mgswit%lmcco.eq.1) then                                       0712BL02
         call mccoghk(progrms%g3prog,geom,lmg3,mccoinp,ierr)            0712BL02
      endif                                                             0712BL02

c
c  MC3BB
c
      if (mgswit%lmc3bb.eq.1) then                                      0712YZ03
        call mc3bbghk(progrms%g3prog,geom,lmg3,mc3bbinp,ierr)           0712YZ03
      endif                                                             0712YZ03

c
c  MC3BB
c
      if (mgswit%lmc3mpw.eq.1) then                                     0712YZ03
        call mc3mpwghk(progrms%g3prog,geom,lmg3,mc3mpwinp,ierr)         0712YZ03
      endif                                                             0712YZ03


c
c  G3SX(MP3) 
c
      if (mgswit%lg3sxmp3.eq.1) then                                    0712YZ03
        call g3sxmp3ghk(progrms%g3prog,geom,lmg3,g3sxmp3inp,ierr)       0712YZ03
      endif                                                             0712YZ03

c
c  G3
c
      if (mgswit%lg3.eq.1) then
         call g3ghk(progrms%g3prog,geom,lmg3,g3inp,ierr)
      endif
      
      return
      end
c
c     
c******************************************************************************
c MCGHK
c******************************************************************************
c
      subroutine mcghk(prognme, geom, mcinp, mcoptl, sacinp,
     *                   mcsinp, ibinp, mcoinp, mnminp, mutinp, ierr)
c
c     Subroutine mcghk
c
c     Created:  July 1, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure
c       calculations, make calls to the e.s. program, and then carry out
c       the SAC, MCSAC, IB, and MCCM gradient calculations
c
c     Called by:  mlghook  
c     Calls:  mcchk, mcochk, mnmchk, mutchk, ibchk, mcschk, sacchk,
c             getemco, getemnm, getemut, geteib, getemcs, getesac,
c             getgmco, getgmnm, getgmut, getgib, getgmcs, getgsac,
c             mcdisp, setmcsw, esgparse
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mctype, mcinf
      use param
      use files
      use energy
      use gradient
      implicit none

      type (cartgeom) :: geom
      type (mctype)   :: mcinp
      character*80    :: mcoptl(5)
      type (mcinf)    :: sacinp, mcsinp, ibinp, mcoinp, mnminp, mutinp
c
c  Note - esswit will indicate which electronic structure calls to make to
c    the exterior program, and mcswit will indicate which MC calculations
c    to do with the obtained information.  The integers used to indicate
c    this are all defined in the module param.
c
      integer esswit(numes,numbas), mcswit(5,numcalc)
      integer ierr, i, j, k, ctr, natoms, max
      integer mcmeth, coefsw, esmeth, basis, vers
      double precision coef(10)
      double precision blnkhess(3*geom%natoms)
      character*10  prognme
c
c  Initialize switches to 0 and energies and gradients to 0.0000d0
c
      do 20 i=1, numes
         do 40 j=1, numbas
            esswit(i,j) = 0
            esener(i,j) = 0.0000d0
            do 50 k=1, 3*geom%natoms
               esgrad(i,j,k) = 0.0000d0
  50        continue
  40     continue
  20  continue
c
      do 60 i=1, 5
         do 80 j=1,numcalc
            mcswit(i,j) = 0
  80     continue
  60  continue
      do 100 i=1, numcalc
         mcener(i) = 0.0000d0
         do 90 j=1, 3*geom%natoms
            mcgrad(i,j) = 0.0000d0
  90     continue
 100  continue
c
c  Initialize counter of mc calcs (ctr) to 0.
c
      ctr = 0
c
c  Pass esswit and mcswit to checking subroutines to determine which
c    es and mc calculations are necessary if standard methods and bases
c    have been specified.  If non-standard choices are selected, another
c    hook is called which does not attempt to make all possible mc
c    calculations.
c  Currently non-standard bases are supported for MCCM, IB, MCSAC, and SAC.
c  Non-standard methods are supported for IB and SAC.
c     
      if (mcinp%lmccmco .eq. 1) then
         if (mcoinp%stdm.eq.1 .and. mcoinp%stdb1.eq.1 
     *        .and. mcoinp%stdb2.eq.1) then        
            call mcochk( mcoinp%meth, esswit, mcswit, ctr, ierr )
         else
            call setmcsw( mcswit, ctr, pmco, nodef, nstd, nstd )
            call mcoghk(prognme,geom,mcoinp,mcoptl)
         endif
      endif
      if (mcinp%lmccmnm .eq. 1) then
         if (mnminp%stdm.eq.1 .and. mnminp%stdb1.eq.1 
     *        .and. mnminp%stdb2.eq.1 .and. mnminp%stdb3.eq.1) then
            call mnmchk( mnminp%meth, esswit, mcswit, ctr, ierr )
         else
            call setmcsw( mcswit, ctr, pmnm, nodef, nstd, nstd )
            call mnmghk(prognme,geom,mnminp,mcoptl)
         endif
      endif
      if (mcinp%lmccmut .eq. 1) then
         if (mutinp%stdm.eq.1 .and. mutinp%stdb1.eq.1 
     *        .and. mutinp%stdb2.eq.1) then
            call mutchk( mutinp%meth, esswit, mcswit, ctr, ierr )
         else
            call setmcsw( mcswit, ctr, pmut, nodef, nstd, nstd )
            call mutghk(prognme,geom,mutinp,mcoptl)
         endif
      endif
      if (mcinp%lib .eq. 1) then
         if (ibinp%stdm.eq.1 .and. ibinp%stdb1.eq.1 
     *        .and. ibinp%stdb2.eq.1) then
            call ibchk(ibinp%meth,esswit,mcswit,ctr,ierr)
         else
            call setmcsw( mcswit, ctr, pib, nodef, nstd, nstd )
            call ibghk(prognme, geom, ibinp, mcoptl)
         endif
      endif
      if (mcinp%lmcsac .eq. 1) then
         if (mcsinp%stdm.eq.1 .and. mcsinp%stdb1.eq.1) then
            call mcschk(mcsinp%meth,mcsinp%bas1,esswit,mcswit,ctr,ierr)        
         else
            call setmcsw( mcswit, ctr, pmcs, nodef, nstd, nstd )
            call mcsghk(prognme,geom,mcsinp,mcoptl)
         endif
      endif
      if (mcinp%lsac .eq. 1) then
         if (sacinp%stdm.eq.1 .and. sacinp%stdb1.eq.1) then
            call sacchk(sacinp%meth,sacinp%bas1,esswit,mcswit,ctr,ierr)
         else
            call setmcsw( mcswit, ctr, psac, nodef, nstd, nstd )
            call sacghk(prognme, geom, sacinp, mcoptl)
         endif
      endif
c
c  From esswit, set all default MC calculation in mcswit.
c
      call mcchk( esswit, mcswit, ctr )
c
c  Make all electronic structure calls recorded in esswit with esgparse.
c  Then parse out mcswit and for all standard mc calculations pass info on
c    to a function that will gather the necessary electronic structure
c    information and pass these off to appropriate calculation functions 
c  All nonstandard calculations will already have been carried out
c    by the individual hooks.
c
      if (ctr .gt. 0) then
         call esgparse( prognme, geom, mcoptl, esswit, ierr )
         i = 1
         do while (i.le.(ctr+nummc))
            if (mcswit(3,i).eq.nstd .or. mcswit(4,i).eq.nstd .or.
     *             mcswit(1,i).eq.0) then
               i = i+1
               mcswit(5,i) = 0
            else
               mcmeth = mcswit(1,i)
               coefsw = mcswit(2,i)
               esmeth = mcswit(3,i)  
               basis = mcswit(4,i)
               natoms = geom%natoms
               if (mcmeth .eq. pmco) then
                  if (mcoinp%version(:4) .eq. 'v1sc') then
                     vers = v1sc
                     mcswit(5,i) = v1sc
                  elseif (mcoinp%version(:4) .eq. 'v2sc') then
                     vers = v2sc
                     mcswit(5,i) = v2sc
                  elseif (mcoinp%version(:3) .eq. 'v2s') then
                     vers = v2s
                     mcswit(5,i) = v2s
                  elseif (mcoinp%version(:3) .eq. 'v2m') then
                     vers = v2m
                     mcswit(5,i) = v2m
                  end if
                  coef = mcoinp%coef
                  call getemco(i, coefsw, coef, esmeth, vers)
                  call getgmco(i, coefsw, coef, esmeth, vers, natoms)
               elseif (mcmeth .eq. pmnm) then
                  if (mnminp%version(:4) .eq. 'v1sc') then
                     vers = v1sc
                     mcswit(5,i) = v1sc
                  elseif (mnminp%version(:4) .eq. 'v2sc') then
                     vers = v2sc
                     mcswit(5,i) = v2sc
                  elseif (mnminp%version(:3) .eq. 'v2s') then
                     vers = v2s
                     mcswit(5,i) = v2s
                  elseif (mnminp%version(:3) .eq. 'v2m') then
                     vers = v2m
                     mcswit(5,i) = v2m
                  end if
                  coef = mnminp%coef
                  call getemnm(i, coefsw, coef, esmeth, vers)
                  call getgmnm(i, coefsw, coef, esmeth, vers, natoms)
               elseif (mcmeth .eq. pmut) then
                  if (mutinp%version(:4) .eq. 'v1sc') then
                     vers = v1sc
                     mcswit(5,i) = v1sc
                  elseif (mutinp%version(:4) .eq. 'v2sc') then
                     vers = v2sc
                     mcswit(5,i) = v2sc
                  elseif (mutinp%version(:3) .eq. 'v2s') then
                     vers = v2s
                     mcswit(5,i) = v2s
                  elseif (mutinp%version(:3) .eq. 'v2m') then
                     vers = v2m
                     mcswit(5,i) = v2m
                  end if
                  coef = mutinp%coef
                  call getemut(i, coefsw, coef, esmeth, vers)
                  call getgmut(i, coefsw, coef, esmeth, vers, natoms)
               elseif (mcmeth .eq. pmcs) then
                  if (mcsinp%version(:4) .eq. 'v1sc') then
                     vers = v1sc
                     mcswit(5,i) = v1sc
                  elseif (mcsinp%version(:4) .eq. 'v2sc') then
                     vers = v2sc
                     mcswit(5,i) = v2sc
                  elseif (mcsinp%version(:3) .eq. 'v2s') then
                     vers = v2s
                     mcswit(5,i) = v2s
                  elseif (mcsinp%version(:3) .eq. 'v2m') then
                     vers = v2m
                     mcswit(5,i) = v2m
                  end if
                  coef = mcsinp%coef
                  call getemcs(i, coefsw, coef, esmeth, vers, basis)
                  call getgmcs(i, coefsw, coef, esmeth, vers, basis, 
     *                         natoms)
               elseif (mcmeth .eq. pib) then
                  coef = ibinp%coef
                  mcswit(5,i) = 0
                  call geteib(i, coefsw, coef, esmeth)
                  call getgib(i, coefsw, coef, esmeth,natoms)
               elseif (mcmeth .eq. psac) then
                  if (sacinp%version(:4) .eq. 'v1sc') then
                     vers = v1sc
                     mcswit(5,i) = v1sc
                  elseif (sacinp%version(:3) .eq. 'v1s') then
                     vers = v1s
                     mcswit(5,i) = v1s
                  elseif (sacinp%version(:4) .eq. 'v2sc') then
                     vers = v2sc
                     mcswit(5,i) = v2sc
                  elseif (sacinp%version(:3) .eq. 'v2s') then
                     vers = v2s
                     mcswit(5,i) = v2s
                  elseif (sacinp%version(:3) .eq. 'v2m') then
                     vers = v2m
                     mcswit(5,i) = v2m
                  elseif (sacinp%version(:3) .eq. 'v3m') then
                     vers = v3m
                     mcswit(5,i) = v3m
                  elseif (sacinp%version(:3) .eq. 'v3s') then
                     vers = v3s
                     mcswit(5,i) = v3s
                  end if
                  coef = sacinp%coef
                  call getesac(i, coefsw, coef, esmeth, vers, basis)
                  call getgsac(i, coefsw, coef, esmeth, vers, basis, 
     *                         natoms)
               endif
c
c  Add on ESO and ECC and EREL
c
               mcener(i) = mcener(i) + eso + ecc + erel
               i = i+1
            endif
         enddo
      endif

      call mcdisp( prognme, esswit, mcswit, ctr, natoms, tgrad )

      return 
      end
c
c
c******************************************************************************
c  ESGPARSE
c******************************************************************************
c     
      subroutine esgparse( prognme, geom, optl, esswit, ierr )
c
c     Subroutine esgparse
c
c     Created:  June 24, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Parse esswit and make necessary calls to the electronics
c        structure program using progghk.  Requests one calculation at a
c        time from progghk.
c
c     Called by:  mcghk
c     Calls:  progghk
c
c     Variables defined here:
c
      use input, only : cartgeom
      use param, only : esmlist, baslist, numes, numbas
      use files, only : outfile
      use energy, only : esener
      use gradient, only : esgrad
      implicit none
      
      type (cartgeom) :: geom
      character*10 prognme
      character*20 esmeth
      character*20 esbas
      character*80 optl(5)

      double precision ener, grad(3*geom%natoms)
      integer esswit(numes,numbas), ierr

      integer i, j, k

      ierr = 0
      i = 1

      do while (i.le.numes .and. ierr.eq.0)
         j = 1
         do while (j.le.numbas .and. ierr.eq.0)
            if (esswit(i,j).eq.1 .and. ierr.eq.0) then
               esmeth = '                    '
               esbas =  '                    '
               esmeth = esmlist(i)
               esbas = baslist(j)
               call progghk(1,prognme, esmeth, esbas, geom, optl,
     *                         ener, grad, ierr, 'null')
               if (ierr .ne. 1) then
                  esener(i,j) = ener
                  esgrad(i,j,:3*geom%natoms) = grad
               endif
            endif
            j = j+1
         end do
         i = i+1
      end do

      if (ierr.eq.1) then
         write (outfile,*) 'ERROR calling electronic structure program'        
         stop 'esgparse 1'
      endif

      return
      end
c
c
c******************************************************************************
c  GETGMCO
c******************************************************************************
c
      subroutine getgmco(index, coefsw, inpcoef, esmeth, vers, natoms)
c
c     Subroutine getgmco
c
c     Created:  July 7, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Looks at MCCM-CO calculation requested, gets the
c        necessary electronic structure information from esgrad 
c        and passes it off to calmco to calculate the gradient.
c
c     Called by:  mcghk, mchhk
c     Calls:  calmco
c
c     Variables defined here:
c
      use param
      use gradient, only : esgrad, mcgrad
      implicit none

      integer i, j, index, coefsw, esmeth, basis, max, natoms, vers
      double precision inpcoef(10), coef(10)
      double precision mcoesgr(5,2,3*natoms)

c
c  Set electronic structure gradient arrays to 0.0000d0
c
      do 20 i=1, 5
         do 30 j=1, 3*natoms
            mcoesgr(i,1,j) = 0.0000d0
            mcoesgr(i,2,j) = 0.0000d0
  30     continue
  20  continue
c
c  Gather MCCM-CO electronic structure info in mcoesgr
c
      mcoesgr(1,1,:) = esgrad(phf,pdz,:3*natoms) 
      mcoesgr(1,2,:) = esgrad(phf,ptz,:3*natoms) 
      mcoesgr(2,1,:) = esgrad(pmp2,pdz,:3*natoms)
      mcoesgr(2,2,:) = esgrad(pmp2,ptz,:3*natoms)
      if (esmeth.eq.pccsd .or. esmeth.eq.pccsdt) then
         mcoesgr(3,1,:) = esgrad(pccsd,pdz,:3*natoms)
         mcoesgr(3,2,:) = esgrad(pccsd,ptz,:3*natoms)
      endif
      if (esmeth.eq.pccsdt) then
         mcoesgr(4,1,:) = esgrad(pccsdt,pdz,:3*natoms)
         mcoesgr(4,2,:) = esgrad(pccsdt,ptz,:3*natoms)
      endif
      if (esmeth.eq.pmp4sdq .or. esmeth.eq.pmp4) then
         mcoesgr(3,1,:) = esgrad(pmp4sdq,pdz,:3*natoms)
         mcoesgr(3,2,:) = esgrad(pmp4sdq,ptz,:3*natoms)
      endif
      if (esmeth.eq.pmp4) then
         mcoesgr(4,1,:) = esgrad(pmp4,pdz,:3*natoms)
         mcoesgr(4,2,:) = esgrad(pmp4,ptz,:3*natoms)
      endif
c
c  Based on the electronic structure series that the given calculation is
c    in, determine the number of differences to be taken.
c
      if (esmeth.eq.pmp2)     max=2
      if (esmeth.eq.pmp4sdq)  max=3
      if (esmeth.eq.pmp4)     max=4
      if (esmeth.eq.pccsd)    max=3
      if (esmeth.eq.pccsdt)   max=4
c
c  Look at coefsw and depending on whether default or non-default
c    coefficients have been requested, pass on to calgmco either the input
c    coefficients (inpcoef) or the default coefficients from module param 
c
      do 40 i=1, 10
         coef(i) = 0.0000d0
  40  continue
      
      if (coefsw.eq.def) then
         coef = mcodefc(vers, esmeth, :10)
      elseif (coefsw.eq.nodef) then
         coef = inpcoef(:10)
      endif
c
c  Call calgmco to calculate the MCCM-CO gradient based on the e.s.
c    information and the given coefficients.
c
      do 60 j=1, 3*natoms
         call calmco(mcgrad(index,j),coef,mcoesgr(:,:,j),max,natoms )
  60  continue

      return
      end
c
c******************************************************************************
c  GETGMNM
c******************************************************************************
c
      subroutine getgmnm(index, coefsw, inpcoef, esmeth, vers, natoms)
c
c     Subroutine getgmnm
c
c     Created:  July 7, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Look at MCCM-NM calculation requested, gather the
c        necessary electronic structure information from esgrad 
c        and pass it off to calmnm to calculate the gradient.
c
c     Called by:  mcghk, mchhk
c     Calls:  calmnm
c
c     Variables defined here:
c
      use param
      use gradient, only : esgrad, mcgrad
      implicit none

      integer i, j, index, coefsw, esmeth, basis, max, natoms, vers
      double precision inpcoef(10), coef(7)
      double precision mnmesgr(5,3,3*natoms)

c
c  Set electronic structure gradient arrays to 0.0000d0
c
      do 20 i=1, 5
         do 30 j=1, 3*natoms
            mnmesgr(i,1,j) = 0.0000d0
            mnmesgr(i,2,j) = 0.0000d0
            mnmesgr(i,3,j) = 0.0000d0
  30     continue
  20  continue
c
c  Gather MCCM-NM electronic structure info in mnmesgr
c
      mnmesgr(1,1,:) = esgrad(phf,pdz,:3*natoms)
      mnmesgr(1,2,:) = esgrad(phf,ptz,:3*natoms)
c      mnmesgr(1,3,:) = esgrad(phf,pdzs,:3*natoms)
      mnmesgr(1,3,:) = esgrad(phf,mpdz,:3*natoms)                       0808RMP12
      mnmesgr(2,1,:) = esgrad(pmp2,pdz,:3*natoms)
      mnmesgr(2,2,:) = esgrad(pmp2,ptz,:3*natoms)
      mnmesgr(3,1,:) = esgrad(pccsd,pdz,:3*natoms)
      mnmesgr(4,1,:) = esgrad(pccsdt,pdz,:3*natoms)
c
c  Based on the electronic structure series that the given calculation is
c    in, determine the number of differences to be taken.
c
      if (esmeth.eq.pccsdt)   max=4
c
c  Look at coefsw and depending on whether default or non-default
c    coefficients have been requested, pass on to calgmnm either the input
c    coefficients (inpcoef) or the default coefficients from param.inc 
c
      do 40 i=1, 7
         coef(i) = 0.0000d0
  40  continue
      
      if (coefsw.eq.def) then
         coef = mnmdefc(vers, :7)
      elseif (coefsw.eq.nodef) then
         coef = inpcoef(:7)
      endif
c
c  Call calgmnm to calculate the MCCM-NM gradient.
c
      do 60 j=1, 3*natoms
         call calmnm(mcgrad(index,j),coef,mnmesgr(:,:,j),max,natoms)
  60  continue

      return
      end
c
c******************************************************************************
c  GETGMUT
c******************************************************************************
c
      subroutine getgmut(index, coefsw, inpcoef, esmeth, vers, natoms)
c
c     Subroutine getgmut
c
c     Created:  July 7, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Looks at MCCM-UT calculation requested, gets the
c        necessary electronic structure information from esgrad 
c        and passes it off to calmut to calculate the gradient.
c
c     Called by:  mcghk, mchhk
c     Calls:  calmut
c
c     Variables defined here:
c
      use param
      use gradient, only : esgrad, mcgrad
      implicit none

      integer i, j, index, coefsw, esmeth, basis, max, natoms, vers
      double precision inpcoef(10), coef(7)
      double precision mutesgr(5,2,3*natoms)

c
c  Set electronic structure gradient array to 0.0000d0
c
      do 20 i=1, 5
         do 30 j=1, 3*natoms
            mutesgr(i,1,j) = 0.0000d0
            mutesgr(i,2,j) = 0.0000d0
  30     continue
  20  continue
c
c  Gather MCCM-UT electronic structure info
c
      mutesgr(1,1,:) = esgrad(phf,pdz,:3*natoms)
      mutesgr(1,2,:) = esgrad(phf,ptz,:3*natoms)
      mutesgr(2,1,:) = esgrad(pmp2,pdz,:3*natoms)
      mutesgr(2,2,:) = esgrad(pmp2,ptz,:3*natoms)
      if (esmeth.eq.pccsd .or. esmeth.eq.pccsdt) then
         mutesgr(3,1,:) = esgrad(pccsd,pdz,:3*natoms)
      endif
      if (esmeth.eq.pccsdt) then
         mutesgr(4,1,:) = esgrad(pccsdt,pdz,:3*natoms)
      endif
      if (esmeth.eq.pmp4sdq .or. esmeth.eq.pmp4) then
         mutesgr(3,1,:) = esgrad(pmp4sdq,pdz,:3*natoms)
      endif
      if (esmeth.eq.pmp4) then
         mutesgr(4,1,:) = esgrad(pmp4,pdz,:3*natoms)
      endif
c
c  Based on the electronic structure series that the given calculation is
c    in, determine the number of differences to be taken.
c
      if (esmeth.eq.pmp4sdq)  max=3
      if (esmeth.eq.pmp4)     max=4
      if (esmeth.eq.pccsd)    max=3
      if (esmeth.eq.pccsdt)   max=4
c
c  Look at coefsw and depending on whether default or non-default
c    coefficients have been requested, pass on to calgmut either the input
c    coefficients (inpcoef) or the default coefficients from param.inc 
c
      do 40 i=1, 7
         coef(i) = 0.0000d0
  40  continue
      
      if (coefsw.eq.def) then
         coef = mutdefc(vers, esmeth, :7)
      elseif (coefsw.eq.nodef) then
         coef = inpcoef(:7)
      endif
c
c  Call calgmut to calculation the MCCM-UT energy based on the e.s.
c    information and the given coefficients.
c
      do 60 j=1, 3*natoms
         call calmut(mcgrad(index,j),coef,mutesgr(:,:,j),max,natoms)
  60  continue

      return
      end
c
c******************************************************************************
c  GETGIB
c******************************************************************************
c
      subroutine getgib(index, coefsw, inpcoef, esmeth, natoms)
c
c     Subroutine getgib
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Looks at IB calculation requested, gets the
c        necessary electronic structure information from esgrad and pass
c        it off to calib to calculate the gradient.
c
c     Called by:  mcghk, mchhk
c     Calls:  calib
c
c     Variables defined here:
c
      use param
      use gradient, only : esgrad, mcgrad
      implicit none

      integer i, j, index, coefsw, esmeth, basis, max, natoms
      double precision inpcoef(10), alpha, beta
      double precision ibesgr(2,2,3*natoms)

c
c  Set electronic structure energy arrays to 0.0000d0
c
      do 20 j=1, 3*natoms
         ibesgr(1,1,j) = 0.0000d0
         ibesgr(2,1,j) = 0.0000d0
         ibesgr(1,2,j) = 0.0000d0
         ibesgr(2,2,j) = 0.0000d0 
  20  continue
c
c  Gather IB electronic structure info in ibes
c
      ibesgr(1,1,:) = esgrad(phf,pdz,:3*natoms)
      ibesgr(1,2,:) = esgrad(phf,ptz,:3*natoms)
      ibesgr(2,1,:) = esgrad(esmeth,pdz,:3*natoms)
      ibesgr(2,2,:) = esgrad(esmeth,ptz,:3*natoms)
c
c  Look at coefsw and depending on whether default or non-default
c    coefficients have been requested, pass on to calgib either the input
c    coefficients (inpcoef) or the default coefficients from param.inc 
c
      alpha = 0.0000d0
      beta = 0.0000d0
      
      if (coefsw.eq.def) then
         alpha = ibdefa
         beta = ibdefb(esmeth)
      elseif (coefsw.eq.nodef) then
         alpha = inpcoef(1)
         beta = inpcoef(2)
      endif
c
c  Call calgib to calculation the IB gradient based on the e.s.
c    information and the given coefficients.
c
      do 60 j=1, 3*natoms

c
c  Commented by Jingzhi Pu, incorrect number of parameter in this       0418PJ01
c  call at Multilevel 2.2 and early versions                            0418PJ01
c
c       call calib(mcgrad(index,j),alpha,beta,ibesgr(:,:,j),natoms)
c

        call calib(mcgrad(index,j),alpha,beta,ibesgr(:,:,j))            0418PJ01

  60  continue

      return
      end
c
c******************************************************************************
c  GETGMCS
c******************************************************************************
c
      subroutine getgmcs(index, coefsw, inpcoef, esmeth, vers, 
     *                   basis, natoms)
c
c     Subroutine getgmcs
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Looks at MCSAC calculation requested, gets the
c        necessary electronic structure information from esgrad and pass
c        it off to calmcs to calculate the gradient.
c
c     Called by:  mcghk, mchhk
c     Calls:  calmcs
c
c     Variables defined here:
c
      use param
      use gradient, only : esgrad, mcgrad
      implicit none

      integer i, j, index, coefsw, esmeth, basis, max, natoms, vers
      double precision inpcoef(10), coef(4)
      double precision mcsesgr(5,3*natoms)

c
c  Set electronic structure energy arrays to 0.0000d0
c
      do 20 i=1, 5
         do 30 j=1, 3*natoms
            mcsesgr(i,j) = 0.0000d0
  30     continue
  20  continue
c
c  Gather MCSAC info and pass to calgmcs
c
      mcsesgr(1,:) = esgrad(phf, basis, :3*natoms)
      mcsesgr(2,:) = esgrad(pmp2, basis, :3*natoms)
      if (esmeth.eq.pccsd .or. esmeth.eq.pccsdt) then
         mcsesgr(3,:) = esgrad(pccsd, basis, :3*natoms)
      endif
      if (esmeth.eq.pccsdt) then
         mcsesgr(4,:) = esgrad(pccsdt, basis, :3*natoms)
      endif
      if (esmeth.eq.pmp4sdq .or. esmeth.eq.pmp4) then
         mcsesgr(3,:) = esgrad(pmp4sdq, basis, :3*natoms)
      endif
      if (esmeth.eq.pmp4) then
         mcsesgr(4,:) = esgrad(pmp4, basis, :3*natoms)
      endif
c
c  Based on the electronic structure series that the given calculation is
c    in, determine the number of differences to be taken.
c
      if (esmeth.eq.pmp4sdq)  max=3
      if (esmeth.eq.pmp4)     max=4
      if (esmeth.eq.pccsd)    max=3
      if (esmeth.eq.pccsdt)   max=4
c
c  Look at coefsw and depending on whether default or non-default
c    coefficients have been requested, pass on to calgmcs either the input
c    coefficients (inpcoef) or the default coefficients from param.inc 
c
      do 40 i=1, 4
         coef(i) = 0.0000d0
  40  continue
      
      if (coefsw.eq.def) then
         coef = mcsdefc(vers, esmeth, basis, :4)
      elseif (coefsw.eq.nodef) then
         coef = inpcoef(:4)
      endif

c
c  Call calgmcs to calculate the MCSAC gradient based on the e.s.
c    information and the given coefficients.
c
      do 60 j=1, 3*natoms
         call calmcs(mcgrad(index,j),coef,mcsesgr(:,j),max,natoms)
  60  continue

      return
      end
c
c******************************************************************************
c  GETGSAC
c******************************************************************************
c
      subroutine getgsac(index, coefsw, inpcoef, esmeth, vers, 
     *                   basis, natoms)
c
c     Subroutine getgsac
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Looks at SAC calculation requested, gets the
c        necessary electronic structure information from esgrad and pass
c        it off to calsac to calculate the gradient.
c
c     Called by:  mcghk, mchhk
c     Calls:  calsac
c
c     Variables defined here:
c
      use param
      use gradient, only : esgrad, mcgrad
      implicit none

      integer i, j, index, coefsw, esmeth, basis, max, natoms, vers
      double precision inpcoef(10), coef
      double precision sacesgr(2,3*natoms)

c
c  Set electronic structure energy arrays to 0.0000d0
c
      do 20 j=1, 3*natoms
         sacesgr(1,j) = 0.0000d0
         sacesgr(2,j) = 0.0000d0
  20  continue
c
c  Gather SAC info and pass to calgsac
c
      sacesgr(1,:) = esgrad(phf, basis, :3*natoms)
      sacesgr(2,:) = esgrad(esmeth, basis, :3*natoms)
c
c  Look at coefsw and depending on whether default or non-default
c    coefficients have been requested, pass on to calgsac either the input
c    coefficients (inpcoef) or the default coefficients from param.inc 
c
      coef = 0.0000d0

      if (coefsw.eq.def) then
         coef = sacdefc(vers, esmeth,basis)
      elseif (coefsw.eq.nodef) then
         coef = inpcoef(1)
      endif
c
c  Call calgsac to calculate the SAC gradient based on the e.s.
c    information and the given coefficients.
c 
      do 60 j=1, 3*natoms
         call calsac(mcgrad(index,j),coef,sacesgr(:,j),natoms)
  60  continue

      return
      end
c
c*****************************************************************************
c  PROGGHK
c*****************************************************************************
c
      subroutine progghk(ppnum, prognme, esmeth, esbas, geom, optl, 
     *                    ener, grad, ierr, ver_lab)
c
c     Subroutine progghk
c
c     Created:  June 28, 1999 by J. M. Rodgers
c     Revised:  October 24, 2000 by B. J. Lynch
c     Purpose:  Get a single point energy and gradient for the given geom
c        with the specified electronic structure package.
c
c     Description:  Calls a function to write a G94/98 FORCE input file,
c         runs this calculation on the system, and then calls a fxn that
c         reads the energy and gradient from the formatted checkpoint file
c         created by G94/98.
c
c     Note:  Currently only G94/G98 are enabled but it would be easily
c        expanded to other electronic structure programs.  new _inpe and
c        _oute subroutines would have to be written for each different
c        program though.
c
c     Called by:  hfmoghk, optghk, imohcghk, esgparse, mcoghk, mnmghk,
c        mutghk, mcsghk, ibghk, sacghk, g2ghk, g3ghk, mg2ghk, mg3ghk, 
c        mqcghk, mcomp2ghk, mccoghk, mc3bbghk, mc3mpwghk
c     Calls:  g98inp, g98oute, mg98oute, g98outg, system
c
c     Variables defined here:
c
      use caltyp
      use files
      use input, only : cartgeom
      implicit none

      character*10 prognme
      character*20 esmeth, esbas, ver_lab                                                
      type (cartgeom) :: geom
      character*80 optl(5)
      double precision ener, grad(3*geom%natoms)
      integer ierr, ppnum
      
c
c  GAUSSIAN98
c
      if (prognme(:3).eq.'g98') then
         open (unit=g98inf, status='unknown', file=g98in, err=9991)
         call g98inp(g98inf, esmeth, esbas,geom,optl,tgrad,ver_lab)
         close (g98inf, err=9991)
         call system('./g98shuttle g98.inp g98.out')
         call g98oute(1,esmeth, ener)
         call g98outg(1,esmeth, grad, geom%natoms)



c
c  Parallel GAUSSIAN98 by B. J. Lynch
c
c    Durring parallel g98 excecution, if ppnum is .eq. 1 then
c    the job is run exactly like a normal g98 job.  If ppnum is
c    anything else, the pg98shuttle is used so that additional
c    Test.fchk files are put in separate directories


      elseif (prognme(:4).eq.'pg98') then

       if (ppnum .eq. 1) then

         open (unit=g98inf, status='unknown', file=g98in, err=9991)
         call g98inp(g98inf,esmeth,esbas,geom,optl,tgrad,ver_lab)
         close (g98inf, err=9991)
         call system('./g98shuttle g98.inp g98.out')
         call g98oute(ppnum, esmeth, ener)
         call g98outg(ppnum, esmeth, grad, geom%natoms)
      
       elseif (ppnum .eq. 2) then
         open (unit=g98in2f, status='unknown', file=g98in2, err=9991)
         call g98inp(g98in2f,esmeth,esbas,geom,optl,tgrad,ver_lab)
         close (g98in2f, err=9991)
         call system('pg98shuttle g98_2.inp g98_2.out')
         call g98oute(ppnum, esmeth, ener)
         call g98outg(ppnum, esmeth, grad, geom%natoms)

       endif



c
c  GAUSSIAN94        
c    Just reuse g98inp and g98outg since formats in the FChk files have
c    remained essentially the same.
c
      elseif (prognme(:3).eq.'g94') then
         open (unit=g94inf, status='unknown', file=g94in, err=9992)
         call g98inp(g94inf,esmeth,esbas,geom,optl,tgrad,ver_lab)
         close (g94inf, err=9992)
         call system('./g94shuttle g94.inp g94.out')
         call g98oute(1,esmeth, ener)
         call g98outg(1,esmeth, grad, geom%natoms)
c
c  GAUSSIAN03
c    Just reuse g98inp and g98outg since formats in the FChk files have
c    remained essentially the same.
c
      elseif (prognme(:3).eq.'g03') then
         open (unit=g03inf, status='unknown', file=g03in, err=9993)
         call g98inp(g03inf,esmeth,esbas,geom,optl,tgrad,ver_lab)
         close (g03inf, err=9993)
         call system('./g03shuttle g03.inp g03.out')
         call g98oute(1,esmeth, ener)
         call g98outg(1,esmeth, grad, geom%natoms)                             1409ZY03
c
c  GAUSSIAN09                                                           0808RMP12
c
      elseif (prognme(:3).eq.'g09') then
         open (unit=g09inf, status='unknown', file=g09in, err=9994)
         call g98inp(g09inf,esmeth,esbas,geom,optl,tgrad,ver_lab)
         close (g09inf, err=9993)
         call system('./g09shuttle g09.inp g09.out')
         call g98oute(1,esmeth, ener)
         call g98outg(1,esmeth, grad, geom%natoms)                      0808RMP12 
    
      endif

      return

9991  write (outfile,*) 'Error creating Gaussian98 Forces input file'
      stop 'progghk 1'
9992  write (outfile,*) 'Error creating Gaussian94 Forces input file'
      stop 'progghk 2'
9993  write (outfile,*) 'Error creating Gaussian03 Forces input file'
      stop 'progghk 3'
9994  write (outfile,*) 'Error creating Gaussian09 Forces input file'
      stop 'progghk 4'

      end
c
c
c*****************************************************************************
c  G98OUTG
c*****************************************************************************
c  
      subroutine g98outg (ppnum, esmeth, grad, natoms)
c
c     Subroutine g98outg
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Get the gradient out of the Gaussian98 formatted
c        checkpoint file.  (Also used for Gaussian94)
c
c     Called by:  progghk, proghhk
c     Calls:
c
c     Variables defined here: 
c     
      use files
      use numfmt
      implicit none
      
      character*20  esmeth
      double precision  grad(3*natoms), cfltfmt

      integer ctr, i, natoms, j, gstrt, gend, ppnum,fchknum                    1025BL00
      character*80 string, case
      character*15 gtxt(3*natoms)
      character*14 fchkname                                                    1025BL00

c                                                                     
c  Open the formatted checkpoint file.
c

c
c  ppnum determines the name of the input and output files for parallel runs
c
      if (ppnum .eq. 2) then                                                  1023BL00
      fchknum = fchk2                                                         1023BL00
      fchkname = testfchk2                                                    1023BL00
      else                                                                    1023BL00
      fchknum = fchk                                                          1023BL00
      fchkname = testfchk                                                     1023BL00
      endif                                                                   1023BL00




      open( unit=fchknum, status='unknown', file=fchkname, err=9900)

      read( fchknum, '(a80)', end=9910 ) string
      string = case(string)
 
      do while( string(:18).ne.'cartesian gradient' .and. 
     *              string(:16).ne.'cartesian forces' )
         read( fchknum, '(a80)', end=9910 ) string
         string = case(string)
      enddo
c
c  Get each element of gradient as a piece of text and put into an array
c    of strings.
c
      ctr = 1
      do while( ctr .le. 3*natoms )
         read( fchknum, '(a80)', end=9910 ) string
         string = case(string)
         i = 0
         do while( ctr.le.3*natoms .and. i.lt.5 )
            gstrt = i*(nlen(gfmt)+1)+2
            gend  = (i+1)*(nlen(gfmt)+2)
            gtxt(ctr) = string(gstrt:gend)
            ctr = ctr+1
            i = i+1
         end do
      end do
c
c  Convert strings to floating points
c
      do 20 j=1, 3*natoms
         grad(j) = cfltfmt(gtxt(j),gfmt)
  20  continue

      close( unit=fchknum )

      return

9900  write( outfile,*) 'Error opening Gaussian98 checkpoint file'
      stop 'g98outg 1'
9910  write( outfile,*) 'Error reading Gaussian98 checkpoint file'
      stop 'g98outg 2'

      end
c
c
c******************************************************************************
c  HFMOGHK
c******************************************************************************
c
      subroutine hfmoghk(hfprognme, moprognme, geom, hfmoinp, ierr)
c
c     Subroutine hfmoghk
c  
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine the HF||MO energy and gradient
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calhfmo, hfmodisp
c
c     Variables defined here:  none.
c
      use caltyp, only : tgrad
      use input, only : cartgeom, hfmoinf
      use param, only : esmlist, fesmlist, phf
      use files, only : outfile
      use energy, only : hfmoener
      use gradient, only : hfmograd
      implicit none
c
      character*10 hfprognme, moprognme
      type (cartgeom) :: geom
      type (hfmoinf)  :: hfmoinp
      integer ierr, i
      
      call progghk(1,hfprognme, esmlist(phf), hfmoinp%hfkbas, geom,
     *               hfmoinp%hfkoptl, hfmoener(1), 
     *               hfmograd(1,:3*geom%natoms), ierr, 'null')
      call progghk(1,moprognme, hfmoinp%mokmeth, '   ', geom,
     *               hfmoinp%mokoptl, hfmoener(2), 
     *               hfmograd(2,:3*geom%natoms), ierr, 'null')
 
      call calhfmo(hfmoener(3),hfmoinp%frachf,hfmoener(1),hfmoener(2))
      do 20 i=1, 3*geom%natoms
         call calhfmo(hfmograd(3,i), hfmoinp%frachf, hfmograd(1,i),
     *                   hfmograd(2,i))
  20  continue

      call hfmodisp(geom%natoms, tgrad)

      return
      end

c
c******************************************************************************
c  G2GHK
c******************************************************************************
c
      subroutine g2ghk(prognme, geom, lmg2, g2inp, ierr)
c
c     Created:  July 14, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To get G2 energy and gradient
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calg, g2disp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, ginf
      use gparam
      use files, only : outfile
      use energy, only : g2es, g2ener
      use gradient, only : g2esgr, g2grad

      implicit none

      character*10     :: prognme
      type (cartgeom)  :: geom
      type (ginf)      :: g2inp
      integer          :: ierr, lmg2, i, n3tm

      double precision, parameter :: a = 0.00500d0
      double precision, parameter :: b = 0.00019d0

      double precision :: gethlc

      n3tm = 3*geom%natoms
c     
c  If an MCG2 calculation has already been done then a lot of the 
c    energies and gradients have already been collected in g2es/g2esgr.
c  Definitions of each calculation called can be found in the module
c    gparam.
c
      if (lmg2 .eq. 1) then
         call progghk(1,prognme, g2esml(4), g2basl(4), geom,
     *      g2inp%optl, g2es(4), g2esgr(4,:n3tm), ierr,'null')
         call progghk(1,prognme, g2esml(5), g2basl(5), geom,
     *      g2inp%optl, g2es(5), g2esgr(5,:n3tm), ierr,'null')
      else
         do 20 i=1, numg2es
            call progghk(1,prognme, g2esml(i), g2basl(i), geom,
     *          g2inp%optl,g2es(i),g2esgr(i,:n3tm),ierr,'null')
  20     continue
      endif
c
c  Add HLC correction - 0 for the gradient
c
      g2es(phlc) = gethlc(g2inp%alpha, g2inp%beta, a, b)
      do 40 i=1, n3tm
         g2esgr(phlc,i) = 0.0000d0
  40  continue
c
c  No SO correction for g2
c
      g2es(pso)  = 0.0000d0
      do 60 i=1, n3tm
         g2esgr(pso,i)  = 0.0000d0
  60  continue
      
      call calg(g2ener, g2es)
      do 80 i=1, n3tm
         call calg(g2grad(i), g2esgr(:,i))
  80  continue

      call g2disp(geom%natoms,tgrad)

      return
      end
c
c******************************************************************************
c  MG2GHK
c******************************************************************************
c     
      subroutine mg2ghk(prognme, geom, mg2inp, ierr)
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To get MCG2 energies and gradients
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calmg2, mg2disp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mginf
      use gparam
      use energy, only : mg2ener,mg2es,eso,ecc,erel,g2es
      use gradient, only : mg2grad, mg2esgr, g2esgr
      use files, only : outfile

      implicit none
         
      character*10     :: prognme
      type (cartgeom)  :: geom
      type (mginf)     :: mg2inp
      integer          :: ierr, i, j

c
c  Gather all the energies necessary to calculate MCG2 energies.
c  Definitions of each calculation called can be found in the module
c    gparam.
c
      do 20 i=1, nummg2es
         call progghk(1, prognme, mg2esml(i), mg2basl(i), 
     *              geom, mg2inp%optl, mg2es(i), 
     *              mg2esgr(i,:3*geom%natoms), ierr,'null')
  20  continue
c
c  Pass on duplicate info to g2es, so won't have to be reproduced if a g2
c    calculation has been specifed.
c
      g2es(1) = mg2es(2)
      g2es(2) = mg2es(4)
      g2es(3) = mg2es(5)
      g2es(6) = mg2es(6)
      g2es(7) = mg2es(8)
      g2es(8) = mg2es(10)

      g2esgr(1,:) = mg2esgr(2,:)
      g2esgr(2,:) = mg2esgr(4,:)
      g2esgr(3,:) = mg2esgr(5,:)
      g2esgr(6,:) = mg2esgr(6,:)
      g2esgr(7,:) = mg2esgr(8,:)
      g2esgr(8,:) = mg2esgr(10,:)
c
c  Calculate the MCG2 energy and gradient
c
      call calmg2(mg2ener, mg2inp%mcoef, mg2es)
      mg2ener = mg2ener + eso + ecc + erel
      do 40 j=1, 3*geom%natoms
         call calmg2(mg2grad(j), mg2inp%mcoef, mg2esgr(:,j))
  40  continue
c     
      call mg2disp(geom%natoms,tgrad)         
      
      return
      end
c
c******************************************************************************
c  G3GHK
c******************************************************************************
c
      subroutine g3ghk(prognme, geom, lmg3, g3inp, ierr)
c
c     Created:  July 14, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To get G3 energy and gradient.
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calg, g3disp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, ginf
      use gparam
      use files, only : outfile
      use energy, only : g3es, g3ener
      use gradient, only : g3esgr, g3grad

      implicit none

      character*10     :: prognme
      type (cartgeom)  :: geom
      type (ginf)      :: g3inp
      integer          :: ierr, i, lmg3, n3tm

      double precision, parameter :: a = 0.006386d0
      double precision, parameter :: b = 0.002977d0
      double precision, parameter :: c = 0.006219d0
      double precision, parameter :: d = 0.001185d0

      double precision :: gethlc, getso

      n3tm = 3*geom%natoms
c
c  If an MCG3 calculation has already been done then a lot of the
c    energies and gradients have already been collected in g3es.
c  Definitions of each calculation called can be found in the module
c    gparam.
c
      if (lmg3 .eq. 1) then
         call progghk(1,prognme, g3esml(4), g3basl(4), geom,
     *           g3inp%optl, g3es(4), g3esgr(4,:n3tm), ierr,'null')
         call progghk(1,prognme, g3esml(5), g3basl(5), geom,
     *           g3inp%optl, g3es(5), g3esgr(5,:n3tm), ierr,'null')
         call progghk(1,prognme, g3esml(7), g3basl(7), geom,
     *           g3inp%optl, g3es(7), g3esgr(7,:n3tm), ierr,'null')
         call progghk(1,prognme, g3esml(8), g3basl(8), geom,
     *           g3inp%optl, g3es(8), g3esgr(8,:n3tm), ierr,'null')
      else
         do 20 i=1, numg3es
            call progghk(1,prognme, g3esml(i), g3basl(i), geom,
     *           g3inp%optl, g3es(i), g3esgr(i,:n3tm), ierr,'null')
  20     continue
      endif
c
c  Get the HLC and SO - 0 for gradients
c
      if (geom%natoms.eq.1) then
         g3es(phlc) = gethlc(g3inp%alpha, g3inp%beta, c, d)
         g3es(pso)  = getso(geom%atm(1), geom%charge)
      else
         g3es(phlc) = gethlc(g3inp%alpha, g3inp%beta, a, b)
         g3es(pso)  = 0.0000d0
      endif

      do 40 i=1, n3tm
         g3esgr(phlc,i) = 0.0000d0
         g3esgr(pso,i)  = 0.0000d0
  40  continue

      call calg(g3ener, g3es)
      do 60 i=1, n3tm
         call calg(g3grad(i), g3esgr(:,i))
  60  continue

      call g3disp(geom%natoms,tgrad)

      return
      end
c
c******************************************************************************
c  MQCGHK
c******************************************************************************
c
      subroutine mqcghk(prognme, geom, lmg3, mqcinp, ierr)
c
c     Created:  January 10, 2000 by P. L. Fast
c     Revised:  Feb 24, 2002, B. J. Lynch
c     Purpose:  To get MC-QCISD energy and gradient.
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calg, mqcdisp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mginf
      use gparam
      use files, only : outfile
      use energy, only : mqces, mqcener
      use gradient, only : mqcesgr, mqcgrad

      implicit none

      character*20     ver_lab
      character*10     :: prognme
      type (cartgeom)  :: geom
      type (mginf)     :: mqcinp
      integer          :: ierr, i, lmg3, n3tm


      ver_lab = mqcinp%version
      n3tm = 3*geom%natoms
c
c  If an MCG3 calculation has already been done then three of the
c    energies and gradients have already been collected in mqces.
c  Definitions of each calculation called can be found in the module
c    gparam.
c
      if ((lmg3.eq.1).and.(ver_lab(:3).ne.'v3s').and.(ver_lab(:3)
     *   .ne.'v3m')) then
         call progghk(1,prognme, mqcesml(3), mqcbasl(3), geom,
     *                  mqcinp%optl, mqces(3), mqcesgr(3,:n3tm), ierr
     *                  ,ver_lab)
      elseif((ver_lab(:3).eq.'v3s').or.(ver_lab(:3).eq.'v3m'))then
         do 10 i=1, 5
            call progghk(1,prognme,mqcesml_3(i),mqcbasl_3(i),geom,
     *                     mqcinp%optl, mqces(i), mqcesgr(i,:n3tm),
     *                     ierr,ver_lab)
  10     continue
      else
         do 20 i=1, nummqces
            call progghk(1,prognme, mqcesml(i), mqcbasl(i), geom,
     *                     mqcinp%optl, mqces(i), mqcesgr(i,:n3tm),
     *                     ierr,ver_lab)
  20     continue
      endif

      call calmqc(mqcener, mqcinp%mqcoef, mqces,ver_lab)
      do 60 i=1, n3tm
        call calmqc(mqcgrad(i),mqcinp%mqcoef,mqcesgr(:,i),ver_lab)
  60  continue

      call mqcdisp(geom%natoms,tgrad,ver_lab)

      return
      end
c
c******************************************************************************
c  MCOMP2GHK
c******************************************************************************
c
      subroutine mcomp2ghk(prognme, geom, lmg3, mcomp2inp, ierr)
c
c     Created:  January 10, 2000 by P. L. Fast
c     Revised:  July 10, 2000 by Jingzhi Pu
c     Purpose:  To get MCOMP2 energy and gradient.
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calg, mcomp2disp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mginf
      use gparam
      use files, only : outfile
      use energy, only : mcomp2es, mcomp2ener
      use gradient, only : mcomp2esgr, mcomp2grad

      implicit none

      character*20  ver_lab
      character*10     :: prognme
      type (cartgeom)  :: geom
      type (mginf)     :: mcomp2inp
      integer          :: ierr, i, lmg3, n3tm

      ver_lab = mcomp2inp%version
      n3tm = 3*geom%natoms
c
c  If an MCG3 calculation has already been done then three of the
c    energies and gradients have already been collected in mcomp2es.
c  Definitions of each calculation called can be found in the module
c    gparam.
c
c     if (lmg3 .eq. 1) then                                             0711PJ00
c         call progghk(1,prognme, mcomp2esml(3), mcomp2basl(3),         1024BL00
c    *                geom, mcomp2inp%optl, mcomp2es(3),                1024BL00 
c    *                mcomp2sgr(3,:n3tm), ierr,ver_lab)                 1024BL00
c     else                                                              0711PJ00



         if((ver_lab(:3).eq.'v3m').or.(ver_lab(:3).eq.'v3s'))then
         do 20 i=1, nummcomp2es                                         0224BL02
           call progghk(1,prognme,mcomp2esml_3(i),mcomp2basl_3(i),      0224BL02
     *                   geom, mcomp2inp%optl, mcomp2es(i),             0224BL02
     *                   mcomp2esgr(i,:n3tm),ierr,ver_lab)              0224BL02
  20     continue                                                       0224BL02

         else                                                           0224BL02
         do 30 i=1, nummcomp2es
            call progghk(1, prognme, mcomp2esml(i), mcomp2basl(i), 
     *                   geom, mcomp2inp%optl, mcomp2es(i),
     *                   mcomp2esgr(i,:n3tm),ierr,ver_lab)
  30     continue
         endif                                                          0224BL02



c     endif                                                             0711PJ00

      call calmcomp2(mcomp2ener, mcomp2inp%mcomp2coef, mcomp2es)
      do 60 i=1, n3tm
         call calmcomp2(mcomp2grad(i), mcomp2inp%mcomp2coef, 
     *                  mcomp2esgr(:,i))
  60  continue

      call mcomp2disp(geom%natoms,tgrad,ver_lab)

      return
      end

c******************************************************************************
c  MCCOGHK
c******************************************************************************
c
      subroutine mccoghk(prognme, geom, lmg3, mccoinp, ierr)
c
c     Created:  July 12, 2002
c     Revised:  
c     Purpose:  To get MCCO energy and gradient.
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calg, mccodisp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mginf
      use gparam
      use files, only : outfile
      use energy, only : mccoes, mccoener
      use gradient, only : mccoesgr, mccograd

      implicit none

      character*20  ver_lab
      character*10     :: prognme
      type (cartgeom)  :: geom
      type (mginf)     :: mccoinp
      integer          :: ierr, i, lmg3, n3tm

      ver_lab = mccoinp%version
      n3tm = 3*geom%natoms


         do 30 i=1, nummccoes
            call progghk(1, prognme, mccoesml(i), mccobasl(i), 
     *                   geom, mccoinp%optl, mccoes(i),
     *                   mccoesgr(i,:n3tm),ierr,ver_lab)
  30     continue


      call calmcco(mccoener, mccoinp%mccocoef, mccoes)
      do 60 i=1, n3tm
         call calmcco(mccograd(i), mccoinp%mccocoef, 
     *                  mccoesgr(:,i))
  60  continue

      call mccodisp(geom%natoms,tgrad,ver_lab)

      return
      end

c******************************************************************************
c  MC3BBGHK
c******************************************************************************
c
      subroutine mc3bbghk(prognme, geom, lmg3, mc3bbinp, ierr)
c
c     Created:   Dec. 12, 2003 by Yan Zhao
c     Revised:
c     Purpose:  To get MC3BB  energy and gradient.
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calg, mc3bbdisp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mginf
      use gparam
      use files, only : outfile
      use energy, only : mc3bbes, mc3bbener
      use gradient, only : mc3bbesgr, mc3bbgrad

      implicit none

      character*20  ver_lab
      character*10     :: prognme
      type (cartgeom)  :: geom
      type (mginf)     :: mc3bbinp
      integer          :: ierr, i, lmg3, n3tm

      ver_lab = mc3bbinp%version
      n3tm = 3*geom%natoms


         do 30 i=1, nummc3bbes
            call progghk(1, prognme, mc3bbesml(i), mc3bbbasl(i),
     *                   geom, mc3bbinp%optl, mc3bbes(i),
     *                   mc3bbesgr(i,:n3tm),ierr,ver_lab)
  30     continue


      call calmc3bb(mc3bbener, mc3bbinp%mc3bbcoef, mc3bbes)
      do 60 i=1, n3tm
         call calmc3bb(mc3bbgrad(i), mc3bbinp%mc3bbcoef,
     *                  mc3bbesgr(:,i))
  60  continue

      call mc3bbdisp(geom%natoms,tgrad,ver_lab)

      return
      end


c******************************************************************************
c  MC3MPWGHK
c******************************************************************************
c
      subroutine mc3mpwghk(prognme, geom, lmg3, mc3mpwinp, ierr)
c
c     Created:   Dec. 12, 2003 by Yan Zhao
c     Revised:
c     Purpose:  To get MC3MPW  energy and gradient.
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calg, mc3mpwdisp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mginf
      use gparam
      use files, only : outfile
      use energy, only : mc3mpwes, mc3mpwener
      use gradient, only : mc3mpwesgr, mc3mpwgrad

      implicit none

      character*20  ver_lab
      character*10     :: prognme
      type (cartgeom)  :: geom
      type (mginf)     :: mc3mpwinp
      integer          :: ierr, i, lmg3, n3tm

      ver_lab = mc3mpwinp%version
      n3tm = 3*geom%natoms


         do 30 i=1, nummc3mpwes
            call progghk(1, prognme, mc3mpwesml(i), mc3mpwbasl(i),
     *                   geom, mc3mpwinp%optl, mc3mpwes(i),
     *                   mc3mpwesgr(i,:n3tm),ierr,ver_lab)
  30     continue


      call calmc3mpw(mc3mpwener, mc3mpwinp%mc3mpwcoef, mc3mpwes)
      do 60 i=1, n3tm
         call calmc3mpw(mc3mpwgrad(i), mc3mpwinp%mc3mpwcoef,
     *                  mc3mpwesgr(:,i))
  60  continue

      call mc3mpwdisp(geom%natoms,tgrad,ver_lab)

      return
      end




c******************************************************************************
c  G3SX(MP3)GHK
c******************************************************************************
c
      subroutine g3sxmp3ghk(prognme, geom, lmg3, g3sxmp3inp, ierr)
c
c     Created:   Dec. 12, 2003 by Yan Zhao
c     Revised:
c     Purpose:  To get G3SX(MP3)  energy and gradient.
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calg, g3sxmp3disp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mginf
      use gparam
      use files, only : outfile
      use energy, only : g3sxmp3es, g3sxmp3ener
      use gradient, only : g3sxmp3esgr, g3sxmp3grad

      implicit none

      character*20  ver_lab
      character*10     :: prognme
      type (cartgeom)  :: geom
      type (mginf)     :: g3sxmp3inp
      integer          :: ierr, i, lmg3, n3tm

      ver_lab = g3sxmp3inp%version
      n3tm = 3*geom%natoms

      do 30 i=1, numg3sxmp3es
       call progghk(1, prognme, g3sxmp3esml(i), g3sxmp3basl(i),
     *                   geom, g3sxmp3inp%optl, g3sxmp3es(i),
     *                   g3sxmp3esgr(i,:n3tm),ierr,ver_lab)
  30     continue


      call calg3sxmp3(g3sxmp3ener,g3sxmp3inp%g3sxmp3coef,g3sxmp3es)
      do 60 i=1, n3tm
         call calg3sxmp3(g3sxmp3grad(i), g3sxmp3inp%g3sxmp3coef,
     *                  g3sxmp3esgr(:,i))
  60  continue

      call g3sxmp3disp(geom%natoms,tgrad,ver_lab)

      return
      end


c    
c******************************************************************************
c  MG3GHK
c******************************************************************************
c
      subroutine mg3ghk(prognme, geom, mg3inp, ierr)
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:  Feb 24, 2002 by B. J. Lynch
c     Purpose:  To get MCG3 energies and gradients
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, calmg3, mg3disp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mginf
      use gparam
      use energy, only : mg3ener,mg3es,eso,ecc,erel,g3es,mqces 
      use gradient, only : mg3grad, mg3esgr, g3esgr, mqcesgr 
      use files, only : outfile
     
      implicit none
     
      character*20     ver_lab
      character*10     :: prognme
      type (cartgeom)  :: geom
      type (mginf)     :: mg3inp 
      integer          :: ierr, i, j
      
c
c  Gather all the energies necessary to calculate MCG3 energies.
c  Definitions of each calculation called can be found in the module
c    gparam.
c

      ver_lab = mg3inp%version

      if (prognme(:4).eq.'pg98') then                                   1024BL00

!$OMP PARALLEL SECTIONS                                                 1024BL00
!$OMP SECTION                                                           1024BL00

      do 20 i=1, 4                                                      1024BL00
         call progghk(1, prognme, mg3esml(i), mg3basl(i),               1024BL00
     *                geom, mg3inp%optl, mg3es(i),                      1024BL00
     *                  mg3esgr(i,:3*geom%natoms), ierr
     *                  ,ver_lab)                                       0224BL02
  20  continue                                                          1024BL00

      do 21 i=6, 9                                                      1024BL00
         call progghk(1, prognme, mg3esml(i), mg3basl(i),               1024BL00
     *                geom, mg3inp%optl, mg3es(i),                      1024BL00
     *                  mg3esgr(i,:3*geom%natoms), ierr,                0224BL02
     *                  ver_lab)
  21  continue                                                          1024BL00


!$OMP SECTION                                                           1024BL00
         call progghk(2, prognme, mg3esml(5), mg3basl(5),               1024BL00
     *                geom, mg3inp%optl, mg3es(5),                      1024BL00
     *                  mg3esgr(5,:3*geom%natoms), ierr                 0224BL02
     *                  ,ver_lab)                                       0224BL02

!$OMP END PARALLEL SECTIONS

      elseif((ver_lab(:3).eq.'v3s').or.(ver_lab(:3).eq.'v3m'))then
      do 23 i=1, nummg3es-1                                             0224BL02
         call progghk(1, prognme, mg3esml_3(i), mg3basl_3(i),           0224BL02
     *                geom, mg3inp%optl, mg3es(i),                      0224BL02
     *                  mg3esgr(i,:3*geom%natoms), ierr,                0224BL02
     *                  ver_lab)                                        0224BL02
  23  continue

      else
      do 22 i=1, nummg3es                                               1024BL00
         call progghk(1, prognme, mg3esml(i), mg3basl(i),               1024BL00
     *                geom, mg3inp%optl, mg3es(i),                      0224BL02
     *                  mg3esgr(i,:3*geom%natoms), ierr,                0224BL02
     *                  ver_lab)                                        0224BL02
  22  continue

      endif

c
c  Pass on some energies to g3es so won't have to be recalculated in g3
c    is also selected.
c
C      g3es(1) = mg3es(2)
C      g3es(2) = mg3es(4)
C      g3es(3) = mg3es(5)
C      g3es(6) = mg3es(6)

C      g3esgr(1,:) = mg3esgr(2,:)
C      g3esgr(2,:) = mg3esgr(4,:)
C      g3esgr(3,:) = mg3esgr(5,:)
C      g3esgr(6,:) = mg3esgr(6,:)
c
c  Pass calculated energies and gradients to mqces if mqcisd is also selected
c
C      mqces(1) = mg3es(1)                                               0110PF00
C      mqces(2) = mg3es(2)                                               0110PF00
C      mqces(4) = mg3es(9)                                               0110PF00

C      mqcesgr(1,:) = mg3esgr(1,:)                                       0110PF00
C      mqcesgr(2,:) = mg3esgr(2,:)                                       0110PF00
C      mqcesgr(4,:) = mg3esgr(9,:)                                       0110PF00
c
c  Calculate the MCG3 energy and gradient
c
      call calmg3(mg3ener, mg3inp%mcoef, mg3es,ver_lab)
      mg3ener = mg3ener + eso + ecc + erel
      do 40 j=1, 3*geom%natoms
         call calmg3(mg3grad(j), mg3inp%mcoef, mg3esgr(:,j),ver_lab)
  40  continue

      call mg3disp(geom%natoms,tgrad,ver_lab)
      
      return
      end
c
c******************************************************************************
c  MCOGHK
c******************************************************************************
c
      subroutine mcoghk(prognme,geom,mcoinp,optl)
c     Subroutine mcoghk
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To carry out an MCCM-CO calculation with non-standard
c        bases (non-standard methods currently not supported).  Makes all
c        electronic structure program calls and parses electronic
c        information to pass on to calmco.  Energy; Gradients
c
c     Called by:  mcghk, optghk
c     Calls:  progghk, calmco, mcodisp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mcinf
      use param
      use files, only : outfile
      use energy, only : mcener, eso, ecc, erel
      use gradient, only : mcgrad
      implicit none

      character*10  prognme
      type (cartgeom) ::  geom
      type (mcinf)    ::  mcoinp
      integer  ierr, max, i, j, k, mcoessw(5)
      double precision  mcoes(5,2)
      double precision  mcoesgr(5,2,3*geom%natoms)
      double precision blnkhess(3*geom%natoms)
      character*20  meth, bas1, bas2
      character*80  optl(5)

      meth = mcoinp%meth
      bas1 = mcoinp%bas1
      bas2 = mcoinp%bas2
c
c  Initialize mcoes(5,2) to 0.0000d0
c
      do 20 i=1, 5
         do 40 j=1, 2
            mcoes(i,j) = 0.0000d0
            do 50 k=1, 3*geom%natoms
               mcoesgr(i,j,k) = 0.0000d0
  50        continue
  40     continue
  20  continue
c
c  Set max equal to the number of e.s. levels in the series.
c  Set mcoessw to the appropriate order of theory calls.
c
      if (meth(:7).eq.'ccsd(t)') then
         max = 4
         mcoessw(4) = pccsdt
         mcoessw(3) = pccsd
      elseif (meth(:4).eq.'ccsd') then
         max = 3
         mcoessw(3) = pccsd
      elseif (meth(:6).eq.'mp4sdq') then
         max = 3
         mcoessw(3) = pmp4sdq
      elseif (meth(:3).eq.'mp4') then
         max = 4
         mcoessw(4) = pmp4
         mcoessw(3) = pmp4sdq
      elseif (meth(:3).eq.'mp2') then
         max = 2
      endif

      mcoessw(2) = pmp2
      mcoessw(1) = phf

c
c  Make all calls to electronic structure program
c
      do 55 i=max, 1, -1
         call progghk(1, prognme,esmlist(mcoessw(i)), bas2, geom,       1024BL00 
     *             optl, mcoes(i,2), mcoesgr(i,2,:), ierr,'null')
         call progghk(1, prognme,esmlist(mcoessw(i)), bas1, geom,       1024BL00
     *             optl, mcoes(i,1), mcoesgr(i,1,:), ierr,'null')
  55  continue
c
c  Calculate the MCCM-CO energy and gradient with calmco using the info 
c    gathered in mcoes and mcoesgr and the input coefficients.
c
      call calmco( mcener(pmco), mcoinp%coef(1:10), mcoes, max )
      mcener(pmco) = mcener(pmco) + eso + ecc + erel
      do 60 j=1, 3*geom%natoms
         call calmco(mcgrad(pmco,j), mcoinp%coef(1:10),
     *            mcoesgr(:,:,j), max)
  60  continue

      call mcodisp(mcoessw,max,mcoinp%bas1,mcoinp%bas2,mcoes,
     *               mcoesgr, blnkhess, geom%natoms, tgrad)

      return
      end

c
c******************************************************************************
c MUTGHK
c******************************************************************************
c
      subroutine mutghk(prognme,geom,mutinp,optl)
c
c     Subroutine mutghk
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To carry out an MCCM-UT calculation with non-standard
c        bases (non-standard methods currently not supported).  Makes all
c        electronic structure program calls and parses electronic
c        information to pass on to calmut.  Energy; Gradient
c
c     Called by:  mcghk, optghk
c     Calls:  progghk, calmut, mutdisp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mcinf
      use param
      use files, only : outfile
      use energy, only : mcener, eso, ecc, erel
      use gradient, only : mcgrad
      implicit none

      character*10  prognme
      type (cartgeom) ::  geom
      type (mcinf)    ::  mutinp
      integer  ierr, max, i, j, k, mutessw(5)
      double precision  mutes(5,2)
      double precision  mutesgr(5,2,3*geom%natoms)
      character*20  meth, bas1, bas2
      character*80  optl(5)
      double precision blnkhess(3*geom%natoms)

      meth = mutinp%meth
      bas1 = mutinp%bas1
      bas2 = mutinp%bas2
c
c  Initialize mutes(5,2) to 0.0000d0
c
      do 20 i=1, 5
         do 40 j=1, 2
            mutes(i,j) = 0.0000d0
            do 50 k=1, 3*geom%natoms
               mutesgr(i,j,k) = 0.0000d0
  50        continue
  40     continue
  20  continue
c
c  Set max equal to the number of e.s. levels in the series.
c  Goto appropriate place in lines below to gather the necessary energies
c    from the electronic structure program.
c
      if (meth(:7).eq.'ccsd(t)') then
         max = 4
         mutessw(4) = pccsdt
         mutessw(3) = pccsd
      elseif (meth(:4).eq.'ccsd') then
         max = 3
         mutessw(3) = pccsd
      elseif (meth(:6).eq.'mp4sdq') then
         max = 3
         mutessw(3) = pmp4sdq
      elseif (meth(:3).eq.'mp4') then
         max = 4
         mutessw(4) = pmp4
         mutessw(3) = pmp4sdq
      endif

      mutessw(2) = pmp2
      mutessw(1) = phf
c
c  Make all calls to electronic structure program
c
      do 55 i=2, 1, -1
         call progghk(1, prognme,esmlist(mutessw(i)), bas2, geom, 
     *             optl, mutes(i,2), mutesgr(i,2,:), ierr,'null')
  55  continue
      do 52 i=max, 1, -1
         call progghk(1, prognme,esmlist(mutessw(i)), bas1, geom, 
     *             optl, mutes(i,1), mutesgr(i,1,:), ierr,'null')
  52  continue
c
c  Calculate the MCCM-UT energy with calmut using the energies gathered
c    in mutes and the input coefficients.  Then set the position in the
c    mcener for the non-default MCCM-UT calculation equal to that energy.
c
      call calmut( mcener(pmut), mutinp%coef(1:7), mutes, max )
      mcener(pmut) = mcener(pmut) + eso + ecc + erel
      do 60 j=1, 3*geom%natoms   
         call calmut(mcgrad(pmut,j), mutinp%coef(1:7),
     *            mutesgr(:,:,j), max)
  60  continue

      call mutdisp(mutessw,max,mutinp%bas1,mutinp%bas2,mutes,
     *               mutesgr, blnkhess, geom%natoms, tgrad)

      return
      end
c
c******************************************************************************
c MNMGHK
c******************************************************************************
c
      subroutine mnmghk(prognme,geom,mnminp,optl)
c
c     Subroutine mnmghk
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To carry out an MCCM-NM calculation with non-standard
c        bases (non-standard methods currently not supported).  Makes all
c        electronic structure program calls and parses electronic
c        information to pass on to calmnm.  Energy; Gradient
c
c     Called by:  mcghk, optghk
c     Calls:  progghk, calmnm, mnmdisp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mcinf
      use files, only : outfile
      use param
      use energy, only : mcener, eso, ecc, erel
      use gradient, only : mcgrad
      implicit none

      character*10  prognme
      type (cartgeom) ::  geom
      type (mcinf)    ::  mnminp
      integer  ierr, max, i, j, k, mnmessw(5)
      double precision  mnmes(5,3)
      double precision  mnmesgr(5,3,3*geom%natoms)
      character*20  meth, bas1, bas2, bas3
      character*80  optl(5)
      double precision blnkhess(3*geom%natoms)

      meth = mnminp%meth
      bas1 = mnminp%bas1
      bas2 = mnminp%bas2
      bas3 = mnminp%bas3
c
c  Initialize mnmes(5,3) to 0.0000d0
c
      do 20 i=1, 5
         do 40 j=1, 3
            mnmes(i,j) = 0.0000d0
            do 50 k=1, 3*geom%natoms
               mnmesgr(i,j,k) = 0.0000d0
  50        continue
  40     continue
  20  continue
c
c  Set max equal to the number of e.s. levels in the series.
c  Goto appropriate place in lines below to gather the necessary energies
c    from the electronic structure program.
c
      if (meth(:7).eq.'ccsd(t)') then
         max = 4
         mnmessw(4) = pccsdt
         mnmessw(3) = pccsd
      endif

      mnmessw(2) = pmp2
      mnmessw(1) = phf

      do 55 i=2, 1, -1
         call progghk(1, prognme,esmlist(mnmessw(i)), bas3, geom, 
     *           optl, mnmes(i,2), mnmesgr(i,2,:), ierr,'null')
  55  continue
      do 52 i=max, 1, -1
         call progghk(1, prognme,esmlist(mnmessw(i)), bas1, geom, 
     *             optl, mnmes(i,1), mnmesgr(i,1,:),ierr,'null')
  52  continue

      call progghk(1, prognme,esmlist(mnmessw(1)), bas2, geom, 
     *           optl, mnmes(1,3), mnmesgr(1,3,:), ierr,'null')

c
c  Calculate the MCCM-NM energy with calmnm using the energies gathered
c    in mnmes and the input coefficients.  Then set the position in the
c    mcener for the non-default MCCM-NM calculation equal to that energy.
c
      call calmnm( mcener(pmnm), mnminp%coef(1:7), mnmes, max )
      mcener(pmnm) = mcener(pmnm) + eso + ecc + erel
      do 60 j=1, 3*geom%natoms
         call calmnm(mcgrad(pmnm,j), mnminp%coef(1:7),
     *            mnmesgr(:,:,j), max)
  60  continue

      call mnmdisp(mnmessw,max,mnminp%bas1,mnminp%bas2,
     *               mnminp%bas3,mnmes,mnmesgr,blnkhess,
     *               geom%natoms,tgrad)

      return
      end
c
c******************************************************************************
c MCSGHK
c******************************************************************************
c
      subroutine mcsghk(prognme,geom,mcsinp,optl)
c
c     Subroutine mcsghk
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To carry out an MCSAC calculation with non-standard
c        bases (non-standard methods currently not supported).  Makes all
c        electronic structure program calls and parses electronic
c        information to pass on to calmcs.  Energy; Gradient
c
c     Called by:  mcghk, optghk
c     Calls:  progghk, calmcs, mcsdisp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mcinf
      use param
      use files, only : outfile
      use energy, only : mcener, eso, ecc, erel
      use gradient, only : mcgrad 
      implicit none

      character*10  prognme
      type (cartgeom) ::  geom
      type (mcinf)    ::  mcsinp
      integer  ierr, max, i, j, mcsessw(5)
      double precision  mcses(5), mcsesgr(5,3*geom%natoms)
      character*20  meth, bas1
      character*80  optl(5)
      double precision blnkhess(3*geom%natoms)

      meth = mcsinp%meth
      bas1 = mcsinp%bas1
c
c  Initialize mcses(5) to 0.0000d0
c
      do 20 i=1, 5
         mcses(i) = 0.0000d0
         do 30 j=1, 3*geom%natoms
            mcsesgr(i,j) = 0.0000d0
  30     continue
  20  continue
c
c  Set max equal to the number of e.s. levels in the series.
c  Set switch to appropriate calculations.
c
      if (meth(:7).eq.'ccsd(t)') then
         max = 4
         mcsessw(4) = pccsdt
         mcsessw(3) = pccsd
      elseif (meth(:4).eq.'ccsd') then
         max = 3
         mcsessw(3) = pccsd
      elseif (meth(:6).eq.'mp4sdq') then
         max = 3
         mcsessw(3) = pmp4sdq
      elseif (meth(:3).eq.'mp4') then
         max = 4
         mcsessw(4) = pmp4
         mcsessw(3) = pmp4sdq
      endif

      mcsessw(2) = pmp2
      mcsessw(1) = phf
c
c  Make all calls to electronic structure program
c
      do 50 i=max, 1, -1
         call progghk(1, prognme,esmlist(mcsessw(i)), bas1, geom,          
     *               optl, mcses(i), mcsesgr(i,:), ierr, 'null')
  50  continue

c
c  Calculate the MCSAC energy and gradient with calmcs using the
c    info gathered in mcses and the input coefficients.
c
      call calmcs( mcener(pmcs), mcsinp%coef(1:4), mcses, max )
      mcener(pmcs) = mcener(pmcs) + eso + ecc + erel
      do 60 j=1, 3*geom%natoms
         call calmcs( mcgrad(pmcs,j), mcsinp%coef(1:4),
     *            mcsesgr(:,j), max)
  60  continue

      call mcsdisp(mcsessw,max,mcsinp%bas1,mcses,mcsesgr,
     *               blnkhess,geom%natoms,tgrad)

      return
      end
c
c******************************************************************************
c IBGHK
c******************************************************************************
c
      subroutine ibghk(prognme, geom, ibinp, optl)
c
c     Subroutine ibghk
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To carry out an IB calculation with non-standard
c        bases or methods.  Makes all electronic structure program calls
c        and parses electronic information to pass on to calib.  Energy;
c        Gradient
c
c     Called by:  mcghk, optghk
c     Calls:  progghk, calib, ibdisp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mcinf
      use files, only : outfile
      use param
      use energy, only : mcener, eso, ecc, erel
      use gradient, only : mcgrad
      implicit none

      character*10  prognme
      type (cartgeom) ::  geom
      type (mcinf)    ::  ibinp
      integer  ierr, max, i, j, k
      double precision  ibes(2,2), ibesgr(2,2,3*geom%natoms)
      character*20  meth, bas1, bas2
      character*80  optl(5)
      double precision blnkhess(3*geom%natoms)

      meth = ibinp%meth
      bas1 = ibinp%bas1
      bas2 = ibinp%bas2
c
c  Initialize ibes(2,2) to 0.0000d0
c
      do 20 i=1, 2
         do 40 j=1, 2
            ibes(i,j) = 0.0000d0
            do 50 k=1, 3*geom%natoms
               ibesgr(i,j,k) = 0.0000d0
  50        continue
  40     continue
  20  continue
c
c  Make calls to the electronic structure program
c
      call progghk(1,prognme,meth,bas2,geom,optl,ibes(2,2),
     *                  ibesgr(2,2,:), ierr,'null')
      call progghk(1,prognme,esmlist(phf), bas2, geom, optl, 
     *                ibes(1,2), ibesgr(1,2,:), ierr,'null')
      call progghk(1,prognme,meth,bas1,geom,optl,ibes(2,1),
     *                  ibesgr(2,1,:), ierr,'null')
      call progghk(1,prognme,esmlist(phf), bas1, geom, optl,
     *                ibes(1,1), ibesgr(1,1,:), ierr,'null')
c
c  Calculate the IB values with calib using the info gathered
c    in ibes and the input coefficients. 
c
      call calib( mcener(pib), ibinp%coef(1), ibinp%coef(2), ibes )
      mcener(pib) = mcener(pib) + eso + ecc + erel
      do 60 j=1, 3*geom%natoms
         call calib(mcgrad(pib,j), ibinp%coef(1), ibinp%coef(2),
     *            ibesgr(:,:,j) )
  60  continue

      call ibdisp(ibinp%meth,ibinp%bas1,ibinp%bas2,ibes,
     *              ibesgr,blnkhess,geom%natoms,tgrad)

      return
      end
c
c******************************************************************************
c SACGHK
c******************************************************************************
c
      subroutine sacghk(prognme, geom, sacinp, optl)
c
c     Subroutine sacghk
c
c     Created:  July 8, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To carry out an SAC calculation with non-standard
c        bases or methods.  Makes all electronic structure program calls
c        and parses electronic information to pass on to calsac.  Energy;
c        Gradient
c
c     Called by:  mcghk, optghk
c     Calls:  progghk, calsac, sacdisp
c
c     Variables defined here:
c
      use caltyp, only : tgrad
      use input, only : cartgeom, mcinf
      use files, only : outfile
      use param
      use energy, only : mcener, eso, ecc, erel
      use gradient, only : mcgrad
      implicit none

      character*10  prognme
      type (cartgeom) ::  geom
      type (mcinf)    ::  sacinp
      integer  ierr, max, i, j
      double precision  saces(2), sacesgr(2,3*geom%natoms)
      character*20  meth, bas1
      character*80  optl(5)
      double precision blnkhess(3*geom%natoms)

      meth = sacinp%meth
      bas1 = sacinp%bas1
c
c  Initialize saces(2) to 0.0000d0
c
      do 20 i=1, 2
         saces(i) = 0.0000d0
         do 30 j=1, 3*geom%natoms
            sacesgr(i,j) = 0.0000d0
  30     continue
  20  continue
c
c  Make all calls to the electronic structure program
c
      call progghk(1,prognme,meth,bas1,geom,optl,saces(2),
     *                   sacesgr(2,:),ierr,'null')
      call progghk(1,prognme,esmlist(phf), bas1, geom, optl,
     *          saces(1), sacesgr(1,:), ierr,'null')
c
c  Calculate the SAC value with calsac using the info gathered
c    in saces and the input coefficients.
c
      call calsac( mcener(psac), sacinp%coef(1), saces )
      mcener(psac) = mcener(psac) + eso + ecc + erel
      do 60 j=1, 3*geom%natoms
         call calsac(mcgrad(psac,j), sacinp%coef(1), sacesgr(:,j) )
  60  continue

      call sacdisp(sacinp%meth,sacinp%bas1,saces,sacesgr,
     *               blnkhess,geom%natoms,tgrad)

      return
      end
c
c******************************************************************************
c  IMOHCGHK
c******************************************************************************
c
      subroutine imohcghk(hlprognme, llprognme, geom, inp, ierr)
c
c     Subroutine imohcghk
c
c     Created:  June 1998 by B.J. Lynch
c     Revised:  August 2, 1999 by J.M. Rodgers
c               Used Ben's structure - just converted to standard Multilevel
c                  subroutines and modules.
c     Purpose:  To determine the IMOHC energy and gradient
c
c     Called by:  mlghook, optghk
c     Calls:  progghk, hnrg, hgrad, imohcdisp
c  
c     Variables defined here:  none.
c
      use caltyp, only : tgrad
      use input, only : cartgeom, imoinf
      use files, only : outfile
      use energy, only : imohcener, imohces
      use gradient, only : imohcgrad, imohcesgr
      implicit none
c
      character*10 hlprognme, llprognme
      type (cartgeom) :: geom, lsgeom, ssgeom
      type (imoinf)  :: inp
      integer ierr, i, j
      double precision  r, theta, phi
      double precision  rgrad(6), agrad(9), torgrad(12), dumh(12,12)
c
c  Assign the appropriate geometries to lsgeom and ssgeom
c
      call hcgeom(geom,lsgeom,ssgeom, inp%lsatm, inp%lsnatm,
     *       inp%ssatm, inp%ssnatm)
c
c  High level calculation on the small system
c
      call progghk(1,hlprognme, inp%hlmeth, inp%hlbas, ssgeom,
     * inp%hloptl,imohces(1),imohcesgr(1,:3*inp%ssnatm),ierr,'null')
c
c  Low level calculation on the large system
c
      call progghk(1,llprognme, inp%llmeth, inp%llbas, lsgeom,
     * inp%lloptl, imohces(2), imohcesgr(2,:3*inp%lsnatm), ierr,'null')
c
c  Low level calculation on the small system
c
      call progghk(1,llprognme, inp%llmeth, inp%llbas, ssgeom,
     * inp%lloptl, imohces(3), imohcesgr(3,:3*inp%ssnatm), ierr,'null')
c
c  Calculate the IMOMO energy and gradient
c
      imohcener = imohces(1) + imohces(2) - imohces(3)

c  add low lev./large sys. gradient

      do 42 i=1, 3*(geom%natoms)
	imohcgrad(i) = 0.0d0
  42  continue

      do 60 i=1, inp%lsnatm
         do 70 j=1, 3
            imohcgrad((inp%lsatm(i)-1)*3+j) = imohcesgr(2,(i-1)*3+j)
  70     continue
  60  continue

      do 110 i=1, inp%ssnatm
         do 120 j=1, 3
            imohcgrad((inp%ssatm(i)-1)*3+j) =
     *              imohcgrad((inp%ssatm(i)-1)*3+j) +
     *              imohcesgr(1,(i-1)*3+j) - imohcesgr(3,(i-1)*3+j)
 120     continue
 110  continue

c
c  Call subroutines hnrg and hgrad to calculate the harmonic contributions to
c    the total energy and gradient.  Imohcener and imohcgrad altered within.
c
      call hnrg( geom, inp%bond, inp%angle, inp%tors, 
     *             r, theta, phi)
      call hgrad( geom, inp%bond, inp%angle, inp%tors,
     *             rgrad, agrad, torgrad )
c

c  Display results
c
      call imohcdisp(r,theta,phi,rgrad,agrad,torgrad,dumh(:6,:6), 
     *   dumh(:9,:9),dumh(:12,:12),inp%ssnatm, 
     *   inp%lsnatm,tgrad)

      return
      end
c
c******************************************************************************
c  HGRAD
c******************************************************************************
c
      subroutine hgrad( geom, bond, angle, tors, rgrad, agrad, tgrad )
c
c     Subroutine hgrad
c
c     Created:  June 1998 by B.J. Lynch
c     Revised:  August 2, 1999 by J.M. Rodgers
c               Used Ben's structure - just converted to standard Multilevel
c                  subroutines and modules.
c     Purpose:  To add on the harmonic correction to imohcgrad
c
c     Called by:  imohcghk, imohchhk
c     Calls:  rdx, adx, adx2, tdx, tdx2
c
c     Variables defined here:  none.
c
      use input, only : cartgeom, hcinf
      use files, only : outfile
      use gradient, only : imohcgrad
      implicit none

      type (cartgeom) :: geom
      type (hcinf)    :: bond, angle, tors
      integer         :: i
      double precision :: x1,x2,y1,y2,z1,z2,x3,x4,y3,y4,z3,z4,ddx,dy,
     *     rgrad(6),agrad(9),tgrad(12)
c
c  Bond contribution - use symmetry
c 
        x1 = geom%aucoord(bond%atoms(1)*3-2)
        y1 = geom%aucoord(bond%atoms(1)*3-1)
        z1 = geom%aucoord(bond%atoms(1)*3)
        x2 = geom%aucoord(bond%atoms(2)*3-2)
        y2 = geom%aucoord(bond%atoms(2)*3-1)
        z2 = geom%aucoord(bond%atoms(2)*3)

        CALL rdx(x1,x2,y1,y2,z1,z2,bond%eqval,bond%k,rgrad(1))
        CALL rdx(y1,y2,x1,x2,z1,z2,bond%eqval,bond%k,rgrad(2))
        CALL rdx(z1,z2,y1,y2,x1,x2,bond%eqval,bond%k,rgrad(3))
        rgrad(4) = -rgrad(1)
        rgrad(5) = -rgrad(2)
        rgrad(6) = -rgrad(3)
c
c  Angle contribution
c
        x1 = geom%aucoord(angle%atoms(1)*3-2)
        y1 = geom%aucoord(angle%atoms(1)*3-1)
        z1 = geom%aucoord(angle%atoms(1)*3)
        x2 = geom%aucoord(angle%atoms(2)*3-2)
        y2 = geom%aucoord(angle%atoms(2)*3-1)
        z2 = geom%aucoord(angle%atoms(2)*3)
        x3 = geom%aucoord(angle%atoms(3)*3-2)
        y3 = geom%aucoord(angle%atoms(3)*3-1)
        z3 = geom%aucoord(angle%atoms(3)*3)

        CALL adx(x1,x2,x3,y1,y2,y3,z1,z2,z3,angle%eqval,
     *         angle%k,agrad(1))
        CALL adx(y1,y2,y3,x1,x2,x3,z1,z2,z3,angle%eqval,
     *         angle%k,agrad(2))
        CALL adx(z1,z2,z3,y1,y2,y3,x1,x2,x3,angle%eqval,
     *         angle%k,agrad(3))
        CALL adx2(x1,x2,x3,y1,y2,y3,z1,z2,z3,angle%eqval,
     *         angle%k,agrad(4))
        CALL adx2(y1,y2,y3,z1,z2,z3,x1,x2,x3,angle%eqval,
     *         angle%k,agrad(5))
        CALL adx2(z1,z2,z3,y1,y2,y3,x1,x2,x3,angle%eqval,
     *         angle%k,agrad(6))
        CALL adx(x3,x2,x1,y3,y2,y1,z3,z2,z1,angle%eqval,
     *         angle%k,agrad(7))
        CALL adx(y3,y2,y1,x3,x2,x1,z3,z2,z1,angle%eqval,
     *         angle%k,agrad(8))
        CALL adx(z3,z2,z1,y3,y2,y1,x3,x2,x1,angle%eqval,
     *         angle%k,agrad(9))
c
c  Torsion contribution
c
        x1 = geom%aucoord(tors%atoms(1)*3-2)
        y1 = geom%aucoord(tors%atoms(1)*3-1)
        z1 = geom%aucoord(tors%atoms(1)*3)
        x2 = geom%aucoord(tors%atoms(2)*3-2)
        y2 = geom%aucoord(tors%atoms(2)*3-1)
        z2 = geom%aucoord(tors%atoms(2)*3)
        x3 = geom%aucoord(tors%atoms(3)*3-2)
        y3 = geom%aucoord(tors%atoms(3)*3-1)
        z3 = geom%aucoord(tors%atoms(3)*3)
        x4 = geom%aucoord(tors%atoms(4)*3-2)
        y4 = geom%aucoord(tors%atoms(4)*3-1)
        z4 = geom%aucoord(tors%atoms(4)*3)

        CALL tdx(x1,x2,x3,x4,y1,y2,y3,y4,z1,z2,z3,z4,
     *     tors%eqval,tors%k,tgrad(1))
        CALL tdx(y1,y2,y3,y4,x1,x2,x3,x4,z1,z2,z3,z4,
     *     tors%eqval,tors%k,tgrad(2))
        CALL tdx(z1,z2,z3,z4,y1,y2,y3,y4,x1,x2,x3,x4,
     *     tors%eqval,tors%k,tgrad(3))
        CALL tdx2(x1,x2,x3,x4,y1,y2,y3,y4,z1,z2,z3,z4,
     *     tors%eqval,tors%k,tgrad(4))
        CALL tdx2(y1,y2,y3,y4,x1,x2,x3,x4,z1,z2,z3,z4,
     *     tors%eqval,tors%k,tgrad(5))
        CALL tdx2(z1,z2,z3,z4,y1,y2,y3,y4,x1,x2,x3,x4,
     *     tors%eqval,tors%k,tgrad(6))
        CALL tdx2(x4,x3,x2,x1,y4,y3,y2,y1,z4,z3,z2,z1,
     *     tors%eqval,tors%k,tgrad(7))
        CALL tdx2(y4,y3,y2,y1,x4,x3,x2,x1,z4,z3,z2,z1,
     *     tors%eqval,tors%k,tgrad(8))
        CALL tdx2(z4,z3,z2,z1,y4,y3,y2,y1,x4,x3,x2,x1,
     *     tors%eqval,tors%k,tgrad(9))
        CALL tdx(x4,x3,x2,x1,y4,y3,y2,y1,z4,z3,z2,z1,
     *     tors%eqval,tors%k,tgrad(10))
        CALL tdx(y4,y3,y2,y1,x4,x3,x2,x1,z4,z3,z2,z1,
     *     tors%eqval,tors%k,tgrad(11))
        CALL tdx(z4,z3,z2,z1,y4,y3,y2,y1,x4,x3,x2,x1,
     *     tors%eqval,tors%k,tgrad(12))
c
c  Add rgrad, agrad, and tgrad to imohcgrad
c
      do 10 i=1, 2
         imohcgrad(bond%atoms(i)*3-2) =
     *      imohcgrad(bond%atoms(i)*3-2) + rgrad(i*3-2)
         imohcgrad(bond%atoms(i)*3-1) =
     *      imohcgrad(bond%atoms(i)*3-1) + rgrad(i*3-1)
         imohcgrad(bond%atoms(i)*3) =
     *      imohcgrad(bond%atoms(i)*3) + rgrad(i*3)
  10  continue

      do 20 i=1, 3
         imohcgrad(angle%atoms(i)*3-2) =
     *      imohcgrad(angle%atoms(i)*3-2) + agrad(i*3-2)
         imohcgrad(angle%atoms(i)*3-1) =
     *      imohcgrad(angle%atoms(i)*3-1) + agrad(i*3-1)
         imohcgrad(angle%atoms(i)*3) =
     *      imohcgrad(angle%atoms(i)*3) + agrad(i*3)
  20  continue

      do 30 i=1, 4
         imohcgrad(tors%atoms(i)*3-2) =
     *      imohcgrad(tors%atoms(i)*3-2) + tgrad(i*3-2)
         imohcgrad(tors%atoms(i)*3-1) =
     *      imohcgrad(tors%atoms(i)*3-1) + tgrad(i*3-1)
         imohcgrad(tors%atoms(i)*3) =
     *      imohcgrad(tors%atoms(i)*3) + tgrad(i*3)
  30  continue

      return
      end
c
c******************************************************************************
c  RDX
c******************************************************************************
c
      subroutine rdx(x1,x2,y1,y2,z1,z2,r0,k1,ddx)
c
c     Subroutine rdx
c
c     Created:  June 1998 by B.J. Lynch
c     Revised:  August 2, 1999 by J.M. Rodgers
c     Purpose:  To determine the change to the gradients due to the harmonic
c        approximation on the bond length based on the coordinates, the
c        equilibrium bond length, and the force constant
c
c     Called by:  hgrad
c     Calls:
c  
c     Variables defined here:
c

      implicit none

      double precision  x1,x2,y1,y2,z1,z2,r0,k1,ddx

      ddx=(k1*(x1-x2)*(-r0+Sqrt((x1-x2)**2+(y1-y2)**2+(z1-
     *   z2)**2)))/Sqrt((x1-x2)**2+(y1-y2)**2+(z1-z2)**2)

      return
      end
c
c******************************************************************************
c  ADX   
c******************************************************************************
c        
      subroutine adx(x1,x2,x3,y1,y2,y3,z1,z2,z3,thetanot,k2,ddx)
c        
c     Subroutine adx
c 
c     Created:  June 1998 by B.J. Lynch
c     Revised:  August 2, 1999 by J.M. Rodgers
c     Purpose:  To determine the change to the gradients due to the harmonic
c        approximation on the bond angle based on the coordinates, the
c        equilibrium bond angle, and the force constant
c    
c     Called by:  hgrad
c     Calls:
c 
c     Variables defined here:       
c     
      implicit none

      double precision  x1,x2,x3,y1,y2,y3,z1,z2,z3,thetanot,k2,ddx

      ddx =   -((k2*((-x2 + x3)/
     *         (Sqrt((x1 - x2)**2 + (y1 - y2)**2 + (z1 - z2)**2)*
     *       Sqrt((-x2 + x3)**2 + (-y2 + y3)**2 + (-z2 + z3)**2)) - 
     *   ((x1-x2)*((x1-x2)*(-x2+x3)+(y1 - y2)*(-y2+y3)+(z1-z2)*(-z2+ 
     *   z3)))/
     *         (((x1 - x2)**2 + (y1 - y2)**2 + (z1 - z2)**2)**1.5*
     *           Sqrt((-x2 + x3)**2 + (-y2 + y3)**2 + (-z2 + z3)**2)))*
     *      (-thetanot+ACos(((x1-x2)*(-x2+x3)+(y1-y2)*(-y2+y3)+ 
     *            (z1 - z2)*(-z2 + z3))/
     *          (Sqrt((x1 - x2)**2 + (y1 - y2)**2 + (z1 - z2)**2)*
     *            Sqrt((-x2 + x3)**2+(-y2+y3)**2 + (-z2 + z3)**2)))))/
     *  Sqrt(1-((x1-x2)*(-x2+x3)+(y1-y2)*(-y2+y3)+(z1-z2)*(-z2+z3))**2/
     *       (((x1 - x2)**2 + (y1 - y2)**2 + (z1 - z2)**2)*
     *         ((-x2 + x3)**2 + (-y2 + y3)**2 + (-z2 + z3)**2))))

      return
      end
c
c******************************************************************************
c  ADX2
c******************************************************************************
c
      subroutine adx2(x1,x2,x3,y1,y2,y3,z1,z2,z3,thetanot,k2,ddx)
c
c     Subroutine adx2
c
c     Created:  June 1998 by B.J. Lynch
c     Revised:  August 2, 1999 by J.M. Rodgers
c     Purpose:  To determine the change to the gradients due to the harmonic
c        approximation on the bond angle based on the coordinates, the
c        equilibrium bond angle, and the force constant
c
c     Called by:  hgrad
c     Calls:
c
c     Variables defined here:
c
      implicit none

      double precision  x1,x2,x3,y1,y2,y3,z1,z2,z3,thetanot,k2,ddx

      ddx=-((k2*(((-x2+x3)*((x1-x2)*(-x2+x3)+(y1-y2)*(-y2 + y3) + 
     *             (z1 - z2)*(-z2 + z3)))/
     *         (Sqrt((x1 - x2)**2 + (y1 - y2)**2 + (z1 - z2)**2)*
     *           ((-x2 + x3)**2 + (-y2 + y3)**2 +(-z2+z3)**2)**1.5) + 
     *        (-x1 + 2*x2 - x3)/
     *         (Sqrt((x1 - x2)**2 + (y1 - y2)**2 + (z1 - z2)**2)*
     *           Sqrt((-x2+x3)**2+(-y2+y3)**2+(-z2+z3)**2)) + 
     *        ((x1 - x2)*((x1-x2)*(-x2 +x3)+(y1-y2)*(-y2 + y3) + 
     *     (z1 - z2)*(-z2 + z3)))/
     *         (((x1 - x2)**2 + (y1 - y2)**2 + (z1 - z2)**2)**1.5*
     *           Sqrt((-x2+x3)**2+(-y2+y3)**2+(-z2+z3)**2)))*
     *      (-thetanot + ACos(((x1-x2)*(-x2+x3)+(y1-y2)*(-y2 + y3) + 
     *            (z1 - z2)*(-z2 + z3))/
     *          (Sqrt((x1 - x2)**2 + (y1 - y2)**2 + (z1 - z2)**2)*
     *            Sqrt((-x2 + x3)**2+(-y2+y3)**2+(-z2+z3)**2)))))/
     *    Sqrt(1-((x1-x2)*(-x2+x3)+(y1-y2)*(-y2+y3)+(z1-z2)*(-z2+
     *    z3))**2/
     *       (((x1 - x2)**2 + (y1 - y2)**2 + (z1 - z2)**2)*
     *         ((-x2 + x3)**2 + (-y2 + y3)**2 + (-z2 + z3)**2))))

      return
      end
c
c******************************************************************************
c  TDX
c******************************************************************************
c
      subroutine tdx(x1,x2,x3,x4,y1,y2,y3,y4,z1,z2,z3,z4,
     *     phinot,k3,ddx)
c
c     Subroutine tdx
c
c     Created:  June 1998 by B.J. Lynch
c     Revised:  August 2, 1999 by J.M. Rodgers
c     Purpose:  To determine the change to the gradients due to the harmonic
c        approximation on the bond torsion based on the coordinates, the
c        equilibrium bond torsion, and the force constant
c
c     Called by:  hgrad
c     Calls:
c
c     Variables defined here:
c
      implicit none

      double precision  x1,x2,x3,x4,y1,y2,y3,y4,z1,z2,z3,z4,
     *    phinot,k3,ddx   

      ddx =  -((k3*(((-y2+y3)*(-((x2-x4)*(-y2+y3))+(-x2+
     *  x3)*(y2-y4))+
     *  (z2-z3)*((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4)))/
     *  (Sqrt((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))**2+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))**2+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))**2)*
     *  Sqrt((-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))**2+
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))**2+
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))**2))-
     *  ((2*(-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))*(-y2+y3)+
     *  2*((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))*(z2-z3))*
     *  ((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))*
     *  (-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))*
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))*
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))))/
     *  (2.*((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))**2+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))**2+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))**2)**1.5*
     *  Sqrt((-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))**2+
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))**2+
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))**2)))*
     *  (-phinot+ACos(((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))*
     *  (-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))*
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))*
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4)))/
     *  (Sqrt((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))**2+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))**2+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))**2)*
     *  Sqrt((-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))**2+
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))**2+
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))**2)))))/
     *  Sqrt(1-((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))*
     *  (-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))*((x2-x4)*(-z2
     *  +z3)-(-x2+x3)*(z2-z4))+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))*
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4)))**2/
     *  (((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))**2+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))**2+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))**2)*
     *  ((-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))**2+
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))**2+ 
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))**2)))) 

      return
      end
c
c******************************************************************************
c  TDX2
c******************************************************************************
c
      subroutine tdx2(x1,x2,x3,x4,y1,y2,y3,y4,z1,z2,z3,z4,
     *     phinot,k3,ddx)
c
c     Subroutine tdx2
c    
c     Created:  June 1998 by B.J. Lynch
c     Revised:  August 2, 1999 by J.M. Rodgers
c     Purpose:  To determine the change to the gradients due to the harmonic
c        approximation on the bond torsion based on the coordinates, the
c        equilibrium bond torsion, and the force constant
c    
c     Called by:  hgrad
c     Calls:
c    
c     Variables defined here:
c    
      implicit none
     
      double precision  x1,x2,x3,x4,y1,y2,y3,y4,z1,z2,z3,z4,
     *    phinot,k3,ddx

      ddx=-((k3*(-((2*(-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3
     *  ))*(y1-y3)+
     *  2*((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))*(-z1+z3))*
     *  ((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))*
     *  (-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))*
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))*
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))))/
     *  (2.*((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))**2+ 
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))**2+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))**2)**1.5*
     *  Sqrt((-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))**2+
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))**2+
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))**2))+
     *  ((y1-y3)*(-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))+
     *  (-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))*(-y3+y4)+
     *  (-z1+z3)*((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))*(z3-z4))/
     *  (Sqrt((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))**2+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))**2+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))**2)*
     *  Sqrt((-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))**2+
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))**2+
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))**2))-
     *  (((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))*
     *  (-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))*   
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))*
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4)))*
     *  (2*(-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))*(-y3+y4)+
     *  2*((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))*(z3-z4)))/
     *  (2.*Sqrt((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))**2+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))**2+ 
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))**2)*
     *  ((-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))**2+
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))**2+
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))**2)**1.5))*
     *  (-phinot+ACos(((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))*
     *  (-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))*
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))+   
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))*
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4)))/
     *  (Sqrt((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))**2+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))**2+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))**2)*  
     *  Sqrt((-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))**2+ 
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))**2+
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))**2)))))/
     *  Sqrt(1-((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))*
     *  (-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))*((x2-x4)*(-z2
     *  +z3)-(-x2+x3)*(z2-z4))+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))*  
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4)))**2/
     *  (((-((x1-x3)*(-y1+y2))+(-x1+x2)*(y1-y3))**2+
     *  ((x1-x3)*(-z1+z2)-(-x1+x2)*(z1-z3))**2+
     *  (-((y1-y3)*(-z1+z2))+(-y1+y2)*(z1-z3))**2)*
     *  ((-((x2-x4)*(-y2+y3))+(-x2+x3)*(y2-y4))**2+
     *  ((x2-x4)*(-z2+z3)-(-x2+x3)*(z2-z4))**2+
     *  (-((y2-y4)*(-z2+z3))+(-y2+y3)*(z2-z4))**2))))   

      return
      end
