
c******************************************************************************
c  MLEHOOK
c******************************************************************************
c
      subroutine mlehook(progrms, geom, mcinp, mgswit, hfmoinp, mcoptl,
     *   sacinp, mcsinp, ibinp, mcoinp, mnminp, mutinp, g2inp, mg2inp,
     *   g3inp, mg3inp, mqcinp, mcomp2inp, mccoinp, g3sxmp3inp,          0712BL02 
     *   mc3bbinp, mc3mpwinp, 
     *   limohc, imohcinp, ltest, tmeth, tbas,  toptl, ierr) 
c  
c     Subroutine mlehook
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:  January 10, 2000 by P. L. Fast
c     Purpose:  To call the appropriate energy subhook
c
c     Called by:  main
c     Calls:  hfmoehk, mcehk, g2ehk, g3ehk, mg2ehk, mg3ehk, mqcehk, mcomp2ehk,imohcehk
c
c     Variables defined here:  lmg2, lmg3
c
      use input, only : cartgeom, mctype, mgtype, hfmoinf, mcinf,
     *                   ginf, mginf, imoinf, proglist
      use files, only : outfile
      use optimize, only : ener
      use caltyp, only : tener
      use energy, only : eso, ecc, erel

      implicit none

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

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

c
         call testdisp( geom%natoms, tener )
      endif
c
c  IMOHC
c
      if (limohc .eq. 1)  then
         call imohcehk(progrms%imohlprog, progrms%imollprog, geom, 
     *            imohcinp, ierr)
      endif
c     
c  HFMO
c
      if (hfmoinp%lhfmo .eq. 1) then
         call hfmoehk(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 mcehk(progrms%mcprog, geom, mcinp, mcoptl, sacinp,
     *                mcsinp, ibinp, mcoinp, mnminp, mutinp, ierr)
         endif
      else
         if (mcinp%lmccmco.eq.1) then
            call mcoehk(progrms%mcprog,geom,mcoinp,mcoptl)
         endif
         if (mcinp%lmccmnm.eq.1) then
            call mnmehk(progrms%mcprog,geom,mnminp,mcoptl)
         endif
         if (mcinp%lmccmut.eq.1) then
            call mutehk(progrms%mcprog,geom,mutinp,mcoptl)
         endif
         if (mcinp%lib.eq.1) then
            call ibehk(progrms%mcprog,geom,ibinp,mcoptl)
         endif
         if (mcinp%lmcsac.eq.1) then
            call mcsehk(progrms%mcprog,geom,mcsinp,mcoptl)
         endif
         if (mcinp%lsac.eq.1) then
            call sacehk(progrms%mcprog,geom,sacinp,mcoptl)
         endif
      endif         
c
c  MCG2 (Always do for energies if G2 chosen)
c
      if (mgswit%lmcg2.eq.1 .or. mgswit%lg2.eq.1) then
         call mg2ehk(progrms%g2prog,geom,mg2inp,ierr)
         lmg2 = 1
      endif
c
c  G2
c
      if (mgswit%lg2.eq.1) then
         call g2ehk(progrms%g2prog,geom,lmg2,g2inp,ierr)
      endif
c
c  MCG3
c
      if (mgswit%lmcg3.eq.1) then
         call mg3ehk(progrms%g3prog,geom,mg3inp,ierr)
         lmg3 = 1
      endif
c
c G3SX(MP3)
c
      if (mgswit%lg3sxmp3.eq.1) then
       call g3sxmp3ehk(progrms%g3prog,geom,lmg3,g3sxmp3inp,ierr)
      endif

c
cMC3BB
c
      if (mgswit%lmc3bb.eq.1) then
         call mc3bbehk(progrms%g3prog,geom,lmg3,mc3bbinp,ierr)
      endif

c
cMC3MPW
c
      if (mgswit%lmc3mpw.eq.1) then
         call mc3mpwehk(progrms%g3prog,geom,lmg3,mc3mpwinp,ierr)
      endif

c
c  MC-QCISD
c
      if (mgswit%lmqcisd.eq.1) then                                     0110PF00
         call mqcehk(progrms%g3prog,geom,lmg3,mqcinp,ierr)              0110PF00
      endif                                                             0110PF00

c
c  MCOMP2
c
      if (mgswit%lmcomp2.eq.1) then                                     0710PJ00
         call mcomp2ehk(progrms%g3prog,geom,lmg3,mcomp2inp,ierr)        0710PJ00
      endif                                                             0710PJ00

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

c
c  G3
c
      if (mgswit%lg3.eq.1) then
         call g3ehk(progrms%g3prog,geom,lmg3,g3inp,ierr)
      endif
      
      return
      end
c
c     
c******************************************************************************
c MCEHK
c******************************************************************************
c
      subroutine mcehk(prognme, geom, mcinp, mcoptl, sacinp,
     *                   mcsinp, ibinp, mcoinp, mnminp, mutinp, ierr)
c
c     Subroutine mcehk
c
c     Created:  June 23, 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 calculations.  Designed to enable the
c       calculation of all possible MC energies when standard MC
c       calculations have been requested.  If a non-standard calculation
c       occurs, that calc is passed off to an individual energy hook.
c
c     Called by:  mlehook  
c     Calls:  mcchk, mcomchk, mnmmchk, mutmchk, ibmchk, mcsmchk, sacmchk,
c             getemco, getemnm, getemut, geteib, getemcs, getesac,
c             mcdisp, setmcsw, esparse
c
      use caltyp, only : tener
      use input, only : cartgeom, mctype, mcinf
      use param
      use files
      use energy
      implicit none
c
      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, max
      integer mcmeth, coefsw, esmeth, basis, vers
      double precision coef(10)
      character*10  prognme
c
c  Initialize switches to 0 and energies to 0.0000d0
c
      do 20 i=1, numes
         do 40 j=1, numbas
            esswit(i,j) = 0
            esener(i,j) = 0.0000d0
  40     continue
  20  continue

      do 60 i=1, 5
         do 80 j=1,numcalc
            mcswit(i,j) = 0
            mcener(j) = 0.0000d0
  80     continue
  60  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 calculations are necessary if standard methods and bases
c    have been specified.  If non-standard choices are selected, flip a
c    slot in mcswit and then call another hook which does not attempt to
c    make all possible mc 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 mcomchk( mcoinp%meth, esswit, mcswit, ctr, ierr )
         else
            call setmcsw( mcswit, ctr, pmco, nodef, nstd, nstd )
            call mcoehk(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 mnmmchk( mnminp%meth, esswit, mcswit, ctr, ierr )
         else
            call setmcsw( mcswit, ctr, pmnm, nodef, nstd, nstd )
            call mnmehk(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 mutmchk( mutinp%meth, esswit, mcswit, ctr, ierr )
         else
            call setmcsw( mcswit, ctr, pmut, nodef, nstd, nstd )
            call mutehk(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 ibmchk(ibinp%meth, esswit,mcswit, ctr,ierr)
         else
            call setmcsw( mcswit, ctr, pib, nodef, nstd, nstd )
            call ibehk(prognme, geom, ibinp, mcoptl)
         endif
      endif
      if (mcinp%lmcsac .eq. 1) then
         if (mcsinp%stdm.eq.1 .and. mcsinp%stdb1.eq.1) then
            call mcsmchk(mcsinp%meth,mcsinp%bas1,esswit,mcswit,ctr,ierr)
         else
            call setmcsw( mcswit, ctr, pmcs, nodef, nstd, nstd )
            call mcsehk(prognme,geom,mcsinp,mcoptl)
         endif
      endif
      if (mcinp%lsac .eq. 1) then
         if (sacinp%stdm.eq.1 .and. sacinp%stdb1.eq.1) then
            call sacmchk(sacinp%meth,sacinp%bas1,esswit,mcswit,ctr,ierr)
         else
            call setmcsw( mcswit, ctr, psac, nodef, nstd, nstd )
            call sacehk(prognme, geom, sacinp, mcoptl)
         endif
      endif
c
c  From esswit, set all default MC calculations in mcswit.
c
      call mcchk( esswit, mcswit, ctr )
c
c  Make all electronic structure calls recorded in esswit with esparse.
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 energy calculations will already have been carried out
c    by the individual hooks.
c
      if (ctr .gt. 0) then
         call esparse( 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
               mcswit(5,i) = 0
               i = i+1
            else
               mcmeth = mcswit(1,i)
               coefsw = mcswit(2,i)
               esmeth = mcswit(3,i)  
               basis = mcswit(4,i)
c
               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)
               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)
               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)
               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)
               elseif (mcmeth .eq. pib) then
                  coef = ibinp%coef
                  mcswit(5,i) = 0
                  call geteib(i, coefsw, coef, esmeth)
              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)
               endif
c
c  Add on ESO and ECC
c
               mcener(i) = mcener(i) + eso + ecc + erel
               i = i+1
            endif
         enddo
      endif

      call mcdisp( prognme,esswit,mcswit,ctr,geom%natoms,tener)

      return 
      end
c
c
c******************************************************************************
c  MCOMCHK
c******************************************************************************
c
      subroutine mcomchk( mcometh, esswit, mcswit, ctr, ierr )
c
c     Subroutine mcomchk
c    
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for MCCM-CO are standard.
c       For solely energy calls (take into account all energies available 
c       in checkpoint files).
c
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:
c    
      use param
      use energy
      use files, only : outfile
      implicit none
      
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i, j
      character*20  mcometh
c
c  Always do following calculations if a standard MCCM-CO
c 
      esswit(phf,pdz) = 1
      esswit(phf,ptz) = 1
      esswit(pmp2,pdz) = 1
      esswit(pmp2,ptz) = 1
c
c  MCCM-CO METHOD = CCSD(T)
c
      if (mcometh(:7).eq.'ccsd(t)') then
         do 20 i=ptz, pdz
            esswit(pmp4sdq,i) = 1
            esswit(pmp4,i) = 1
            esswit(pccsd,i) = 1
            esswit(pccsdt,i) = 1
  20     continue
c
         call setmcsw( mcswit, ctr, pmco, nodef, pccsdt, na)
c  
c  MCCM-CO METHOD = CCSD
c
      elseif (mcometh(:4).eq.'ccsd') then
         do 40 i=ptz, pdz
            esswit(pmp4sdq,i) = 1
            esswit(pccsd,i) = 1
  40     continue
         call setmcsw( mcswit, ctr, pmco, nodef, pccsd, na )
c
c  MCCM-CO METHOD = MP4SDQ
c
      elseif (mcometh(:6).eq.'mp4sdq') then
         do 60 i=ptz, pdz
            esswit(pmp4sdq,i) = 1
  60     continue
         call setmcsw( mcswit, ctr, pmco, nodef, pmp4sdq, na)
c
c
c  MCCM-CO METHOD = MP4
c
      elseif (mcometh(:3).eq.'mp4') then
         do 100 i=ptz, pdz
            esswit(pmp4,i) = 1   
            esswit(pmp4sdq,i) = 1
 100     continue
         call setmcsw( mcswit, ctr, pmco, nodef, pmp4, na)
c
c  MCCM-CO METHOD = MP2  
c
      elseif (mcometh(:3).eq.'mp2') then
         call setmcsw(mcswit, ctr, pmco, nodef, pmp2, na)
c
      endif
c
      return
      end
c
c
c******************************************************************************
c MNMMCHK
c******************************************************************************
c
      subroutine mnmmchk( mnmmeth, esswit, mcswit, ctr, ierr )
c
c     Subroutine mnmmchk
c    
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for MCCM-NM are standard.
c       For solely energy calls (take into account all energies available 
c       in checkpoint files).
c
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:
c    
      use param
      implicit none
      
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20  mnmmeth
c
c  Always do following calculations if a standard MCCM-NM
c
      esswit(phf,pdz) = 1
c      esswit(phf,pdzs) = 1
      esswit(phf,mpdz) = 1                                              0808RMP12
      esswit(phf,ptz) = 1
      esswit(pmp2,pdz) = 1
      esswit(pmp2,ptz) = 1
c
c  MCCM-NM METHOD = CCSD(T)
c
      if (mnmmeth(:7).eq.'ccsd(t)') then
         esswit(pmp4sdq,pdz) = 1
         esswit(pmp4,pdz) = 1
         esswit(pccsd,pdz) = 1
         esswit(pccsdt,pdz) = 1
         call setmcsw( mcswit, ctr, pmnm, nodef, pccsdt, na)
c
      endif
c
      return
      end
c
c
c******************************************************************************
c MUTMCHK
c******************************************************************************
c
      subroutine mutmchk( mutmeth, esswit, mcswit, ctr, ierr )
c
c     Subroutine mutmchk
c    
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for MCCM-UT are standard.
c       For solely energy calls (take into account all energies available 
c       in checkpoint files).
c
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:
c    
      use param
      use energy
      implicit none
c
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20  mutmeth
c
c  Always do following calculations if a standard MCCM-UT
c
      esswit(phf,pdz) = 1
      esswit(phf,ptz) = 1 
      esswit(pmp2,pdz) = 1
      esswit(pmp2,ptz) = 1
c
c  MCCM-UT METHOD = CCSD(T)
c
      if (mutmeth(:7).eq.'ccsd(t)') then
         esswit(pccsdt,pdz) = 1
         esswit(pccsd,pdz) = 1
         esswit(pmp4,pdz) = 1
         esswit(pmp4sdq,pdz) = 1
         call setmcsw( mcswit, ctr, pmut, nodef, pccsdt, na)
c  
c  MCCM-UT METHOD = CCSD
c
      elseif (mutmeth(:4).eq.'ccsd') then
         esswit(pccsd,pdz) = 1
         esswit(pmp4sdq,pdz) = 1
         call setmcsw( mcswit, ctr, pmut, nodef, pccsd, na)
c
c  MCCM-UT METHOD = MP4SDQ
c
      elseif (mutmeth(:6).eq.'mp4sdq') then
         esswit(pmp4sdq,pdz) = 1
         call setmcsw( mcswit, ctr, pmut, nodef, pmp4sdq, na) 
c 
c  MCCM-UT METHOD = MP4
c
      elseif (mutmeth(:3).eq.'mp4') then
         esswit(pmp4,pdz) = 1
         esswit(pmp4sdq,pdz) = 1
         call setmcsw( mcswit, ctr, pmut, nodef, pmp4, na)
c
      endif
c
      return
      end
c  
c  
c******************************************************************************
c IBMCHK
c******************************************************************************
c
      subroutine ibmchk( ibmeth, esswit, mcswit, ctr, ierr )
c
c     Subroutine ibmchk
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for IB are standard.
c       For solely energy calls (take into account all energies available 
c       in checkpoint files).
c
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:
c
      use param
      use energy
      implicit none

      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20  ibmeth
c
c  Always do following calculations if a standard IB
c
      esswit(phf,pdz) = 1
      esswit(phf,ptz) = 1
c
c  IB METHOD = CCSD(T)
c
      if (ibmeth(:7).eq.'ccsd(t)') then
         do 20 i=ptz, pdz
            esswit(pccsdt,i) = 1
            esswit(pccsd,i) = 1
            esswit(pmp4,i) = 1
            esswit(pmp4sdq,i) = 1
            esswit(pmp2,i) = 1
  20     continue
         call setmcsw( mcswit, ctr, pib, nodef, pccsdt, na)
c
c  IB METHOD = CCSD
c  
      elseif (ibmeth(:4).eq.'ccsd') then
         do 40 i=ptz, pdz
            esswit(pccsd,i) = 1
            esswit(pmp4sdq,i) = 1
            esswit(pmp2,i) = 1
  40     continue
         call setmcsw( mcswit, ctr, pib, nodef, pccsd, na)
c
c  IB METHOD = MP4
c
      elseif (ibmeth(:3).eq.'mp4') then
         do 60 i=ptz, pdz
            esswit(pmp4,i) = 1
            esswit(pmp4sdq,i) = 1
            esswit(pmp2,i) = 1
  60     continue
         call setmcsw( mcswit, ctr, pib, nodef, pmp4, na)
c  
c  IB METHOD = MP2
c
      elseif (ibmeth(:3).eq.'mp2') then  
         esswit(pmp2,ptz) = 1
         esswit(pmp2,pdz) = 1
         call setmcsw( mcswit, ctr, pib, nodef, pmp2, na)
c
      endif
c
      return
      end
c
c
c******************************************************************************
c MCSMCHK
c******************************************************************************
c
      subroutine mcsmchk( mcsmeth,mcsbas,esswit,mcswit,
     *                    ctr,ierr )
c
c     Subroutine mcsmchk
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for MCSAC are standard.
c       For solely energy calls (take into account all energies available 
c       in checkpoint files).
c
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:   
c
      use param
      use energy
      implicit none

      integer bas
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20 mcsmeth, mcsbas
c
c  define bas using mcsmeth
c
      if (mcsbas(:7).eq.'cc-pvtz')  bas = ptz
      if (mcsbas(:7).eq.'cc-pvdz')  bas = pdz
c
c  Always do following calculations if a standard MCSAC
c
      esswit(phf,bas) = 1
      esswit(pmp2,bas) = 1
c 
c  MCSAC METHOD = CCSD(T)
c
      if (mcsmeth(:7).eq.'ccsd(t)') then
         esswit(pccsdt,bas) = 1
         esswit(pccsd,bas) = 1
         esswit(pmp4,bas) = 1
         esswit(pmp4sdq,bas) = 1
         call setmcsw( mcswit, ctr, pmcs, nodef, pccsdt, bas)
c 
c  MCSAC METHOD = CCSD
c
      elseif (mcsmeth(:4).eq.'ccsd') then
         esswit(pccsd,bas) = 1
         esswit(pmp4sdq,bas) = 1
         call setmcsw( mcswit, ctr, pmcs, nodef, pccsd, bas)
c
c  MCSAC METHOD = MP4SDQ
c
      elseif (mcsmeth(:6).eq.'mp4sdq') then
         esswit(pmp4sdq,bas) = 1
         call setmcsw( mcswit, ctr, pmcs, nodef, pmp4sdq, bas)
c
c  MCSAC METHOD = MP4
c   
      elseif (mcsmeth(:3).eq.'mp4') then 
         esswit(pmp4,bas) = 1
         esswit(pmp4sdq,bas) = 1
         call setmcsw( mcswit, ctr, pmcs, nodef, pmp4, bas) 
c
      endif
c
      return
      end
c
c
c******************************************************************************
c SACMCHK
c******************************************************************************
c
      subroutine sacmchk(sacmeth,sacbas,esswit,mcswit,ctr,ierr)
c  
c     Subroutine sacmchk
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for SAC are standard.
c       For solely energy calls (take into account all energies available 
c       in checkpoint files).
c  
c     Called by:  mcehk
c     Calls: setmcsw
c
c     Variables defined here:
c  
      use param
      use energy
      implicit none
   
      integer bas
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20  sacmeth, sacbas
c  
c  define bas using sacmeth
c
         if (sacbas(:7).eq.'cc-pvtz')  bas = ptz
         if (sacbas(:7).eq.'cc-pvdz')  bas = pdz
c
c  Always do following calculation if standard SAC
c
      esswit(phf,bas) = 1
c
c  SAC METHOD = CCSD(T)
c
      if (sacmeth(:7).eq.'ccsd(t)') then
         esswit(pccsdt,bas) = 1
         esswit(pccsd,bas) = 1
         esswit(pmp4,bas) = 1
         esswit(pmp4sdq,bas) = 1
         esswit(pmp2,bas) = 1
         call setmcsw( mcswit, ctr, psac, nodef, pccsdt, bas)
c 
c  SAC METHOD = CCSD
c 
      elseif (sacmeth(:4).eq.'ccsd') then
         esswit(pccsd,bas) = 1
         esswit(pmp4sdq,bas) = 1
         esswit(pmp2,bas) = 1
         call setmcsw( mcswit, ctr, psac, nodef, pccsd, bas)
c  
c  SAC METHOD = MP4SDQ
c  
      elseif (sacmeth(:6).eq.'mp4sdq') then 
         esswit(pmp4sdq,bas) = 1
         esswit(pmp2,bas) = 1
         call setmcsw( mcswit, ctr, psac, nodef, pmp4sdq, bas) 
c
c  SAC METHOD = MP4
c  
      elseif (sacmeth(:3).eq.'mp4') then
         esswit(pmp4,bas) = 1
         esswit(pmp4sdq,bas) = 1
         esswit(pmp2,bas) = 1
         call setmcsw( mcswit, ctr, psac, nodef, pmp4, bas)
c
c  SAC METHOD = MP2
c  
      elseif (sacmeth(:3).eq.'mp2') then
         esswit(pmp2,bas) = 1
         call setmcsw( mcswit, ctr, psac, nodef, pmp2, bas)
c
      endif
c
      return
      end
c
c******************************************************************************
c MCOCHK
c******************************************************************************
c
      subroutine mcochk( mcometh, esswit, mcswit, ctr, ierr )
c
c     Subroutine mcochk
c    
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for MCCM-CO are standard.
c       For gradient or hessian calls.
c
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:
c    
      use param
      use energy
      implicit none
      
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20  mcometh
c
c  Always do following calculations if a standard MCCM-CO
c 
      esswit(phf,pdz) = 1
      esswit(phf,ptz) = 1
      esswit(pmp2,pdz) = 1
      esswit(pmp2,ptz) = 1
c
c  MCCM-CO METHOD = CCSD(T)
c
      if (mcometh(:7).eq.'ccsd(t)') then
         do 20 i=ptz, pdz
            esswit(pccsd,i) = 1
            esswit(pccsdt,i) = 1
  20     continue
         call setmcsw( mcswit, ctr, pmco, nodef, pccsdt, na)
c  
c  MCCM-CO METHOD = CCSD
c
      elseif (mcometh(:4).eq.'ccsd') then
         do 40 i=ptz, pdz
            esswit(pccsd,i) = 1
  40     continue
         call setmcsw( mcswit, ctr, pmco, nodef, pccsd, na)
c
c  MCCM-CO METHOD = MP4SDQ
c
      elseif (mcometh(:6).eq.'mp4sdq') then
         do 60 i=ptz, pdz
            esswit(pmp4sdq,i) = 1
  60     continue
         call setmcsw( mcswit, ctr, pmco, nodef, pmp4sdq, na)
c
c  MCCM-CO METHOD = MP4
c
      elseif (mcometh(:3).eq.'mp4') then
         do 100 i=ptz, pdz
            esswit(pmp4,i) = 1   
            esswit(pmp4sdq,i) = 1
 100     continue
         call setmcsw( mcswit, ctr, pmco, nodef, pmp4, na)
c
c  MCCM-CO METHOD = MP2  
c
      elseif (mcometh(:3).eq.'mp2') then
         call setmcsw(mcswit, ctr, pmco, nodef, pmp2, na)
c
      endif
c
      return
      end
c
c******************************************************************************
c MNMCHK
c******************************************************************************
c
      subroutine mnmchk( mnmmeth, esswit, mcswit, ctr, ierr )
c
c     Subroutine mnmchk
c    
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for MCCM-NM are standard.
c       For gradient and hessian calls.
c
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:
c    
      use param
      implicit none
      
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20  mnmmeth
c
c  Always do following calculations if a standard MCCM-NM
c
      esswit(phf,pdz) = 1
c      esswit(phf,pdzs) = 1
      esswit(phf,mpdz) = 1                                              0808RMP12
      esswit(phf,ptz) = 1
      esswit(pmp2,pdz) = 1
      esswit(pmp2,ptz) = 1
c
c  MCCM-NM METHOD = CCSD(T)
c
      if (mnmmeth(:7).eq.'ccsd(t)') then
         esswit(pccsd,pdz) = 1
         esswit(pccsdt,pdz) = 1
         call setmcsw( mcswit, ctr, pmnm, nodef, pccsdt, na)
c
      endif
c
      return
      end
c
c******************************************************************************
c MUTCHK
c******************************************************************************
c
      subroutine mutchk( mutmeth, esswit, mcswit, ctr, ierr )
c
c     Subroutine mutchk
c    
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for MCCM-UT are standard.
c       For  gradient and hessian calls
c
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:
c    
      use param
      use energy
      implicit none
c
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20  mutmeth
c
c  Always do following calculations if a standard MCCM-UT
c
      esswit(phf,pdz) = 1
      esswit(phf,ptz) = 1 
      esswit(pmp2,pdz) = 1
      esswit(pmp2,ptz) = 1
c
c  MCCM-UT METHOD = CCSD(T)
c
      if (mutmeth(:7).eq.'ccsd(t)') then
         esswit(pccsdt,pdz) = 1
         esswit(pccsd,pdz) = 1
         call setmcsw( mcswit, ctr, pmut, nodef, pccsdt, na)
c  
c  MCCM-UT METHOD = CCSD
c
      elseif (mutmeth(:4).eq.'ccsd') then
         esswit(pccsd,pdz) = 1
         call setmcsw( mcswit, ctr, pmut, nodef, pccsd, na)
c
c  MCCM-UT METHOD = MP4SDQ
c
      elseif (mutmeth(:6).eq.'mp4sdq') then
         esswit(pmp4sdq,pdz) = 1
         call setmcsw( mcswit, ctr, pmut, nodef, pmp4sdq, na) 
c 
c  MCCM-UT METHOD = MP4
c
      elseif (mutmeth(:3).eq.'mp4') then
         esswit(pmp4,pdz) = 1
         esswit(pmp4sdq,pdz) = 1
         call setmcsw( mcswit, ctr, pmut, nodef, pmp4, na )
c
      endif
c
      return
      end
c  
c******************************************************************************
c IBCHK
c******************************************************************************
c
      subroutine ibchk( ibmeth, esswit, mcswit, ctr, ierr )
c
c     Subroutine ibchk
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for IB are standard.
c       For gradient and hessian calls.
c
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:
c
      use param
      use energy
      implicit none

      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20  ibmeth
c
c  Always do following calculations if a standard IB
c
      esswit(phf,pdz) = 1
      esswit(phf,ptz) = 1
c
c  IB METHOD = CCSD(T)
c
      if (ibmeth(:7).eq.'ccsd(t)') then
         do 20 i=ptz, pdz
            esswit(pccsdt,i) = 1
  20     continue
         call setmcsw( mcswit, ctr, pib, nodef, pccsdt, na)
c
c  IB METHOD = CCSD
c  
      elseif (ibmeth(:4).eq.'ccsd') then
         do 40 i=ptz, pdz
            esswit(pccsd,i) = 1
  40     continue
         call setmcsw( mcswit, ctr, pib, nodef, pccsd, na)
c
c  IB METHOD = MP4
c
      elseif (ibmeth(:3).eq.'mp4') then
         do 60 i=ptz, pdz
            esswit(pmp4,i) = 1
  60     continue
         call setmcsw( mcswit, ctr, pib, nodef, pmp4, na)
c  
c  IB METHOD = MP2
c
      elseif (ibmeth(:3).eq.'mp2') then  
         esswit(pmp2,ptz) = 1
         esswit(pmp2,pdz) = 1
         call setmcsw( mcswit, ctr, pib, nodef, pmp2, na)
c
      endif
c
      return
      end
c
c******************************************************************************
c MCSCHK
c******************************************************************************
c
      subroutine mcschk( mcsmeth,mcsbas,esswit,mcswit,ctr,ierr )
c
c     Subroutine mcschk
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for MCSAC are standard.
c       For gradient and hessian calls.
c
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:   
c
      use param
      use energy
      implicit none

      integer bas
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20 mcsmeth, mcsbas
c
c  define bas using mcsmeth
c
      if (mcsbas(:7).eq.'cc-pvtz')  bas = ptz
      if (mcsbas(:7).eq.'cc-pvdz')  bas = pdz
c
c  Always do following calculations if a standard MCSAC
c
      esswit(phf,bas) = 1
      esswit(pmp2,bas) = 1
c 
c  MCSAC METHOD = CCSD(T)
c
      if (mcsmeth(:7).eq.'ccsd(t)') then
         esswit(pccsdt,bas) = 1
         esswit(pccsd,bas) = 1
         call setmcsw( mcswit, ctr, pmcs, nodef, pccsdt, bas)
c 
c  MCSAC METHOD = CCSD
c
      elseif (mcsmeth(:4).eq.'ccsd') then
         esswit(pccsd,bas) = 1
         call setmcsw( mcswit, ctr, pmcs, nodef, pccsd, bas)
c
c  MCSAC METHOD = MP4SDQ
c
      elseif (mcsmeth(:6).eq.'mp4sdq') then
         esswit(pmp4sdq,bas) = 1
         call setmcsw( mcswit, ctr, pmcs, nodef, pmp4sdq, bas)
c
c  MCSAC METHOD = MP4
c   
      elseif (mcsmeth(:3).eq.'mp4') then 
         esswit(pmp4,bas) = 1
         esswit(pmp4sdq,bas) = 1
         call setmcsw( mcswit, ctr, pmcs, nodef, pmp4, bas) 
c
      endif
c
      return
      end
c
c******************************************************************************
c  SACCHK
c******************************************************************************
c
      subroutine sacchk( sacmeth,sacbas,esswit,mcswit,ctr,ierr )
c  
c     Subroutine sacchk
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all necessary electronic structure program
c       calls to make.  Switch on the non-default slot in mcswit.  Only
c       called when method and basis specified for SAC are standard.
c       For gradient and Hessian calls.
c  
c     Called by:  mcehk
c     Calls:  setmcsw
c
c     Variables defined here:
c  
      use param
      use energy
      use files
      implicit none
   
      integer bas
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr, ierr, i
      character*20  sacmeth, sacbas
c  
c  define bas using sacmeth
c
         if (sacbas(:7).eq.'cc-pvtz')  bas = ptz
         if (sacbas(:7).eq.'cc-pvdz')  bas = pdz
c
c  Always do following calculation if standard SAC
c
      esswit(phf,bas) = 1
c
c  SAC METHOD = CCSD(T)
c
      if (sacmeth(:7).eq.'ccsd(t)') then
         esswit(pccsdt,bas) = 1
         call setmcsw( mcswit, ctr, psac, nodef, pccsdt, bas)
c 
c  SAC METHOD = CCSD
c 
      elseif (sacmeth(:4).eq.'ccsd') then
         esswit(pccsd,bas) = 1
         call setmcsw( mcswit, ctr, psac, nodef, pccsd, bas)
c  
c  SAC METHOD = MP4SDQ
c  
      elseif (sacmeth(:6).eq.'mp4sdq') then 
         esswit(pmp4sdq,bas) = 1
         call setmcsw( mcswit, ctr, psac, nodef, pmp4sdq, bas) 
c
c  SAC METHOD = MP4
c  
      elseif (sacmeth(:3).eq.'mp4') then
         esswit(pmp4,bas) = 1
         call setmcsw( mcswit, ctr, psac, nodef, pmp4, bas)
c
c  SAC METHOD = MP2
c  
      elseif (sacmeth(:3).eq.'mp2') then
         esswit(pmp2,bas) = 1
         call setmcsw( mcswit, ctr, psac, nodef, pmp2, bas)
c
      endif
c
      return
      end
c
c
c******************************************************************************
c MCCHK
c******************************************************************************
c
      subroutine mcchk( esswit, mcswit, ctr )
c
c     Subroutine mcchk
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine all possible MC calculations based on the
c       switches flipped in esswit.
c
c     Called by:  mcehk
c     Calls:  setmco, setmnm, setmut, setib, setmcs, setsac
c
c     Variables defined here:
c  
      use param
      use energy
      implicit none
 
      integer es(numbas), i, j
      integer esswit(numes,numbas), mcswit(5,numcalc), ctr
c
c  Set switch for each basis set if a calculation called for one
c
      do 10 i=1, numbas
         es(i) = 0
         do 20 j=1, numes
            if (esswit(j,i).eq.1) then
               es(i) = 1
               goto 10
            endif
  20     continue
  10  continue
c
c  Set switches in desired order, but only call setting functions if
c    appropriate bases have been called.
c
      if (es(pdz).eq.1 .and. es(ptz).eq.1) then  
         call setmco( esswit, mcswit, ctr )
      endif
      if (es(pdz).eq.1 .and. es(ptz).eq.1 
c     *       .and. es(pdzs).eq.1) then
     *       .and. es(mpdz).eq.1) then                                  0808RMP12
         call setmnm( esswit, mcswit, ctr )
      endif
      if (es(pdz).eq.1 .and. es(ptz).eq.1) then
         call setmut( esswit, mcswit, ctr )
      endif
      if (es(pdz).eq.1 .and. es(ptz).eq.1) then
         call setib(  esswit, mcswit, ctr )
      endif
      if (es(ptz).eq.1) then
         call setmcs( esswit, mcswit, ctr, ptz )
      endif
      if (es(pdz).eq.1) then
         call setmcs( esswit, mcswit, ctr, pdz )
      endif
      if (es(ptz).eq.1) then
         call setsac( esswit, mcswit, ctr, ptz )
      endif
      if (es(pdz).eq.1) then
         call setsac( esswit, mcswit, ctr, pdz )
      endif

      return
      end
c
c
c******************************************************************************
c SETMCSW
c******************************************************************************
c
      subroutine setmcsw( mcswit, ctr, mcmeth, defalt, esmeth, basis) 
c 
c     Subroutine setmcsw 
c 
c     Created:  June 23, 1999 by J. M. Rodgers 
c     Revised:
c     Purpose:  To set a row in mcswit based on the information passed
c        into the function.  If defalt is set to nodef then record calc in
c        one of first slots in mcswit.  Otherwise jump to end of list and
c        add the calculation there.  Ctr is incremented only for the
c        number of default calculations.
c 
c     Called by:  setmco, setmnm, setmut, setmcs, setib, setsac, 
c                 mcochk, mnmchk, mutchk, mcschk, ibchk, sacchk,
c                 mcomchk, mnmmchk, mutmchk, mcsmchk, ibmchk, sacmchk,
c                 mcehk, mcghk, mchhk
c     Calls: 
c 
c     Variables defined here: 
c
      use param, only : nummc, numcalc, nodef, def
      use files, only : outfile
      implicit none
c
c     The significance of the integers mcmeth, esmeth, and basis can be
c       found in the module param.
c
      integer mcswit(5,50), i, j, ctr, mcmeth, defalt, esmeth, basis

c
c  If it is a non-default calculation then store it in one of the first
c    slots in mcswit reserved for each type of mc calculation
c
      if (defalt .eq. nodef) then
         mcswit(1,mcmeth) = mcmeth
         mcswit(2,mcmeth) = nodef
         mcswit(3,mcmeth) = esmeth
         mcswit(4,mcmeth) = basis
c
c  Otherwise go into rest of mcswit
c
      else
c
c  Exit subroutine if already at maximum number of mc calculations able
c    to be recorded in mcswit.
c
2020     if (ctr+nummc .eq. numcalc) then
            write(outfile,*) 'ERROR:  Over number of default mc', 
     *            ' calculations.'
            return
         endif
c
c  Go to end of mcswit and record calculation there.
c
         ctr = ctr + 1
         i = nummc + ctr
         mcswit(1,i) = mcmeth
         mcswit(2,i) = defalt
         mcswit(3,i) = esmeth
         mcswit(4,i) = basis
c
      endif
c
      return
      end
c
c  
c******************************************************************************
c SETMCO
c******************************************************************************
c  
      subroutine setmco( esswit, mcswit, ctr )
c
c     Subroutine setmco
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Set all appropriate new lines in mcswit based on contents
c        of esswit.
c
c     Called by:  mcchk
c     Calls:  setmcsw
c  
c     Variables defined here:
c
      use param
      implicit none
c
      integer mcswit(5,numcalc), esswit(numes,numbas), ctr
c
c  Check to see that MP2/cc-pVTZ, HF/cc-pVTZ, MP2/cc-pVDZ, HF/cc-pVDZ have
c    all been called.  Return if not.
c
      if (esswit(pmp2,ptz).eq.0 .or. esswit(phf,ptz).eq.0 .or.
     *    esswit(pmp2,pdz).eq.0 .or. esswit(phf,pdz).eq.0 ) then
         return
      endif
c
c  CCSD(T)
c
      if (esswit(pccsdt,pdz).eq.1 .and. esswit(pccsdt,ptz).eq.1 .and.
     *    esswit(pccsd,pdz).eq.1  .and. esswit(pccsd,ptz).eq.1)  then
         call setmcsw(mcswit,ctr,pmco,def,pccsdt,na)
      endif
c
c  CCSD
c
      if (esswit(pccsd,pdz).eq.1 .and. esswit(pccsd,ptz).eq.1)  then
         call setmcsw(mcswit,ctr,pmco,def,pccsd,na)
      endif
c
c  MP4
c
      if (esswit(pmp4sdq,pdz).eq.1 .and. esswit(pmp4sdq,ptz).eq.1 .and.
     *    esswit(pmp4,pdz).eq.1    .and. esswit(pmp4,ptz).eq.1)  then
         call setmcsw(mcswit,ctr,pmco,def,pmp4,na)
      endif
c
c  MP4SDQ
c
      if (esswit(pmp4sdq,pdz).eq.1 .and. esswit(pmp4sdq,ptz).eq.1) then
         call setmcsw(mcswit,ctr,pmco,def,pmp4sdq,na)
      endif
c
c  MP2
c
      call setmcsw(mcswit,ctr,pmco,def,pmp2,na)
c
      return
      end
c
c
c******************************************************************************
c SETMNM
c******************************************************************************
c
      subroutine setmnm( esswit, mcswit, ctr )
c
c     Subroutine setmnm
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Set all appropriate new lines in mcswit based on contents
c        of esswit.
c
c     Called by:  mcchk
c     Calls:  setmcsw
c
c     Variables defined here:
c  
      use param
      implicit none
c 
      integer mcswit(5,numcalc), esswit(numes,numbas), ctr
c
c  Check that MP2/cc-pVDZ, MP2/cc-pVTZ, HF/cc-pVDZ, HF/cc-pVTZ,
c    HF/mpDZ have all been called.  Return if not.
c
      if (esswit(pmp2,pdz).eq.0 .or. esswit(phf,pdz).eq.0 .or.
     *    esswit(pmp2,ptz).eq.0 .or. esswit(phf,ptz).eq.0 .or.
c     *    esswit(phf,pdzs).eq.0) then
     *    esswit(phf,mpdz).eq.0) then                                   0808RMP12
         return
      endif
c
c  CCSD(T)
c
      if (esswit(pccsdt,pdz).eq.1 .and. esswit(pccsd,pdz).eq.1) then
         call setmcsw(mcswit,ctr,pmnm,def,pccsdt,na)
      endif
c
      return
      end
c
c
c******************************************************************************
c SETMUT
c******************************************************************************
c
      subroutine setmut( esswit, mcswit, ctr )
c        
c     Subroutine setmut
c     
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Set all appropriate new lines in mcswit based on contents
c        of esswit.
c
c     Called by:  mcchk
c     Calls:  setmcsw
c  
c     Variables defined here:
c
      use param
      implicit none
c
      integer mcswit(5,numcalc), esswit(numes,numbas), ctr
c
c  Check that MP2/cc-pVDZ, MP2/cc-pVTZ, HF/cc-pVDZ, HF/cc-pVTZ have all
c    been called.  Return if not.
c
      if (esswit(pmp2,pdz).eq.0 .or. esswit(phf,pdz).eq.0 .or.
     *    esswit(pmp2,ptz).eq.0 .or. esswit(phf,ptz).eq.0)  then
         return
      endif
c  
c  CCSD(T)
c
      if (esswit(pccsdt,pdz).eq.1 .and. esswit(pccsd,pdz).eq.1) then
         call setmcsw(mcswit,ctr,pmut,def,pccsdt,na)
      endif
c
c  CCSD
c
      if (esswit(pccsd,pdz).eq.1) then
         call setmcsw(mcswit,ctr,pmut,def,pccsd,na)
      endif
c
c  MP4
c
      if (esswit(pmp4,pdz).eq.1 .and. esswit(pmp4sdq,pdz).eq.1) then
         call setmcsw(mcswit,ctr,pmut,def,pmp4,na)
      endif
c
c  MP4SDQ
c
      if (esswit(pmp4sdq,pdz).eq.1) then
         call setmcsw(mcswit,ctr,pmut,def,pmp4sdq,na)
      endif
c
      return
      end
c
c
c******************************************************************************
c SETIB
c******************************************************************************
c
      subroutine setib( esswit, mcswit, ctr )
c
c     Subroutine setib
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Set all appropriate new lines in mcswit based on contents
c        of esswit.
c     
c     Called by:  mcchk
c     Calls:  setmcsw
c
c     Variables defined here:
c
      use param
      implicit none
c
      integer mcswit(5,numcalc), esswit(numes,numbas), ctr
c  
c  Check that HF/cc-pVDZ, HF/cc-pVTZ have all been called.  Return if not.
c
      if (esswit(phf,pdz).eq.0 .or. esswit(phf,ptz).eq.0)  then
         return
      endif
c     
c  CCSD(T)
c
      if (esswit(pccsdt,pdz).eq.1 .and. esswit(pccsdt,ptz).eq.1) then
         call setmcsw(mcswit,ctr,pib,def,pccsdt,na)
      endif
c
c  CCSD
c
      if (esswit(pccsd,pdz).eq.1 .and. esswit(pccsd,ptz).eq.1) then
         call setmcsw(mcswit,ctr,pib,def,pccsd,na)
      endif
c
c  MP4
c
      if (esswit(pmp4,pdz).eq.1 .and. esswit(pmp4,ptz).eq.1) then
         call setmcsw(mcswit,ctr,pib,def,pmp4,na)
      endif
c
c  MP2
c
      if (esswit(pmp2,pdz).eq.1 .and. esswit(pmp2,ptz).eq.1) then
         call setmcsw(mcswit,ctr,pib,def,pmp2,na)
      endif
c
      return
      end
c
c
c******************************************************************************
c SETMCS
c******************************************************************************
c
      subroutine setmcs( esswit, mcswit, ctr, bas )
c
c     Subroutine setmcs
c
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Set all appropriate new lines in mcswit based on contents
c        of esswit.
c     
c     Called by:  mcchk
c     Calls:  setmcsw
c
c     Variables defined here:
c
      use param
      implicit none
c
      integer mcswit(5,numcalc), esswit(numes,numbas), ctr, bas
c
c  Check that HF/bas, MP2/bas have all been called.  Return if not.
c
      if (esswit(phf,bas).eq.0 .or. esswit(pmp2,bas).eq.0)  then
         return
      endif
c
c  CCSD(T)
c
      if (esswit(pccsdt,bas).eq.1 .and. esswit(pccsd,bas).eq.1) then
         call setmcsw(mcswit,ctr,pmcs,def,pccsdt,bas)
      endif
c
c  CCSD
c
      if (esswit(pccsd,bas).eq.1) then
         call setmcsw(mcswit,ctr,pmcs,def,pccsd,bas)
      endif
c
c  MP4
c
      if (esswit(pmp4,bas).eq.1 .and. esswit(pmp4sdq,bas).eq.1) then
         call setmcsw(mcswit,ctr,pmcs,def,pmp4,bas)
      endif
c
c  MP4SDQ
c
      if (esswit(pmp4sdq,bas).eq.1) then
         call setmcsw(mcswit,ctr,pmcs,def,pmp4sdq,bas)
      endif
c
      return
      end
c     
c
c******************************************************************************
c SETSAC
c******************************************************************************
c
      subroutine setsac( esswit, mcswit, ctr, bas )
c
c     Subroutine setsac
c     
c     Created:  June 23, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Set all appropriate new lines in mcswit based on contents
c        of esswit.
c
c     Called by:  mcchk
c     Calls:  setmcsw
c
c     Variables defined here:
c     
      use param
      implicit none
c
      integer mcswit(5,numcalc), esswit(numes,numbas), ctr, bas
c
c  Check that HF/bas has been called.  Return if not.
c
      if (esswit(phf,bas).eq.0) then
         return
      endif
c
c  CCSD(T)
c 
      if (esswit(pccsdt,bas).eq.1)  then
         call setmcsw(mcswit,ctr,psac,def,pccsdt,bas)
      endif
c
c  CCSD
c
      if (esswit(pccsd,bas).eq.1)  then
         call setmcsw(mcswit,ctr,psac,def,pccsd,bas)
      endif
c
c  MP4
c
      if (esswit(pmp4,bas).eq.1)  then
         call setmcsw(mcswit,ctr,psac,def,pmp4,bas)
      endif
c
c  MP4SDQ
c
      if (esswit(pmp4sdq,bas).eq.1) then
         call setmcsw(mcswit,ctr,psac,def,pmp4sdq,bas)
      endif
c
c  MP2
c
      if (esswit(pmp2,bas).eq.1) then
         call setmcsw(mcswit,ctr,psac,def,pmp2,bas)
      endif
c
      return
      end
c
c
c******************************************************************************
c  ESPARSE
c******************************************************************************
c     
      subroutine esparse( prognme, geom, optl, esswit, ierr )
c
c     Subroutine esparse
c
c     Created:  June 24, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Parse esswit and make necessary calls to the electronic
c        structure program using mprogehk.  Requests all possible energies
c        from mprogehk and assigns to appropriate locations in esener.
c
c     Called by:  mcehk
c     Calls:  mprogehk
c
c     Variables defined here:
c
      use input, only : cartgeom
      use param
      use files, only : outfile
      use energy, only : esener
      implicit none

      type (cartgeom) :: geom
      character*10 prognme
      character*20 esmeth(numes)                                           0102BL01
      character*20 esbas, ver_lab
      character*80 optl(5)

      double precision ener(numes)
      integer esswit(numes,numbas), ierr, basused(numbas), 
     *   escall(numes), nume

      integer i, j

      ierr = 0

      basused(1) = 0
      basused(2) = 0
      basused(3) = 0

      do 11 i=1, numbas
         do 12 j=1, numes
            if (esswit(j,i).eq.1) then
               basused(i) = 1
               goto 11
            endif
  12     continue
  11  continue

      j = 1

      do while (j.le.numbas .and. ierr.eq.0)
         if (basused(j).eq.0)  goto 31
         nume = 0
         esbas =  '                    '
         esbas = baslist(j)
         do 21 i=1, numes
            escall(i) = 0
            esmeth(i) = '                    '
            ener(i) = 0.0000d0
  21     continue
         if (esswit(pccsdt,j).eq.1 .and. ierr.eq.0) then
            escall(6) = pccsdt
            escall(5) = pccsd
            escall(4) = pmp4
            escall(3) = pmp4sdq
            escall(2) = pmp2
            escall(1) = phf
            nume = 6                        
         elseif (esswit(pmp4,j).eq.1 .and. ierr.eq.0) then
            escall(4) = pmp4
            escall(3) = pmp4sdq
            escall(2) = pmp2
            escall(1) = phf
            nume = 4
            if (esswit(pccsd,j).eq.1) then                               
               call mprogehk(1, prognme, esmlist(pccsd), esbas, geom,    1022BL00
     *            optl, 1, ener(:1), ierr,ver_lab)
               if (ierr.ne.1)  esener(pccsd,j) = ener(1)
               ener(1) = 0.0000d0
            endif
         elseif (esswit(pccsd,j).eq.1 .and. ierr.eq.0) then
            escall(4) = pccsd
            escall(3) = pmp4sdq
            escall(2) = pmp2
            escall(1) = phf
            nume = 4
         elseif (esswit(pmp4sdq,j).eq.1 .and. ierr.eq.0) then
            escall(3) = pmp4sdq
            escall(2) = pmp2
            escall(1) = phf
            nume = 3
         elseif (esswit(pmp2,j).eq.1 .and. ierr.eq.0) then
            escall(2) = pmp2
            escall(1) = phf
            nume = 2
         elseif (esswit(phf,j).eq.1 .and. ierr.eq.0) then
            escall(1) = phf
            nume = 1
         endif
         do 22 i=1, nume
            esmeth(i) = esmlist(escall(i))
  22     continue
         call mprogehk(1, prognme, esmeth(:nume), esbas, geom,           1022BL00
     *               optl, nume, ener(:nume), ierr,ver_lab)              0224BL02
         do 23 i=1, nume
            esener(escall(i),j) = ener(i)
  23     continue
  31     continue
         j = j+1
      enddo

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

      return
      end

c
c
c******************************************************************************
c  GETEMCO
c******************************************************************************
c
      subroutine getemco(index, coefsw, inpcoef, esmeth, vers)
c
c     Subroutine getemco
c
c     Created:  June 24, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Looks at MCCM-CO calculation requested, gets the
c        necessary electronic structure information from esener and pass
c        it off to calmco to calculate the energy.
c
c     Called by:  mcehk, mcghk, mchhk
c     Calls:  calmco
c
c     Variables defined here:
c
      use param
      use energy, only : esener, mcener
      implicit none

      integer i, index, coefsw, esmeth, basis, max, vers
      double precision inpcoef(10), coef(10), mcoes(5,2)

c
c  Set electronic structure energy arrays to 0.0000d0
c
      do 20 i=1, 5
         mcoes(i,1) = 0.0000d0
         mcoes(i,2) = 0.0000d0
  20  continue
c
c  Gather MCCM-CO electronic structure info in mcoes
c
      mcoes(1,1) = esener(phf,pdz)
      mcoes(1,2) = esener(phf,ptz)
      mcoes(2,1) = esener(pmp2,pdz)
      mcoes(2,2) = esener(pmp2,ptz)
      if (esmeth.eq.pccsd .or. esmeth.eq.pccsdt) then
         mcoes(3,1) = esener(pccsd,pdz)
         mcoes(3,2) = esener(pccsd,ptz)
      endif
      if (esmeth.eq.pccsdt) then
         mcoes(4,1) = esener(pccsdt,pdz)
         mcoes(4,2) = esener(pccsdt,ptz)
      endif
      if (esmeth.eq.pmp4sdq .or. esmeth.eq.pmp4) then
         mcoes(3,1) = esener(pmp4sdq,pdz)
         mcoes(3,2) = esener(pmp4sdq,ptz)
      endif
      if (esmeth.eq.pmp4) then
         mcoes(4,1) = esener(pmp4,pdz)
         mcoes(4,2) = esener(pmp4,ptz)
      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 calmco either the input
c    coefficients (inpcoef) or the default coefficients from param 
c
      do 40 i=1, 10
         coef(i) = 0.0000d0
  40  continue
      
      if (coefsw.eq.def) then
         do 60 i=1, 10
            coef(i) = mcodefc(vers, esmeth, i)
  60     continue
      elseif (coefsw.eq.nodef) then
         do 80 i=1, 10
            coef(i) = inpcoef(i)
  80     continue
      endif
c
c  Call calmco to calculation the MCCM-CO energy based on the e.s.
c    information and the given coefficients.
c
      call calmco( mcener(index), coef, mcoes, max )

      return
      end
c
c******************************************************************************
c  GETEMNM
c******************************************************************************
c
      subroutine getemnm(index, coefsw, inpcoef, esmeth, vers)
c
c     Subroutine getemnm
c
c     Created:  June 24, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Look at MCCM-NM calculation requested, gather the
c        necessary electronic structure information from esener and pass
c        it off to calmnm to calculate the energy.
c
c     Called by:  mcehk, mcghk, mchhk
c     Calls:  calmnm
c
c     Variables defined here:
c
      use param
      use energy, only : esener, mcener
      implicit none

      integer i, index, coefsw, esmeth, basis, max, vers
      double precision inpcoef(10), coef(7), mnmes(5,3)

c
c  Set electronic structure energy arrays to 0.0000d0
c
      do 20 i=1, 5
         mnmes(i,1) = 0.0000d0
         mnmes(i,2) = 0.0000d0
         mnmes(i,3) = 0.0000d0
  20  continue
c
c  Gather MCCM-NM electronic structure info in mnmes
c
      mnmes(1,1) = esener(phf,pdz)
      mnmes(1,2) = esener(phf,ptz)
c      mnmes(1,3) = esener(phf,pdzs)
      mnmes(1,3) = esener(phf,mpdz)                                     0808RMP12
      mnmes(2,1) = esener(pmp2,pdz)
      mnmes(2,2) = esener(pmp2,ptz)
      mnmes(3,1) = esener(pccsd,pdz)
      mnmes(4,1) = esener(pccsdt,pdz)
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 calmnm 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
         do 60 i=1, 7
            coef(i) = mnmdefc(vers, i)
  60     continue
      elseif (coefsw.eq.nodef) then
         do 80 i=1, 7
            coef(i) = inpcoef(i)
  80     continue
      endif
c
c  Call calmnm to calculation the MCCM-NM energy based on the e.s.
c    information and the given coefficients.
c
      call calmnm ( mcener(index), coef, mnmes, max )

      return
      end
c
c******************************************************************************
c  GETEMUT
c******************************************************************************
c
      subroutine getemut(index, coefsw, inpcoef, esmeth, vers)
c
c     Subroutine getemut
c
c     Created:  June 24, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Looks at MCCM-UT calculation requested, gets the
c        necessary electronic structure information from esener and pass
c        it off to calmut to calculate the energy.
c
c     Called by:  mcehk, mcghk, mchhk
c     Calls:  calmut
c
c     Variables defined here:
c
      use param
      use energy, only : esener, mcener
      implicit none

      integer i, index, coefsw, esmeth, basis, max, vers
      double precision inpcoef(10), coef(7), mutes(5,2)

c
c  Set electronic structure energy arrays to 0.0000d0
c
      do 20 i=1, 5
         mutes(i,1) = 0.0000d0
         mutes(i,2) = 0.0000d0
  20  continue
c
c  Gather MCCM-UT electronic structure info
c
      mutes(1,1) = esener(phf,pdz)
      mutes(1,2) = esener(phf,ptz)
      mutes(2,1) = esener(pmp2,pdz)
      mutes(2,2) = esener(pmp2,ptz)
      if (esmeth.eq.pccsd .or. esmeth.eq.pccsdt) then
         mutes(3,1) = esener(pccsd,pdz)
      endif
      if (esmeth.eq.pccsdt) then
         mutes(4,1) = esener(pccsdt,pdz)
      endif
      if (esmeth.eq.pmp4sdq .or. esmeth.eq.pmp4) then
         mutes(3,1) = esener(pmp4sdq,pdz)
      endif
      if (esmeth.eq.pmp4) then
         mutes(4,1) = esener(pmp4,pdz)
      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 calmut 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
         do 60 i=1, 7
            coef(i) = mutdefc(vers, esmeth, i)
  60     continue
      elseif (coefsw.eq.nodef) then
         do 80 i=1, 7
            coef(i) = inpcoef(i)
  80     continue
      endif
c
c  Call calmut to calculation the MCCM-UT energy based on the e.s.
c    information and the given coefficients.
c
      call calmut ( mcener(index), coef, mutes, max )

      return
      end
c
c******************************************************************************
c  GETEIB
c******************************************************************************
c
      subroutine geteib(index, coefsw, inpcoef, esmeth)
c
c     Subroutine geteib
c
c     Created:  June 24, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Looks at IB calculation requested, gets the
c        necessary electronic structure information from esener and pass
c        it off to calib to calculate the energy.
c
c     Called by:  mcehk, mcghk, mchhk
c     Calls:  calib
c
c     Variables defined here:
c
      use param
      use energy, only : esener, mcener
      implicit none

      integer i, index, coefsw, esmeth, basis, max
      double precision inpcoef(10), alpha, beta, ibes(2,2)

c
c  Set electronic structure energy arrays to 0.0000d0
c
      ibes(1,1) = 0.0000d0
      ibes(2,1) = 0.0000d0
      ibes(1,2) = 0.0000d0
      ibes(2,2) = 0.0000d0 
c
c  Gather IB electronic structure info in ibes
c
      ibes(1,1) = esener(phf,pdz)
      ibes(1,2) = esener(phf,ptz)
      ibes(2,1) = esener(esmeth,pdz)
      ibes(2,2) = esener(esmeth,ptz)
c
c  Look at coefsw and depending on whether default or non-default
c    coefficients have been requested, pass on to calib 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 calib to calculation the IB energy based on the e.s.
c    information and the given coefficients.
c
      call calib ( mcener(index), alpha, beta, ibes )

      return
      end
c
c
c******************************************************************************
c  GETEMCS
c******************************************************************************
c
      subroutine getemcs(index, coefsw, inpcoef, esmeth, vers, basis)
c
c     Subroutine getemcs
c
c     Created:  June 24, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Looks at MCSAC calculation requested, gets the
c        necessary electronic structure information from esener and pass
c        it off to calmcs to calculate the energy.
c
c     Called by:  mcehk, mcghk, mchhk
c     Calls:  calmcs
c
c     Variables defined here:
c
      use param
      use energy, only : esener, mcener
      implicit none

      integer i, index, coefsw, esmeth, basis, max, vers
      double precision inpcoef(10), coef(4), mcses(5)

c
c  Set electronic structure energy arrays to 0.0000d0
c
      do 20 i=1, 5
         mcses(i) = 0.0000d0
  20  continue
c
c  Gather MCSAC info and pass to calcmcs
c
      mcses(1) = esener(phf, basis)
      mcses(2) = esener(pmp2, basis)
      if (esmeth.eq.pccsd .or. esmeth.eq.pccsdt) then
         mcses(3) = esener(pccsd, basis)
      endif
      if (esmeth.eq.pccsdt) then
         mcses(4) = esener(pccsdt, basis)
      endif
      if (esmeth.eq.pmp4sdq .or. esmeth.eq.pmp4) then
         mcses(3) = esener(pmp4sdq, basis)
      endif
      if (esmeth.eq.pmp4) then
         mcses(4) = esener(pmp4, basis)
      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 calmcs 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
         do 60 i=1, 4
            coef(i) = mcsdefc(vers, esmeth, basis, i)
  60     continue
      elseif (coefsw.eq.nodef) then
         do 80 i=1, 4
            coef(i) = inpcoef(i)
  80     continue
      endif

c
c  Call calmcs to calculation the MCSAC energy based on the e.s.
c    information and the given coefficients.
c
      call calmcs ( mcener(index), coef, mcses, max )

      return
      end
c
c******************************************************************************
c  GETESAC
c******************************************************************************
c
      subroutine getesac(index, coefsw, inpcoef, esmeth, vers, basis)
c
c     Subroutine getesac
c
c     Created:  June 24, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Looks at SAC calculation requested, gets the
c        necessary electronic structure information from esener and pass
c        it off to calsac to calculate the energy.
c
c     Called by:  mcehk, mcghk, mchhk
c     Calls:  calsac
c
c     Variables defined here:
c
      use param
      use energy, only : esener, mcener
      implicit none

      integer i, index, coefsw, esmeth, basis, max, vers
      double precision inpcoef(10), coef, saces(2)

c
c  Set electronic structure energy arrays to 0.0000d0
c
      saces(1) = 0.0000d0
      saces(2) = 0.0000d0
c
c  Gather SAC info and pass to calcsac
c
      saces(1) = esener(phf, basis)
      saces(2) = esener(esmeth, basis)
c
c  Look at coefsw and depending on whether default or non-default
c    coefficients have been requested, pass on to calsac 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 calsac to calculate the SAC energy based on the e.s.
c    information and the given coefficients.
c 
      call calsac ( mcener(index), coef, saces )

      return
      end
c
c
c******************************************************************************
c  CALSAC
c******************************************************************************
c
      subroutine calsac( val, coef, saces )
c
c     Subroutine calsac
c
c     Created:  June 25, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Calculate SAC value given values in saces and the
c               coefficient.  Returns value in val.  Not include SO 
c               and CC energy contributions.  Can calculate energy,
c               gradient components, or hessian components
c
c     Called by: getesac, sacehk, getgsac, sacghk, gethsac, sachhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile
      implicit none
c
c  saces(1) should be the HF value
c  saces(2) should be the higher level value
c
      double precision val, saces(2)
      double precision coef

      val = saces(1) + coef*( saces(2)-saces(1) )

      return
      end
c
c
c******************************************************************************
c  CALMCS
c******************************************************************************
c  
      subroutine calmcs( val, c, mcses, max )
c
c     Subroutine calmcs
c
c     Created:  June 25, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Calculate MCSAC value given values in mcses and the
c               coefficients in c.  Returns value in val.  Not include
c               SO and CC energy contributions.  For energy, gradient
c               component, or hessian component calculations.
c     
c     Called by: getemcs, mcsehk, getgmcs, mcsghk, gethmcs, mcshhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile
      implicit none
c
c  MCSES should be the necessary values to calculated the MCSAC value.
c    1 corresponds to HF and then builds along one of the series to max.
c
      double precision val, mcses(5)
      integer max, meth, bas, i
      double precision c(4)
c
c  Calculate the MCSAC value.
c
      val = mcses(1)

      do 60 i=2, max
         val = val + c(i-1)*(mcses(i)-mcses(i-1))
  60  continue

      return
      end
c
c
c******************************************************************************
c  CALIB
c******************************************************************************
c
      subroutine calib( val, alpha, beta, ibes )
c
c     Subroutine calib
c
c     Created:  June 25, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Calculate IB value given values in ibes and the
c               coefficients alpha and beta.  Returns value in val.  Not
c               include SO and CC energy contributions.  For energy,
c               gradient component, or hessian componenet calculations.
c
c     Called by: geteib, ibehk, getgib, ibghk, gethib, ibhhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile
      implicit none
c
c  The first index corresponds to theory level, with 1 signifying HF and 2
c    signifying the higher level method.
c  The second index corresponds to basis set, with 1 signifying the lower
c    level basis set and 2 signifying the higher level one.
c
      double precision val, ibes(2,2)
      double precision alpha, beta, c(2)

c
c  Set the coefficients based on alpha and beta
c
      c(1) = (3.0000**alpha)/(3.0000**alpha - 2.0000**alpha)
      c(2) = (3.0000**beta)/(3.0000**beta - 2.0000**beta)
c
c  Calculate the value
c      
      val = ibes(1,1) + c(1)*(ibes(1,2)-ibes(1,1))
     *       + (ibes(2,1)-ibes(1,1))
     *       + c(2)*(ibes(2,2)-ibes(1,2)-ibes(2,1)+ibes(1,1))

      return
      end
c
c
c******************************************************************************
c  CALMCO
c******************************************************************************
c
      subroutine calmco( val, c, mcoes, max )
c
c     Subroutine calmco
c
c     Created:  June 25, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Calculate MCCM-CO value given values in mcoes and the
c               coefficients in c.  Return value in  val.  Not include 
c               SO and CC energy contributions.  Can calculate energy,
c               gradient components, or hessian components.
c     
c     Called by: getemco, mcoehk, getgmco, mcoghk, gethmco, mcohhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile
      implicit none
c
c  The second index in mcoes corresponds to basis:
c       1 = Lower Basis,  2 = Higher Basis
c  The first index corresponds to theory level:
c       1 = HF and it builds along one of the series to max.
c
      double precision val, mcoes(5,2), c(10)
      integer max, i
c
c  Calculate value
c
      val = c(1)*mcoes(1,1) + c(2)*( mcoes(1,2) - mcoes(1,1))

      do 60 i=2, max
         val = val + c(2*i)*( mcoes(i,2) - mcoes(i-1,2) 
     *          - mcoes(i,1) + mcoes(i-1,1) )
         val = val + c(2*i-1)*( mcoes(i,1) - mcoes(i-1,1) )
  60  continue

      return
      end
c
c
c******************************************************************************
c  CALMUT
c******************************************************************************
c
      subroutine calmut( val, c, mutes, max )
c
c     Subroutine calmut
c
c     Created:  June 25, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Calculate MCCM-UT value given values in mutes and the
c               coefficients in c.  Return value in val.  Not include 
c               SO and CC energy contributions.  Can calculate energy,
c               gradient components, or hessian components.
c
c     Called by: getemut, mutehk, getgmut, mutghk, gethmut, muthhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile
      implicit none
c
c  The second index in mutes corresponds to basis:
c       1 = Lower Basis,  2 = Higher Basis
c  The first index corresponds to theory level:
c       1 = HF and it builds along one of the series to max.
c               
      double precision val, mutes(5,2), c(7)
      integer max, i

c
c  Calculate value
c
      val = c(1)*mutes(1,1) + c(2)*( mutes(1,2) - mutes(1,1))

      val = val + c(3)*( mutes(2,1) - mutes(1,1) )
      val = val + c(4)*( mutes(2,2) - mutes(1,2) 
     *        - mutes(2,1) + mutes(1,1) )

      do 60, i=3, max
         val = val + c(i+2)*( mutes(i,1) - mutes(i-1,1) )
  60  continue

      return
      end
c
c
c******************************************************************************
c  CALMNM
c******************************************************************************
c
      subroutine calmnm( val, c, mnmes, max )
c
c     Subroutine calmnm
c
c     Created:  June 25, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Calculate MCCM-NM value given values in mnmes and the
c               coefficients in c.  Return value in val.  Not include SO
c               and CC energy contributions.  Can calculate energy,
c               gradient components, or hessian components.
c
c     Called by: getemnm, mnmehk, getgmnm, mnmghk, gethmnm, mnmhhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile
      implicit none
c
c  The second index in mnmes corresponds to basis:
c       1 = Lower Basis,  2 = Higher Basis, 3 = Middle Basis
c  The first index corresponds to theory level:
c       1 = HF and it builds along one of the series to max.
c               
      double precision val, mnmes(5,3)
      integer max, meth, i
      double precision c(7)
c
c  Calculate value
c
      val = c(1)*mnmes(1,1) + c(2)*( mnmes(1,2) - mnmes(1,1))

      val = val + c(3)*( mnmes(2,1) - mnmes(1,1) )
      val = val + c(4)*( mnmes(2,2) - mnmes(1,2)
     *        - mnmes(2,1) + mnmes(1,1) )
      
      do 60, i=3, max
         val = val + c(i+2)*( mnmes(i,1) - mnmes(i-1,1) )
  60  continue

c    contribution from the HF/pDZ+|pDZ difference
      val = val + c(7)*( mnmes(1,3) - mnmes(1,1) )
      
      return
      end

c
c
c*****************************************************************************
c  PROGEHK
c*****************************************************************************
c
      subroutine progehk(prognme, esmeth, esbas, geom, optl, ener, ierr)
c
c     Subroutine progehk
c
c     Created:  June 28, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Get a single point energy for the given geom with the
c        specified electronic structure package.
c
c     Description:  Calls a function to write a G94/98 SPE input file,
c         runs this calculation on the system, and then calls a fxn that
c         reads the energy from the formatted checkpoint file created by
c         G94/98.
c
c     Note:  Currently only G94/98 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:  hfmoehk, optehk, imohcehk
c     Calls:  g98inp, g98oute, mg98oute, system
c
c     Variables defined here:
c
      use caltyp
      use files
      use input, only : cartgeom
      implicit none

      character*10 prognme
      character*20 ver_lab                                                 0224BL02                      
      character*20 esmeth                      
      character*20 esbas                                                   0201BL01
      type (cartgeom) :: geom
      character*80 optl(5)
      double precision ener
      integer ierr


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, tener,ver_lab)
         close (g98inf, err=9991)
         call system('./g98shuttle g98.inp g98.out')
         call g98oute(1,esmeth, ener)                                     2405JC00
c
c  GAUSSIAN94
c    Just reuse g98inp and g98oute 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,tener,ver_lab)
         close (g94inf, err=9992)
         call system('./g94shuttle g94.inp g94.out')
         call g98oute(1,esmeth, ener)                                     2405JC00
c
c  GAUSSIAN03
c    Just reuse g98inp and g98oute 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,tener,ver_lab)
         close (g03inf, err=9993)
         call system('./g03shuttle g03.inp g03.out')
         call g98oute(1,esmeth, ener)                                      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,tener,ver_lab)
         close (g09inf, err=9994)
         call system('./g09shuttle g09.inp g09.out')
         call g98oute(1,esmeth, ener)                                      1409ZY03 
      endif

      return



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

      end
c
c
c*****************************************************************************
c  G98INP
c*****************************************************************************
c
      subroutine g98inp(iunit,esmeth,esbas,geom,optl,type,ver_lab)
c
c     Subroutine g98inp
c     
c     Created:  June 28, 1999 by J. M. Rodgers
c     Revised:  Feb 24, 2002 by B. J. Lynch
c     Purpose:  Write a Gaussian98 input file for the calculation
c        specified.  Type indicates whether it is an energy, gradient, or
c        hessian calculation. (Also used to write G94 input files)0
c                                                                       
c 
c     Called by:  progehk, mprogehk, progghk, proghhk, progohk
c     Calls:
c
c     Variables defined here:
c
      use files
      use caltyp                                                        
      use input, only : cartgeom
      use input, only : mlopt
      use pseudopot                                                     1106RMP13
      implicit none

      type (mlopt) :: optinp


      character*20 ver_lab
      character*20 esmeth
      character*20 esbas, oldbas                                        0201BL01
      type (cartgeom) :: geom   
      character*80 optl(5)   
      integer mfin, bfin, mend, bend, i, j, type, iunit
      character*12 tswit(4)
      logical linkzero

      data tswit /'Energy','Gradient','Hessian','Optimization'/
     
      mfin = 1
      bfin = 1
      mend = 0
      bend = 0

c
       write(outfile,999) tswit(type), esmeth, esbas
 999  format('Running Gaussian Job:',3x,a,3x,a10,3x,a20)
c
c  Hardwired memory has been removed 02/01/01      BJL
c
c      if (type .eq. tener) then                                        0201BL01
c         write (iunit,1010) '%Mem=', emem(:5)                          0201BL01
c      elseif (type.eq.tgrad) then                                      0201BL01
c         write (iunit,1010) '%Mem=', gmem(:5)                          0201BL01
c      elseif (type.eq.thess) then                                      0201BL01
c         write (iunit,1010) '%Mem=', hmem(:5)                          0201BL01
c      elseif (type.eq.topt) then                                       0201BL01
c         write (iunit,1010) '%Mem=', omem(:5)                          0201BL01
c      endif                                                            0201BL01


c
c  If the method is CCSD(T) or QCISD(T) change method specification to get
c     the full MP4 energy as well.. unless the calculation involves 
c     version 3 coefficients which don't require the full MP4           
c     
c
      if (esmeth(:7).eq.'ccsd(t)') then
         esmeth = 'ccsd(t)=e4t'
      elseif (esmeth(:8).eq.'qcisd(t)') then
         if  (.not.((ver_lab(:3).eq.'v3s').or.                          0224BL02
     *                (ver_lab(:3).eq.'v3m')))   then                   0224BL02
                 esmeth = 'qcisd(t)=e4t'                                0201BL01
      endif                                                             0224BL02
      endif
c
c  If the basis is pDZ+,g3large, mg3, or mg3s change the basis
c    specification to Gen so that the non-standard basis will be read in
c    from the foot of the input file. 
c
c      if (esbas(:8).eq.'pdz+' .or. esbas(:3).eq.'mg3'
      if (esbas(:8).eq.'mpdz' .or. esbas(:3).eq.'mg3'                   0808RMP12
     *     .or. esbas(:7).eq.'g3large' .or. 
c     *     esbas(:8).eq.'g3xlarge') then
     *     esbas(:8).eq.'g3xlarge'.or.esbas(:3).eq.'gen') then          1106RMP13
         oldbas = esbas
         esbas = 'gen     '
      endif
c
c  Find ends of method and basis set specification
c
      call fspace(esmeth, mfin, mend)
      if (mend.eq.1) then
         mfin = len(esmeth)
      else
         mfin = mfin-1
      endif

      call fspace(esbas, bfin, bend)
      if (bend.eq.1) then
         bfin = len(esbas)
      else
         bfin = bfin-1
      endif

c
c  Print out Route specifications - different for each possible type
c    specified.
c

c     memory and processors are now specified in the options      
c     linkzero is a logical (boolean) variable to determine if the current
c     line being read is a link0 command or a keyword option

      linkzero = .false.
      i = 1                                                             0201BL01      
      do 10 j=1,10                                                      0201BL01
      if (optl(i)(j:j) .eq. '%' ) then                                  0201BL01
      linkzero = .true.                                                 0201BL01
      endif                                                             0201BL01
10    CONTINUE                                                          0201BL01
      do while (linkzero .and. i.le.5)                                  0201BL01     
         write(iunit,*) optl(i)                                         0201BL01
         i = i+1                                                        0201BL01              
         linkzero = .false.                                             0201BL01
          do 12 j=1,10                                                  0201BL01
            if (optl(i)(j:j) .eq. '%' ) then                            0201BL01
               linkzero = .true.                                        0201BL01
            endif                                                       0201BL01
12    CONTINUE                                                          0201BL01
      end do                                                            0201BL01



c
c

      if( type .eq. tener ) then

      if(esmeth(:12) .eq. 'qcisd(t)=e4t') then                          0201BL01
               write(iunit,1011) '#','qcisd(t,e4t,maxcycle=100)',       0201BL01
     *               '/',esbas(:bfin),'  ','FChk=All','NoSymm'          0201BL01

      else                                                              0201BL01
         write(iunit,1011) '#',esmeth(:mfin),'/',esbas(:bfin),
     *           '  ','FChk=All','NoSymm'
c     *           '  ','FChk=All',' '
      endif                                                             0201BL01


      elseif( type .eq. tgrad ) then

         if( esmeth(:4).eq.'mp4 ' .or.
     *        esmeth(:4).eq.'ccsd' .or. esmeth(:8).eq.'qcisd(t)' ) then
            if(esmeth(:12) .eq. 'qcisd(t)=e4t') then                    0201BL01
               write(iunit,1011) '#','qcisd(t,e4t,maxcycle=100)',       0201BL01
     *         '/',esbas(:bfin),'Force=EnOnly','FChk=All','NoSymm'      0201BL01
            else                                                        0201BL01
            write(iunit,1011) '#',esmeth(:mfin),'/',esbas(:bfin),
     *              'Force=EnOnly','FChk=All','NoSymm'
c     *              'Force=EnOnly','FChk=All',' '
            endif                                                       0201BL01
         else
            write(iunit,1011) '#',esmeth(:mfin),'/',esbas(:bfin),
     *              'Force','FChk=All','NoSymm'
c     *              'Force','FChk=All',' '
         endif



      elseif( type .eq. thess ) then
         write(iunit,1011) '#',esmeth(:mfin),'/',esbas(:bfin),
     *           'Freq=noraman','FChk=All','NoSymm'
c     *           'Freq=noraman','FChk=All',' '
      elseif( type .eq. topt ) then
         write(iunit,1012) '#',esmeth(:mfin),'/',esbas(:bfin),
     *           'FChk=All','NoSymm'
      endif

c     i = 1                                                             0201BL01
      do while (optl(i).ne.'   ' .and. i.le.5)
         write(iunit,1016) optl(i)
         i = i+1
      end do
c
c   MC3BB  BB95-39HF 
c
      if ( esmeth(:4).eq.'bb95') then
        write (iunit,1065) 
      endif       

1065  format('iop(3/76=0610003900)')

c
c   MC3MPW  mPWPW91-38HF
c
      if ( esmeth(:7).eq.'mpwpw91') then                                0808RMP12
        write (iunit,1066)                                              0808RMP12
      endif                                                             0808RMP12

1066  format('iop(3/76=0620003800)')

C   
C   Pseudo potentials  
c
      if (lgenecp.eq.1) then                                            1106RMP13
        write(iunit,1067)                                               1106RMP13
      endif                                                             1106RMP13
1067  format('Pseudo=read')                                             1106RMP13

      
c
c  Print out title
c
      if (type .eq. tener) then
         write(iunit,1021) 
      elseif (type .eq. tgrad) then
         write(iunit,1022)
      elseif (type .eq. thess) then
         write(iunit,1023)
      elseif (type .eq. topt) then
         write(iunit,1024)
      endif
c
c  Print out charge, multiplicity, and atomic symbols and coordinates
c
      write(iunit,1031) geom%charge, geom%mult
      do 20 i=1, geom%natoms
         write(iunit,1041) geom%atm(i), geom%angcoord(3*i-2),
     *      geom%angcoord(3*i-1), geom%angcoord(3*i)
  20  continue

      write(iunit,*)
c
c  Include basis set file at end of the input file if needed
c
      if (esbas(:3).eq.'gen') then
c         if (oldbas(:8).eq.'pdz+') then
c            write (iunit, 1051) '@', pDZsloc
         if (oldbas(:8).eq.'mpdz') then                                 0808RMP12
            write (iunit, 1051) '@', mpDZloc                            0808RMP12
         elseif (oldbas(:4).eq.'mg3s') then
            write (iunit, 1051) '@', mg3sloc
         elseif (oldbas(:3).eq.'mg3') then
            write (iunit, 1051) '@', mg3loc
         elseif (oldbas(:7).eq.'g3large') then
            write (iunit, 1051) '@', g3Lloc
         elseif (oldbas(:8).eq.'g3xlarge') then
            write (iunit, 1051) '@', g3XLloc
         elseif (lgenecp.eq.1) then                                     1106RMP13
            write (iunit, 1051) '@', genecp                             1106RMP13
         endif
      endif
c
c  Change the method and basis set name back if they've been changed
c
      if (esmeth(:11).eq.'ccsd(t)=e4t') then
         esmeth = 'ccsd(t)    '
      elseif (esmeth(:12).eq.'qcisd(t)=e4t') then
         esmeth = 'qcisd(t)    '
      endif
      if (esbas(:3).eq.'gen') then
         esbas = oldbas
      endif
c
c  Close the file
c
      close (iunit, err=9999)
      
      return

9999  write (outfile,*) 'Error creating Gaussian input file'
      stop 'g98inp'

1001  format (/)
1010  format (2a)
1011  format (4a,3(3x,a))
1012  format (4a,2(3x,a))
1016  format (a75)
1021  format (/'Single Point Energy Calculation'/)
1022  format (/'Gradient Calculation'/)
1023  format (/'Hessian Calculations'/)
1024  format (/'External Optimization'/)
1031  format (1x,i3,1x,i3)
1041  format (a2,5x,3(d16.9,3x))
1051  format (2a,/)

      end
c
c
c*****************************************************************************
c  G98OUTE
c*****************************************************************************
c
      subroutine g98oute (ppnum,esmeth, ener)
c
c     Subroutine g98oute
c     
c     Created:  June 28, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Get a single energy out of the Gaussian98 formatted
c        checkpoint file. (Also used for Gaussian94)
c
c     Called by:  progehk, progghk, proghhk
c     Calls:
c
c     Variables defined here:
c
      use files
      use numfmt
      implicit none
 
      character*20  esmeth                                                    0201BL01
      double precision  ener, cfltfmt
      integer enerfnd,ppnum,fchknum                                           1023BL00

      character*80 string, case
      character*30 label
      character*22 etxt
      character*14 fchkname                                                   1023BL00

      enerfnd = 0
c
c  Open the formatted checkpoint file.
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)            1023BL00

      read( fchknum, '(a80)', end=9910 ) string                               1023BL00
      string = case(string)
      label = string(:llen(efmt))
      etxt = string(nstrt(efmt):nstrt(efmt)+nlen(efmt)-1)

      do while( label(:12).ne.'total energy' )
         read( fchknum, '(a80)', end=9910 ) string                            1023BL00
         string = case(string)
         label = string(:llen(efmt))
         etxt = string(nstrt(efmt):nstrt(efmt)+nlen(efmt)-1)
      end do

      ener = cfltfmt(etxt,efmt)

      close( unit=fchknum )                                                   1023BL00

      return

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

      end
c
c
c*****************************************************************************
c  CFLTFMT
c*****************************************************************************
c
      function cfltfmt (number, fmt)
c
c     Function cfltfmt
c
c     Created:  June 28, 1999 by J. M. Rodgers
c               Partially based on Polyrate cfloat function
c     Revised:
c     Purpose:  Convert a string in the specified FChk format (fmt) into a
c        double precision number.
c
c     Called by:  g98oute, mg98oute, g98outg, g98outh, g98outo
c     Calls:
c
c     Variables defined here:
c
c
c  Figure out the type of floating point gathered from the formatted
c    checkpoint file and use the appropriate module.
c
      use numfmt
      use files, only : outfile
      implicit none

      double precision cfltfmt
      double precision sign, esign, f1, f2, f3
      integer i, j, n
      character*22  number
      character  ch
      integer fmt
c
c  Error checking - if decimal place and exponent place are incorrect exit
c
      if (number(inum(fmt)+1:inum(fmt)+1) .ne. '.') then
         write (outfile,1001) number
      endif
      if (number(decfin(fmt)+1:decfin(fmt)+1) .ne. 'e'
     *      .and.  number(decfin(fmt)+1:decfin(fmt)+1) .ne. 'd' ) then
         write (outfile,1001) number
      endif

1001  format('ERROR: This number has the wrong format.',5x,a)

c
c  Get sign of number
c
      if (number(isign(fmt):isign(fmt)).eq.'-') then
         sign = -1.0000d0
      else
         sign = +1.0000d0
      endif
c
c  Get sign of exponent
c
      if (number(iesign(fmt):iesign(fmt)).eq.'-') then
         esign = -1.0000d0
      else
         esign = +1.0000d0
      endif
c
c  Get number before decimal
c
      ch = number(inum(fmt):inum(fmt))
      n  = ichar(ch) - ichar('0')
      f1 = dble(n)
c
c  Get number after decimal
c
      f2 = 0.0000d0
      j = 0
      do 60 i=decbeg(fmt), decfin(fmt)
         ch = number(i:i)
         n  = ichar(ch) - ichar('0')         
         f2 = f2*10.0000d0 + dble(n)
         j  = j+1
  60  continue
      f2 = f2 / 10.0000d0 ** dble(j)
c
c  Get the exponent
c
      f3 = 0.0000d0
      do 80 i=expbeg(fmt), expfin(fmt)
         ch = number (i:i)
         n = ichar(ch) - ichar('0')
         f3 = f3*10.0000d0 + dble(n)
  80  continue

      cfltfmt = (sign*(f1+f2)) * 10.0000d0 ** (esign*f3)

      return

      end
c
c
c******************************************************************************
c MCOEHK
c******************************************************************************
c
      subroutine mcoehk(prognme,geom,mcoinp,optl)
c
c     Subroutine mcoehk
c
c     Created:  June 23, 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 calculation only.
c
c     Called by:  mcehk, optehk
c     Calls:  mprogehk, calmco, mcodisp
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mcinf
      use param
      use files, only : outfile
      use energy, only : mcener, eso, ecc, erel
      implicit none

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

      meth = mcoinp%meth
      bas1 = mcoinp%bas1
      bas2 = mcoinp%bas2
c
c  Initialize mcoes(5,2) to 0.0000d0
c
      do 20 i=1, 5
         esmeth(i) = '                    '
         do 40 j=1, 2
            mcoes(i,j) = 0.0000d0
  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

      do 50 i=1,max
         esmeth(i) = esmlist(mcoessw(i))
  50  continue
c
c  Make all calls to electronic structure program
c
      call mprogehk(1, prognme,esmeth(:max), bas2, geom, optl,           1022BL00
     *              max, mcoes(:max,2), ierr,ver_lab)
      call mprogehk(1, prognme,esmeth(:max), bas1, geom, optl,           1022BL00
     *              max, mcoes(:max,1), ierr,ver_lab)
c
c  Calculate the MCCM-CO energy with calmco using the energies gathered
c    in mcoes and the input coefficients.  Then set the position in the
c    mcener for the non-default MCCM-CO calculation equal to that energy.
c
      call calmco( mcener(pmco), mcoinp%coef(1:10), mcoes, max )
      mcener(pmco) = mcener(pmco) + eso + ecc + erel

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

      return
      end
c
c
c******************************************************************************
c MUTEHK
c******************************************************************************
c
      subroutine mutehk(prognme,geom,mutinp,optl)
c
c     Subroutine mutehk
c
c     Created:  June 23, 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 calculation only.
c
c     Called by:  mcehk, optehk
c     Calls:  mprogehk, calmut, mutdisp
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mcinf
      use param
      use files, only : outfile
      use energy, only : mcener, eso, ecc, erel
      implicit none

      character*10  prognme
      type (cartgeom) ::  geom
      type (mcinf)    ::  mutinp
      integer  ierr, max, i, j, mutessw(5)
      double precision  mutes(5,2)
      character*20  meth, bas1, bas2,ver_lab
      character*20  esmeth(5)                                                0201BL01
      character*80  optl(5)
      double precision blnkgrad(3*geom%natoms)
      double precision blnkhess(3*geom%natoms,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
         esmeth(i) = '                    '
         do 40 j=1, 2
            mutes(i,j) = 0.0000d0
  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

      do 50 i=1, max
         esmeth(i) = esmlist(mutessw(i))
  50  continue
c  
c  Make all calls to electronic structure program
c  
      call mprogehk(1, prognme,esmeth(1:2), bas2, geom, optl,            1022BL00
     *              2, mutes(1:2,2), ierr,ver_lab)
      call mprogehk(1, prognme,esmeth(:max), bas1, geom, optl,           1022BL00
     *              max, mutes(:max,1), ierr,ver_lab)
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

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

      return
      end
c
c
c******************************************************************************
c  MNMEHK
c******************************************************************************
c
      subroutine mnmehk(prognme,geom,mnminp,optl)
c
c     Subroutine mnmehk
c
c     Created:  June 23, 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 calculations only.
c
c     Called by:  mcehk, optehk
c     Calls:  mprogehk, calmnm, mnmdisp
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mcinf
      use files, only : outfile
      use param
      use energy, only : mcener, eso, ecc, erel
      implicit none

      character*10  prognme
      type (cartgeom) ::  geom
      type (mcinf)    ::  mnminp
      integer  ierr, max, i, j, mnmessw(5)
      double precision  mnmes(5,3)
      character*20  meth, bas1, bas2, bas3
      character*20  esmeth(5),ver_lab
      character*80  optl(5)
      double precision blnkgrad(3*geom%natoms)
      double precision blnkhess(3*geom%natoms,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
         esmeth(i) = '                    '
         do 40 j=1, 3
            mnmes(i,j) = 0.0000d0
  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 50 i=1, max
         esmeth(i) = esmlist(mnmessw(i))
  50  continue
c  
c  Make all calls to electronic structure program
c  
      call mprogehk(1, prognme,esmeth(1:2), bas3, geom, optl,            1022BL00
     *              2, mnmes(1:2,2), ierr,ver_lab)
      call mprogehk(1, prognme,esmeth(:max), bas1, geom, optl,           1022BL00            
     *              max, mnmes(:max,1), ierr,ver_lab)
      call mprogehk(1, prognme,esmeth(1:1), bas2, geom, optl,            1022BL00
     *              1, mnmes(1,3), ierr,ver_lab)
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

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

      return
      end
c
c
c******************************************************************************
c MCSEHK
c******************************************************************************
c
      subroutine mcsehk(prognme,geom,mcsinp,optl)
c
c     Subroutine mcsehk
c
c     Created:  June 23, 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 calculations only.
c
c     Called by:  mcehk, optehk
c     Calls:  mprogehk, calmcs, mcsdisp
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mcinf
      use param
      use files, only : outfile
      use energy, only : mcener, eso, ecc, erel
      implicit none

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

      meth = mcsinp%meth
      bas1 = mcsinp%bas1
c
c  Initialize mcses(5) to 0.0000d0
c
      do 20 i=1, 5
         esmeth(i) = '                    '
         mcses(i) = 0.0000d0
  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
         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

      do 50 i=1, max
         esmeth(i) = esmlist(mcsessw(i))
  50  continue
c        
c  Make all calls to electronic structure program
c
      call mprogehk(1, prognme,esmeth(:max), bas1, geom, optl,                    1022BL00
     *              max, mcses(:max), ierr,ver_lab)
c
c  Calculate the MCSAC energy with calmcs using the energies gathered
c    in mcses and the input coefficients.  Then set the position in the
c    mcener for the non-default MCSAC calculation equal to that energy.
c
      call calmcs( mcener(pmcs), mcsinp%coef(1:4), mcses, max )
      mcener(pmcs) = mcener(pmcs) + eso + ecc + erel

      call mcsdisp(mcsessw,max,mcsinp%bas1,mcses,blnkgrad,
     *               blnkhess,geom%natoms,tener)

      return
      end
c
c
c******************************************************************************
c IBEHK
c******************************************************************************
c
      subroutine ibehk(prognme,geom,ibinp,optl)
c
c     Subroutine ibehk
c
c     Created:  June 23, 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        calculations only.
c
c     Called by:  mcehk, optehk
c     Calls:  mprogehk, calib, ibdisp
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mcinf
      use files, only : outfile
      use param
      use energy, only : mcener, eso, ecc, erel
      implicit none

      character*10  prognme
      type (cartgeom) ::  geom
      type (mcinf)    ::  ibinp
      integer  ierr, max, i, j
      double precision  ibes(2,2)
      character*20  meth, bas1, bas2
      character*20  esmeth(2),ver_lab
      character*80  optl(5)
      double precision blnkgrad(3*geom%natoms)
      double precision blnkhess(3*geom%natoms,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
         esmeth(i) = '                    '
         do 40 j=1, 2
            ibes(i,j) = 0.0000d0
  40     continue
  20  continue

      esmeth(2) = meth
      esmeth(1) = esmlist(phf)
c
c  Make calls to the electronic structure program
c
      call mprogehk(1, prognme,esmeth, bas2, geom, optl,                          1022BL00 
     *                  2, ibes(:,2), ierr,ver_lab)                               0224BL02
      call mprogehk(1, prognme,esmeth, bas1, geom, optl,                          1022BL00
     *                  2, ibes(:,1), ierr,ver_lab)                               0224BL02
c
c  Calculate the IB energy with calib using the energies gathered
c    in ibes and the input coefficients.  Then set the position in the
c    mcener for the non-default IB calculation equal to that energy.
c
      call calib( mcener(pib), ibinp%coef(1), ibinp%coef(2), ibes )
      mcener(pib) = mcener(pib) + eso + ecc + erel

      call ibdisp(ibinp%meth,ibinp%bas1,ibinp%bas2,ibes,
     *              blnkgrad,blnkhess,geom%natoms,tener)

      return
      end
c
c
c******************************************************************************
c SACEHK
c******************************************************************************
c
      subroutine sacehk(prognme,geom,sacinp,optl)
c
c     Subroutine sacehk
c
c     Created:  June 23, 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        calculations only.
c
c     Called by:  mcehk, optehk
c     Calls:  mprogehk, calsac, sacdisp
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mcinf
      use files, only : outfile
      use param
      use energy, only : mcener, eso, ecc, erel
      implicit none

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

      meth = sacinp%meth
      bas1 = sacinp%bas1
c
c  Initialize saces(2) to 0.0000d0
c
      do 20 i=1, 2
         esmeth(i) = '                    '
         saces(i) = 0.0000d0
  20  continue

      esmeth(2) = meth
      esmeth(1) = esmlist(phf)
c
c  Make all calls to the electronic structure program
c
      call mprogehk(1, prognme,esmeth, bas1, geom, optl,                       1022BL00
     *                   2, saces, ierr, ver_lab)                              0224BL02
c
c  Calculate the SAC energy with calsac using the energies gathered
c    in saces and the input coefficients.  Then set the position in the
c    mcener for the non-default SAC calculation equal to that energy.
c
      call calsac( mcener(psac), sacinp%coef(1), saces )
      mcener(psac) = mcener(psac) + eso + ecc + erel

      call sacdisp(sacinp%meth,sacinp%bas1,saces,blnkgrad,
     *               blnkhess,geom%natoms,tener)

      return
      end
c  
c
c******************************************************************************
c  HFMOEHK
c******************************************************************************
c
      subroutine hfmoehk(hfprognme, moprognme, geom, hfmoinp, ierr)
c  
c     Subroutine hfmoehk
c
c     Created:  July 1, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine the HF||MO energy
c
c     Called by:  mlehook, optehk
c     Calls:  progehk, calhfmo, hfmodisp
c
c     Variables defined here:  none.
c
      use caltyp, only : tener
      use input, only : cartgeom, hfmoinf
      use param, only : esmlist, phf
      use files, only : outfile
      use energy, only : hfmoener
      implicit none
c
      character*10 hfprognme, moprognme
      type (cartgeom) :: geom
      type (hfmoinf)  :: hfmoinp
      integer ierr
      character*20 basem                                                0808RMP12
      basem="                    "                                      0808RMP12

      call progehk(hfprognme, esmlist(phf), hfmoinp%hfkbas, geom, 
     *                hfmoinp%hfkoptl, hfmoener(1), ierr)
C      call progehk(moprognme, hfmoinp%mokmeth, '   ', geom, 
      call progehk(moprognme, hfmoinp%mokmeth,basem,geom,               0808RMP12

     *                hfmoinp%mokoptl, hfmoener(2), ierr)

      call calhfmo(hfmoener(3),hfmoinp%frachf,hfmoener(1),hfmoener(2))

      call hfmodisp(geom%natoms, tener)

      return
      end
c
c
c******************************************************************************
c  CALHFMO
c******************************************************************************
c
      subroutine calhfmo(val, x, hfes, moes)
c
c     Subroutine hfmoehk
c
c     Created:  July 1, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To determine the HF||MO value
c
c     Called by:  hfmoehk, hfmoghk, hfmohhk
c     Calls: 
c    
c     Variables defined here:  none.
c
      implicit none
      double precision  val, x, hfes, moes

      val = x*hfes + (1-x)*moes

      return
      end

c
c******************************************************************************
c  G2EHK
c******************************************************************************
c
      subroutine g2ehk(prognme, geom, lmg2, g2inp, ierr)
c
c     Created:  July 14, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To get G2 energy
c
c     Called by:  mlehook, optehk
c     Calls:  mprogehk, calg, g2disp
c
c     Variables defined here:
c
      use caltyp
      use input, only : cartgeom, ginf
      use gparam
      use files, only : outfile
      use energy, only : g2es, g2ener

      implicit none

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

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

      double precision :: gethlc
c     
c  If an MCG2 calculation has already been done then a lot of the energies
c    have already been collected in g2es.
c  Definitions of each calculation called can be found in the module
c    gparam.
c
      if (lmg2 .eq. 1) then
         call mprogehk(1, prognme, g2esml(4:5), g2basl(4), geom,               1022BL00   
     *                  g2inp%optl, 2, g2es(4:5),ierr,ver_lab)
      else
         call mprogehk(1, prognme, g2esml(1:3), g2basl(1), geom,               1022BL00
     *                  g2inp%optl, 3, g2es(1:3), ierr,ver_lab)
         call mprogehk(1, prognme, g2esml(4:5), g2basl(4), geom,               1022BL00
     *                  g2inp%optl, 2, g2es(4:5), ierr,ver_lab)
         call mprogehk(1, prognme, g2esml(6:7), g2basl(6), geom,               1022BL00
     *                  g2inp%optl, 2, g2es(6:7), ierr,ver_lab)
         call mprogehk(1, prognme, g2esml(8), g2basl(8), geom,                 1022BL00
     *                  g2inp%optl, 1, g2es(8), ierr,ver_lab)
      endif

      g2es(phlc) = gethlc(g2inp%alpha, g2inp%beta, a, b)
c
c  No SO correction for g2
c
      g2es(pso)  = 0.0000d0
      
      call calg(g2ener, g2es)

      call g2disp(geom%natoms,tener)
      
      return
      end
c
c*****************************************************************************
c  GETHLC
c*****************************************************************************
c
      function gethlc(alpha, beta, c1, c2)
c
c     Function gethlc
c
c     Created:  July 14, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Calculate the HLC for G2 and G3.
c
c     Called by: g2ehk, g3ehk, g2ghk, g3ghk, g2hhk, g3hhk
c     Calls
c
c     Variables:  _alpha_ electrons and _beta_ electrons
c                 c1 = coefficient for electron pairs
c                 c2 = coefficient for unpaired electrons
c                 
      double precision gethlc, c1, c2, hlc
      integer alpha, beta   

      hlc = -c1*beta - c2*(alpha - beta)

      gethlc = hlc

      return
      end
c        
c*****************************************************************************
c  CALG
c*****************************************************************************
c
      subroutine calg (val, ges)
c
c     Subroutine calg
c
c     Created:  July 14, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Calculate the G2 or G3 values based on the electronic
c        structure values in ges containing the e.s. values and SO and HLC
c        
c     Take advantage of fact that G2 and G3 follow the same pattern of
c        differences.
c
c     Called by: g2ehk, g2ghk, g2hhk, g3ehk, g3ghk, g3hhk
c     Calls:
c
c     Variables defined here:
c     
      use caltyp
      use gparam, only : pso, phlc
      
      double precision  :: val, ges(10)
      double precision  :: deplus, de2dfp, delarge
c
c  Take all differences and get the G2 or G3 value
c
      deplus   = ges(5) - ges(2)
      de2dfp   = ges(7) - ges(2)
      delarge  = ges(8) - ges(6) - ges(4) + ges(1)

      val = 0.0000d0
      val = ges(3) + deplus + de2dfp + delarge + ges(phlc) + ges(pso)
      
      return
      end
c
c******************************************************************************
c  MG2EHK
c******************************************************************************
c
      subroutine mg2ehk(prognme, geom, mg2inp, ierr)
c
c     Created:  July 1, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To get MCG2 energies
c
c     Called by:  mlehook, optehk
c     Calls:  progehk, calmg, mg2disp
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mginf
      use gparam
      use energy, only : mg2ener,mg2es,eso,ecc,erel,g2es
      use files, only : outfile

      implicit none

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

c
c  Gather all the energies necessary to calculate MCG2 and MCCG2 energies.
c  Definitions of each calculation called can be found in the module
c    gparam.
c
      call mprogehk(1, prognme, mg2esml(1:5), mg2basl(1), geom,                   1022BL00
     *                  mg2inp%optl, 5, mg2es(1:5), ierr,ver_lab)
      call mprogehk(1, prognme, mg2esml(6:8), mg2basl(6), geom,                   1022BL00
     *                  mg2inp%optl, 3, mg2es(6:8), ierr,ver_lab)
      call mprogehk(1, prognme, mg2esml(9:10), mg2basl(9), geom,                  1022BL00
     *                  mg2inp%optl, 2, mg2es(9:10), ierr,ver_lab)
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)
c
c  Calculate the MCG2 energy
c
      call calmg2(mg2ener, mg2inp%mcoef, mg2es)
      mg2ener = mg2ener + eso + ecc + erel
c
      call mg2disp(geom%natoms,tener)

      return
      end
c
c******************************************************************************
c  G3EHK
c******************************************************************************
c
      subroutine g3ehk(prognme, geom, lmg3, g3inp, ierr)
c
c     Created:  July 6, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To get G3 energy.
c
c     Called by:  mlehook, optehk
c     Calls:  mprogehk, calg, g3disp
c
c     Variables defined here:
c
      use input, only : cartgeom, ginf
      use caltyp, only : tener
      use gparam
      use files, only : outfile
      use energy, only : g3es, g3ener

      implicit none

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

      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
c
c  If an MCG3 calculation has already been done then a lot of the energies
c    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 mprogehk(1, prognme, g3esml(4:5), g3basl(4), geom,               1022BL00
     *                  g3inp%optl, 2, g3es(4:5), ierr,ver_lab)                0224BL02
         call mprogehk(1, prognme, g3esml(7), g3basl(7), geom,                 1022BL00
     *                  g3inp%optl, 1, g3es(7), ierr,ver_lab)                  0224BL02
         call mprogehk(1, prognme, g3esml(8), g3basl(8), geom,                 1022BL00
     *                  g3inp%optl, 1, g3es(8), ierr,ver_lab)                  0224BL02
      else
         call mprogehk(1, prognme, g3esml(1:3), g3basl(1), geom,               1022BL00
     *                  g3inp%optl, 3, g3es(1:3), ierr,ver_lab)                0224BL02
         call mprogehk(1, prognme, g3esml(4:5), g3basl(4), geom,               1022BL00
     *                  g3inp%optl, 2, g3es(4:5), ierr,ver_lab)                0224BL02
         call mprogehk(1, prognme, g3esml(6:7), g3basl(6), geom,               1022BL00
     *                  g3inp%optl, 2, g3es(6:7), ierr,ver_lab)                0224BL02
         call mprogehk(1, prognme, g3esml(8), g3basl(8), geom,                 1022BL00
     *                  g3inp%optl, 1, g3es(8), ierr,ver_lab)                  0224BL02
      endif
c
c  Get the HLC and SO
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

      call calg(g3ener, g3es)

      call g3disp(geom%natoms,tener)

      return
      end

c
c******************************************************************************
c  G3SXMP3EHK
c******************************************************************************
c
      subroutine g3sxmp3ehk(prognme, geom, lmg3, g3sxmp3inp, ierr)
c
c     Created:  Oct. 12, by Yan Zhao 
c     Revised:
c     Purpose:  To get G3SXMP3 energies
c
c     Called by:  mlehook, optehk
c     Calls:  mprogehk  
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mginf
      use gparam
      use energy, only : eso,ecc,erel,g3sxmp3ener, g3sxmp3es
      use files, only : outfile

      implicit none

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

c
c  Gather all the energies necessary to calculate MCG2 and MCCG2 energies.
c  Definitions of each calculation called can be found in the module
c    gparam.
c
      call mprogehk(1, prognme, g3sxmp3esml(1:5), g3sxmp3basl(1), geom,   1022YZ03
     *        g3sxmp3inp%optl, 5, g3sxmp3es(1:5), ierr,ver_lab)
      call mprogehk(1, prognme, g3sxmp3esml(6:7), g3sxmp3basl(6), geom,   1022YZ03
     *        g3sxmp3inp%optl, 2, g3sxmp3es(6:7), ierr,ver_lab)
      call mprogehk(1, prognme, g3sxmp3esml(8:9), g3sxmp3basl(9), geom,   1022YZ03
     *        g3sxmp3inp%optl, 2, g3sxmp3es(8:9), ierr,ver_lab)
      call mprogehk(1, prognme, g3sxmp3esml(10), g3sxmp3basl(10), geom,   1022YZ03
     *        g3sxmp3inp%optl, 1, g3sxmp3es(10), ierr,ver_lab)

c
c  Calculate the G3SXMP3 energy
c
c      g3sxmp3ener = g3sxmp3es(1) +
c     *        g3sxmp3inp%g3sxmp3coef(1)*(g3sxmp3es(4)-g3sxmp3es(1))+
c     *        g3sxmp3inp%g3sxmp3coef(2)*(g3sxmp3es(5)-g3sxmp3es(4))+
c     *        g3sxmp3inp%g3sxmp3coef(3)*(g3sxmp3es(10)-g3sxmp3es(1))+
c     *        g3sxmp3inp%g3sxmp3coef(4)*(g3sxmp3es(9)-g3sxmp3es(8)-
c     *        g3sxmp3es(2)+g3sxmp3es(1))+
c     *        g3sxmp3inp%g3sxmp3coef(5)*(g3sxmp3es(7)-g3sxmp3es(6)-
c     *        g3sxmp3es(3)+g3sxmp3es(2))
c
      call calg3sxmp3(g3sxmp3ener, g3sxmp3inp%g3sxmp3coef, g3sxmp3es)
c
      call g3sxmp3disp(geom%natoms,tener)

      return
      end


c
c******************************************************************************
c     MC3BBEHK 
c******************************************************************************
c
      subroutine mc3bbehk(prognme, geom, lmg3, mc3bbinp, ierr)
c
c     Created:  Oct. 12, by Yan Zhao
c     Revised:
c     Purpose:  To get MC3BB energies
c
c     Called by:  mlehook, optehk
c     Calls:  mprogehk
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mginf
      use gparam
      use energy, only : eso,ecc,erel, mc3bbener, mc3bbes
      use files, only : outfile

      implicit none

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

c
c  Gather all the energies necessary to calculate MC3BB energies.
c  Definitions of each calculation called can be found in the module
c    gparam.
c
         
         call mprogehk(1, prognme, mc3bbesml(1:2), mc3bbbasl(1),geom,
     *                  mc3bbinp%optl, 2, mc3bbes(1:2),ierr,ver_lab)

         call mprogehk(1, prognme, mc3bbesml(3), mc3bbbasl(3),geom,
     *                  mc3bbinp%optl, 1, mc3bbes(3),ierr,ver_lab)

c
c  Calculate the MC3BB energy
c

       call calmc3bb(mc3bbener, mc3bbinp%mc3bbcoef, mc3bbes)
c
      call mc3bbdisp(geom%natoms,tener)

      return
      end

c
c******************************************************************************
c     MC3MPWEHK
c******************************************************************************
c
      subroutine mc3mpwehk(prognme, geom, lmg3, mc3mpwinp, ierr)
c
c     Created:  Oct. 12, by Yan Zhao
c     Revised:
c     Purpose:  To get MC3MPW energies
c
c     Called by:  mlehook, optehk
c     Calls:  mprogehk
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mginf
      use gparam
      use energy, only : eso,ecc,erel, mc3mpwener, mc3mpwes
      use files, only : outfile

      implicit none

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

c
c  Gather all the energies necessary to calculate MC3MPW energies.
c  Definitions of each calculation called can be found in the module
c    gparam.
c

         call mprogehk(1, prognme, mc3mpwesml(1:2), mc3mpwbasl(1),geom,
     *                  mc3mpwinp%optl, 2, mc3mpwes(1:2),ierr,ver_lab)

         call mprogehk(1, prognme, mc3mpwesml(3), mc3mpwbasl(3),geom,
     *                  mc3mpwinp%optl, 1, mc3mpwes(3),ierr,ver_lab)

c
c  Calculate the MC3MPW energy
c

       call calmc3mpw(mc3mpwener, mc3mpwinp%mc3mpwcoef, mc3mpwes)
c
      call mc3mpwdisp(geom%natoms,tener)

      return
      end




c
c*****************************************************************************
c  GETSO
c*****************************************************************************
c
      function getso(atom, charge)
c
c     Function getso
c
c     Created:  July 14, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Calculate the SO energy correction for G3.
c
c     Called by:  g3ehk, g3ghk, g3hhk
c     Calls:
c
c     Variables:
c
      implicit none

      double precision  getso, soener, soind(46)
      character*2  atom, atmind(46)
      integer  charge, chgind(46), i, fnd
c
c  Determine the spin-orbit correction for G3.
c  Corrections listed in the indices below were found in the original G3
c    paper, Table 1, for atomic species.
c  The SO correction is assumed to be zero for atoms not found in the
c    table.
c
      data atmind /'H ','He','Li','Be','B ','C ','N ','O ','F ',
     *   'Ne','Na','Mg','Al','Si','P ','S ','Cl','Ar','He','Li',
     *   'Be','B ','C ','N ','O ','F ','Ne','Na','Mg','Al','Si',
     *   'P ','S ','Cl','Ar','Li','B ','C ','O ','F ','Na','Al',
     *   'Si','P ','S ','Cl'/     
      data chgind / 0,   0,   0,   0,   0,   0,   0,   0,   0,
     *    0,   0,   0,   0,   0,   0,   0,   0,   0,   +1,  +1,
     *    +1,  +1,  +1,  +1,  +1,  +1,  +1,  +1,  +1,  +1,  +1,
     *    +1,  +1,  +1,  +1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,
     *    -1,  -1,  -1,  -1 /
      data soind  / 0.00d-3,  0.00d-3,  0.00d-3,  0.00d-3, -0.05d-3,
     *    -0.14d-3,  0.00d-3, -0.36d-3, -0.61d-3,  0.00d-3,  0.00d-3,
     *     0.00d-3, -0.34d-3, -0.68d-3,  0.00d-3, -0.89d-3, -1.34d-3,
     *     0.00d-3,  0.00d-3,  0.00d-3,  0.00d-3,  0.00d-3, -0.20d-3,
     *    -0.43d-3,  0.00d-3, -0.67d-3, -1.19d-3,  0.00d-3,  0.00d-3,
     *     0.00d-3, -0.93d-3, -1.43d-3,  0.00d-3, -1.68d-3, -2.18d-3,
     *     0.00d-3, -0.03d-3,  0.00d-3, -0.26d-3,  0.00d-3,  0.00d-3,
     *    -0.28d-3,  0.00d-3, -0.45d-3, -0.88d-3,  0.00d-3 /

      i = 1
      fnd = 0

      do while (fnd .ne. 1)
         if (i .gt. 46) then
            soener = 0.00d0
            fnd = 1
         elseif (atom.eq.atmind(i) .and. charge.eq.chgind(i)) then
            soener = soind(i)
            fnd = 1
         endif
         i = i+1
      end do

      getso = soener
 
      return
      end
c
c******************************************************************************
c  MQCEHK
c******************************************************************************
c
      subroutine mqcehk(prognme, geom, lmg3, mqcinp, ierr)
c
c     Created:  January 10, 2000 by P. L. Fast
c     Revised:  Feb 24, 2002 by B. J. Lynch
c     Purpose:  To get MC-QCISD energy.
c
c     Called by:  mlehook, optehk
c     Calls:  mprogehk, mqcdisp
c
c     Variables defined here:
c
      use input, only : cartgeom, mginf
      use caltyp, only : tener
      use gparam
      use files, only : outfile
      use energy, only : mqces, mqcener

      implicit none

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


      ver_lab = mqcinp%version


c
c  If an MCG3 calculation has already been done then three of the energies
c    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)       0224BL02
     *   .ne.'v3m'))then                                                0224BL02
         call mprogehk(1, prognme, mqcesml(3), mqcbasl(3), geom,        1022BL00
     *                  mqcinp%optl, 1, mqces(3), ierr,ver_lab)         0224BL02
      elseif((ver_lab(:3).eq.'v3s').or.(ver_lab(:3).eq.'v3m'))then      0224BL02
         call mprogehk(1, prognme, mqcesml_3(1:3), mqcbasl_3(1),geom,   0224BL02
     *                  mqcinp%optl, 3, mqces(1:3), ierr,ver_lab)       0224BL02
         call mprogehk(1, prognme, mqcesml_3(4), mqcbasl_3(4), geom,    0224BL02
     *                  mqcinp%optl, 2, mqces(4:5), ierr,ver_lab)       0224BL02
      else
         call mprogehk(1, prognme, mqcesml(1:3), mqcbasl(1), geom,      0224BL02
     *                  mqcinp%optl, 3, mqces(1:3), ierr,ver_lab)       0224BL02
         call mprogehk(1, prognme, mqcesml(4), mqcbasl(4), geom,        0224BL02
     *                  mqcinp%optl, 1, mqces(4), ierr,ver_lab)         0224BL02
      endif

      call calmqc(mqcener, mqcinp%mqcoef, mqces,ver_lab)
      call mqcdisp(geom%natoms,tener,ver_lab)
      return
      end
c
c******************************************************************************
c  MCOMP2EHK
c******************************************************************************
c
      subroutine mcomp2ehk(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.
c
c     Called by:  mlehook, optehk
c     Calls:  mprogehk, mcomp2disp
c
c     Variables defined here:
c
      use input, only : cartgeom, mginf
      use caltyp, only : tener
      use gparam
      use files, only : outfile
      use energy, only : mcomp2es, mcomp2ener

      implicit none

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

      ver_lab = mcomp2inp%version


c
c  If an MCG3 calculation has already been done then three of the energies
c    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                                             0224BL02 
c        call mprogehk(1, prognme, mcomp2esml(3), mcomp2basl(3), geom,  0224BL02
c    *                  mcomp2inp%optl, 1, mcomp2es(3), ierr,ver_lab)   0224BL02
c     else                                                              0224BL02




         call mprogehk(1, prognme, mcomp2esml(1:2), mcomp2basl(1),geom, 1022BL00
     *                  mcomp2inp%optl, 2, mcomp2es(1:2),ierr,ver_lab)  0224BL02

         if ((mcomp2inp%version(1:3).eq.'v3m').or.                      0224BL02
     *        (mcomp2inp%version(1:3).eq.'v3s'))   then                 0224BL02
         call mprogehk(1, prognme, mcomp2esml_3(3:4),mcomp2basl_3(3),   0224BL02
     *                geom,mcomp2inp%optl,2,mcomp2es(3:4),ierr,ver_lab) 0224BL02
         else                                                           0224BL02
         call mprogehk(1, prognme, mcomp2esml(3:4), mcomp2basl(3),geom, 1022BL00
     *                  mcomp2inp%optl, 2, mcomp2es(3:4),ierr,ver_lab)  0224BL02

         endif


c     endif                                                             0224BL02

      call calmcomp2(mcomp2ener, mcomp2inp%mcomp2coef, mcomp2es)
      call mcomp2disp(geom%natoms,tener,ver_lab)

      return
      end

c******************************************************************************
c  MCCOEHK
c******************************************************************************
c
      subroutine mccoehk(prognme, geom, lmg3, mccoinp, ierr)
c
c     Created:  July 12, 2002 by B. J. Lynch
c     Revised:  
c     Purpose:  To get MCCO energy
c
c     Called by:  mlehook, optehk
c     Calls:  mprogehk, mccodisp
c
c     Variables defined here:
c
      use input, only : cartgeom, mginf
      use caltyp, only : tener
      use gparam
      use files, only : outfile
      use energy, only : mccoes, mccoener

      implicit none

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

      ver_lab = mccoinp%version


         call mprogehk(1, prognme, mccoesml(1:2), mccobasl(1),geom,     
     *                  mccoinp%optl, 2, mccoes(1:2),ierr,ver_lab)    

         call mprogehk(1, prognme, mccoesml(3:4), mccobasl(3),geom,     
     *                  mccoinp%optl, 2, mccoes(3:4),ierr,ver_lab)      


      call calmcco(mccoener, mccoinp%mccocoef, mccoes)
      call mccodisp(geom%natoms,tener,ver_lab)

      return
      end

c
c******************************************************************************
c  MG3EHK
c******************************************************************************
c
      subroutine mg3ehk(prognme, geom, mg3inp, ierr)
c
c     Created:  July 6, 1999 by J. M. Rodgers
c     Revised:  Feb 24, 2002 by B. J. Lynch
c     Purpose:  To get MCG3 energies
c
c     Called by:  mlehook, optehk
c     Calls:  mprogehk, calmg, mg3disp
c
c     Variables defined here:
c
      use caltyp, only : tener
      use input, only : cartgeom, mginf
      use gparam
      use energy, only : mg3ener,mg3es,eso,ecc,erel,g3es,mqces,mqcener    
      use files, only : outfile

      implicit none

      character*20     ver_lab,tempml(6),ver_lab2
      character*10     :: prognme
      double precision tempes(6) 
      type (cartgeom)  :: geom
      type (mginf)     :: mg3inp,mqcinp
      integer          :: ierr, i

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


c
c     parallel version of code implemented 10/22/00 by B. Lynch
      if (prognme(:4).eq.'pg98') then
c  Parallel excecution of MCG3 using OpenMP
c   
c  
c 

!$OMP PARALLEL SECTIONS
!$OMP SECTION
      do i=1,4
      tempml(i)=mg3esml(i)
      enddo
      tempml(5)=mqcesml(3)
      tempml(6)=mg3esml(5)
      call mprogehk(1, prognme, tempml(1:6), mg3basl(1), geom,             
     *               mg3inp%optl, 6, tempes(1:6), ierr,ver_lab)
      do i=1,4
      mg3es(i)=tempes(i)
      enddo
      mg3es(5)=tempes(6)
      mqces(3)=tempes(5) 
      call mprogehk(1, prognme, mg3esml(6:7), mg3basl(6), geom,
     *               mg3inp%optl, 2, mg3es(6:7), ierr,ver_lab)

!$OMP SECTION

      call mprogehk(2, prognme, mg3esml(8:9), mg3basl(8), geom,
     *               mg3inp%optl, 2, mg3es(8:9), ierr,ver_lab)
      mqces(1) = mg3es(1)                                               0110PF00
      mqces(2) = mg3es(2)                                               0110PF00
      mqces(4) = mg3es(9) 
!$OMP END PARALLEL SECTIONS         

c
c  end of parallel MCG3 code
c



      elseif ((ver_lab(:3).eq.'v3m').or.(ver_lab(:3).eq.'v3s')) then
      do i=1,3
      tempml(i)=mg3esml_3(i)
      enddo
      tempml(4)= mqcesml(3)
      tempml(5)= mg3esml_3(4)
      call mprogehk(1, prognme, tempml(1:5), mg3basl_3(1), geom,        0224BL02
     *               mg3inp%optl, 5, tempes(1:5), ierr,ver_lab)         0224BL02
      do i=1,3
       mg3es(i)=tempes(i)
      enddo
      mg3es(4)=tempes(5)
      mqces(3)=tempes(4)

      call mprogehk(1, prognme, mg3esml_3(5:6), mg3basl_3(5), geom,     0224BL02
     *               mg3inp%optl, 2, mg3es(5:6), ierr,ver_lab)          0224BL02
      call mprogehk(1, prognme, mg3esml_3(7:8), mg3basl_3(7), geom,     0224BL02
     *               mg3inp%optl, 2, mg3es(7:8), ierr,ver_lab)          0224BL02



      else
      do i=1,4
      tempml(i)=mg3esml(i)
      enddo
      tempml(5)=mqcesml(3)
      tempml(6)=mg3esml(5)
      call mprogehk(1, prognme, tempml(1:6), mg3basl(1), geom,          1022BL00
     *               mg3inp%optl, 6, tempes(1:6), ierr,ver_lab)         0224BL02
       do i=1,4
       mg3es(i)=tempes(i)
       enddo
       mg3es(5)=tempes(6)
       mqces(3)=tempes(5)

      call mprogehk(1, prognme, mg3esml(6:7), mg3basl(6), geom,         1022BL00
     *               mg3inp%optl, 2, mg3es(6:7), ierr,ver_lab)          0224BL02
      call mprogehk(1, prognme, mg3esml(8:9), mg3basl(8), geom,         1022BL00
     *               mg3inp%optl, 2, mg3es(8:9), ierr,ver_lab)          0224BL02
      endif


c
c  Pass on some energies to g3es so won't have to be recalculated in g3 is
c    also selected.
C
C   this sharing is not yet enabled for version 3 coefficients
c
C      g3es(1) = mg3es(2)
C      g3es(2) = mg3es(4)
C      g3es(3) = mg3es(5)
C      g3es(6) = mg3es(6)
c
c  Pass on some energies to mqces to avoid recalculating if mcqcisd is selected.
c
      mqces(1) = mg3es(1)                                               0110PF00
      mqces(2) = mg3es(2)                                               0110PF00
      if ((ver_lab(:3).eq.'v3m').or.(ver_lab(:3).eq.'v3s')) then
      mqces(4) = mg3es(7)                                               0110PF00
      mqces(5) = mg3es(8)
      else
      mqces(4) = mg3es(9) 
      endif
c
c  Calculate the MCG3 energy
c
      call calmg3(mg3ener, mg3inp%mcoef, mg3es,ver_lab)
      mg3ener = mg3ener + eso + ecc + erel
      call definemqc(ver_lab, mqcinp%mqcoef,ver_lab2)
      call calmqc(mqcener, mqcinp%mqcoef, mqces,ver_lab2)
      call mqcdisp(geom%natoms,tener,ver_lab)
      call mg3disp(geom%natoms,tener,ver_lab)

      return
      end
c    
c******************************************************************************
c  CALMQC               
c******************************************************************************
c    
      subroutine calmqc(val,c,mqes,ver_lab)
c    
c     Created:  January 10, 2000 by P. L. Fast
c     Revised:  Feb 24, 2002 B. J. Lynch 
c     Purpose:  To calculate the MC-QCISD value (without the SO and CC 
c        contributions) based on the given
c        electronic structure calculations in mqces and the coefficients
c        in c.  Can calculate energies, gradient components, or hessian
c        components.
c 
c
c     Called by:  mqcehk, mqcghk, mqchhk
c     Calls: 
c
c     Variables defined here:
c
      use files, only : outfile

      character*20 ver_lab
      double precision  :: val, c(4), mqes(5)
      integer           :: i

c
c  The definition of what each portion of mqes is can be found in the
c    module gparam.
c

      if((ver_lab(:3).eq.'v3s').or.(ver_lab(:3).eq.'v3m'))then
      val = mqes(1)
     *    + c(1)*(mqes(4)-mqes(1))
     *    + c(2)*(mqes(2)-mqes(1))
     *    + c(3)*(mqes(5)+mqes(1)-mqes(4)-mqes(2))
     *    + c(4)*(mqes(3)-mqes(2))
      else
      val = c(1)*mqes(1) + c(2)*(mqes(2)-mqes(1))
     *    + c(3)*(mqes(4)-mqes(2))
     *    + c(4)*(mqes(3)-mqes(2))
      endif
      return
      end
c
c******************************************************************************
c  CALMCOMP2
c******************************************************************************
c
      subroutine calmcomp2(val,c,mqes)
c   
c     Created:  January 10, 2000 by P. L. Fast
c     Revised:  July 10, 2000 by Jingzhi Pu 
c     Purpose:  To calculate the MCOMP2 value (without the SO and CC
c        contributions) based on the given
c        electronic structure calculations in mqces and the coefficients
c        in c.  Can calculate energies, gradient components, or hessian
c        components.
c
c
c     Called by:  mcomp2ehk, mcomp2ghk, mcomp2hhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile

      double precision  :: val, c(4), mqes(5)
      integer           :: i

c
c  The definition of what each portion of mqes is can be found in the
c    module gparam.
c
      val = c(1)*mqes(1) + c(2)*(mqes(3)-mqes(1))                       0711PJ00                      
     *    + c(3)*(mqes(2)-mqes(1))                                      0711PJ00
     *    + c(4)*((mqes(4)-mqes(2)) - (mqes(3)-mqes(1)))                0711PJ00

      return
      end



c******************************************************************************
c  CALMCCO
c******************************************************************************
c
      subroutine calmcco(val,c,mqes)
c   
c     Created:  July 12, 2002 by B. J. Lynch
c     Revised:  
c     Purpose:  To calculate the MCCO value (without the SO and CC
c        contributions) based on the given
c        electronic structure calculations in mqces and the coefficients
c        in c.  Can calculate energies, gradient components, or hessian
c        components.
c
c
c     Called by:  mccoehk, mccoghk, mccohhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile

      double precision  :: val, c(4), mqes(5)
      integer           :: i

c
c  The definition of what each portion of mqes is can be found in the
c    module gparam.
c
      val = c(1)*mqes(1) + c(2)*(mqes(3)-mqes(1))           
     *    + c(3)*(mqes(2)-mqes(1))              
     *    + c(4)*((mqes(4)-mqes(2)) - (mqes(3)-mqes(1))) 

      return
      end





c******************************************************************************
c  CALG3SXMP3
c******************************************************************************
c
      subroutine calg3sxmp3(val,c,mqes)
c
c     Created:  July 12, 2003 by  Yan Zhao
c     Revised:
c     Purpose:  To calculate the G3SX(MP3) value (without the SO and CC
c        contributions) based on the given
c        electronic structure calculations in mqces and the coefficients
c        in c.  Can calculate energies, gradient components, or hessian
c        components.
c
c
c     Called by: g3sxmp3ehk,g3sxmp3ghk,g3sxmp3hhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile

      double precision  :: val, c(5), mqes(10)
      integer           :: i

c
c  The definition of what each portion of mqes is can be found in the
c    module gparam.
c
       val = mqes(1) +
     *        c(1)*(mqes(4)-mqes(1))+
     *        c(2)*(mqes(5)-mqes(4))+
     *        c(3)*(mqes(10)-mqes(1))+
     *        c(4)*(mqes(9)-mqes(8)- mqes(2)+ mqes(1))+
     *        c(5)*(mqes(7)-mqes(6)-mqes(3)+mqes(2))

      return
      end



c******************************************************************************
c  CALMC3BB
c******************************************************************************
c
      subroutine calmc3bb(val,c,mqes)
c
c     Created:  July 12, 2003 by  Yan Zhao 
c     Revised:
c     Purpose:  To calculate the MC3BB value (without the SO and CC
c        contributions) based on the given
c        electronic structure calculations in mqces and the coefficients
c        in c.  Can calculate energies, gradient components, or hessian
c        components.
c
c
c     Called by:  mc3bbehk, mc3bbghk, mc3bbhhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile

      double precision  :: val, c(2), mqes(3)
      integer           :: i

c
c  The definition of what each portion of mqes is can be found in the
c    module gparam.
c
      val = c(1)*(mqes(1) + c(2)*(mqes(2)-mqes(1)))
     *    + (1-c(1))*mqes(3)

      return
      end


c******************************************************************************
c  CALMC3MPW
c******************************************************************************
c
      subroutine calmc3mpw(val,c,mqes)
c
c     Created:  July 12, 2003 by  Yan Zhao
c     Revised:
c     Purpose:  To calculate the MC3MPW value (without the SO and CC
c        contributions) based on the given
c        electronic structure calculations in mqces and the coefficients
c        in c.  Can calculate energies, gradient components, or hessian
c        components.
c
c
c     Called by:  mc3mpwehk, mc3mpwghk, mc3mpwhhk
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile

      double precision  :: val, c(2), mqes(3)
      integer           :: i

c
c  The definition of what each portion of mqes is can be found in the
c    module gparam.
c
      val = c(1)*(mqes(1) + c(2)*(mqes(2)-mqes(1)))
     *    + (1-c(1))*mqes(3)

      return
      end


c     
c******************************************************************************
c  CALMG2
c******************************************************************************
c     
      subroutine calmg2(val,c,mges)
c     
c     Created:  July 6, 1999 by J. M. Rodgers
c     Revised:  
c     Purpose:  To calculated MCG2 values
c        (without the SO and CC contributions) based on the given 
c        electronic structure calculations in mges and the coefficients
c        in c.  Can calculate energies, gradient components, or hessian
c        components.
c  
c     Called by:  mg2ehk, mg2ghk, mg2hhk 
c     Calls:  
c
c     Variables defined here:
c
      use files, only : outfile

      double precision  :: val, c(9), mges(10)
      integer           :: i

c
c  The definition of what each portion of mges is can be found in the
c    module gparam.
c
      val = c(1)*mges(1) + c(2)*(mges(9)-mges(1))
     *     + c(3)*(mges(2)-mges(1)) 
     *     + c(4)*(mges(10)-mges(9)-mges(2)+mges(1))
     *     + c(5)*(mges(3)-mges(2))
     *     + c(6)*(mges(7)-mges(6)-mges(3)+mges(2))
     *     + c(7)*(mges(4)-mges(3))
     *     + c(8)*(mges(8)-mges(7)-mges(4)+mges(3))
     *     + c(9)*(mges(5)-mges(4))

      return
      end
c
c******************************************************************************
c  CALMG3
c******************************************************************************
c
      subroutine calmg3(val,c,mges,ver_lab)
c
c     Created:  July 6, 1999 by J. M. Rodgers
c     Revised:  Feb 24, 2002 by B. J. Lynch
c     Purpose:  To calculated MCG3 values
c
c        (without the SO and CC contributions) based on the given
c        electronic structure calculations in mges and the coefficients
c        in c.  Can calculate energies, gradient components, or hessian
c        components.
c 
c     Called by:  mg3ehk, mg3ghk, mg3hhk 
c     Calls:
c
c     Variables defined here:
c
      use files, only : outfile

      character*20 ver_lab
      double precision  :: val, c(8), mges(9)
      integer           :: i

c
c  The definition of what each portion of mges is can be found in the
c    module gparam.
c

      if ((ver_lab(:3).eq.'v3m').or.(ver_lab(:3).eq.'v3s'))then
      val = c(1)*mges(1) + c(2)*(mges(7)-mges(1))
     *     + c(3)*(mges(2)-mges(1))
     *     + c(4)*(mges(8)-mges(7)-mges(2)+mges(1))
     *     + c(5)*(mges(3)-mges(2))
     *     + c(6)*(mges(6)-mges(5)-mges(3)+mges(2))
     *     + c(7)*(mges(4)-mges(3))

      else
      val = c(1)*mges(1) + c(2)*(mges(8)-mges(1))
     *     + c(3)*(mges(2)-mges(1))
     *     + c(4)*(mges(9)-mges(8)-mges(2)+mges(1))
     *     + c(5)*(mges(3)-mges(2))
     *     + c(6)*(mges(7)-mges(6)-mges(3)+mges(2))
     *     + c(7)*(mges(4)-mges(3))
     *     + c(8)*(mges(5)-mges(4))
      endif
      return
      end
c
c
c*****************************************************************************
c  MPROGEHK
c*****************************************************************************
c
      subroutine mprogehk(ppnum,prognme,esmeth,esbas,geom,optl,          1022BL00
     *   nume,ener,ierr,ver_lab)
c
c     Subroutine mprogehk
c
c     Created:  July 6, 1999 by J. M. Rodgers
c     Revised:  Feb 24, 2002 by B. J. Lynch
c     Purpose:  Get a single point energy at each theory level specified
c        in esmeth for the given geom with the specified electronic
c        structure package.  Based on the assumption that the
c        highest level theory is in the last space of esmeth and ener.
c
c     Description:  Calls a function to write a G94/98 SPE input file,
c         runs this calculation on the system, and then calls a fxn that
c         reads the energies from the formatted checkpoint file created by
c         G94/98.
c
c     Note:  Currently only G94 and G98 is 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:  esparse, mcoehk, mutehk, mnmehk, mcsehk, ibehk, sacehk,
c        mg3ehk, mg2ehk, g3ehk, g2ehk, mqcehk, mcomp2ehk, mccoehk        0711PJ00
c     Calls:  g98inp, system, mg98oute
c
c     Variables defined here:
c
      use caltyp
      use files
      use param, only : numes
      use input, only : cartgeom
      implicit none

      character*10 prognme
      character*20 ver_lab                                              0224BL02
      character*20 esmeth(nume)
      character*20 esbas                                                0201BL01
      type (cartgeom) :: geom
      character*80 optl(5)
      double precision ener(nume)
      integer ierr, nume, i, ppnum

c
c  G98
c
      if (prognme(:3).eq.'g98') then
        open (unit=g98inf, status='unknown', file=g98in, err=9991)
        call g98inp(g98inf,esmeth(nume),esbas,geom,optl,tener,ver_lab)
        close (g98inf, err=9991)
        call system('./g98shuttle g98.inp g98.out')
        call mg98oute(1, esmeth, nume, ener,ver_lab)

c
c  Parallel G98     10-23-00 B. Lynch
c

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

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
c

      if (ppnum .eq. 1) then
         open (unit=g98inf, status='unknown', file=g98in, err=9991)
         call g98inp(g98inf, esmeth(nume), esbas, geom, optl, tener
     *, ver_lab)
         close (g98inf, err=9991)
         call system('./g98shuttle g98.inp g98.out')
         call mg98oute(ppnum, esmeth, nume, ener,ver_lab)

      elseif (ppnum .eq. 2) then
         open (unit=g98in2f, status='unknown', file=g98in2, err=9991)
         call g98inp(g98in2f, esmeth(nume), esbas, geom, optl, tener
     *, ver_lab)
         close (g98in2f, err=9991)
         call system('pg98shuttle g98_2.inp g98_2.out')
         call mg98oute(ppnum, esmeth, nume, ener,ver_lab)
      endif



c
c  G94        
c    Just reuse g98inp and mg98oute 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(nume),esbas,geom,optl,tener,
     *  ver_lab)
         close (g94inf, err=9992)
         call system('./g94shuttle g94.inp g94.out')
         call mg98oute(1, esmeth, nume, ener,ver_lab)


c
c  G03
c    Just reuse g98inp and mg98oute 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(nume),esbas,geom,optl,tener,
     *  ver_lab)
         close (g03inf, err=9993)
         call system('./g03shuttle g03.inp g03.out')
         call mg98oute(1, esmeth, nume, ener,ver_lab)                      1409ZY03

c
c  G09                                                                  0808RMP12
c
      elseif (prognme(:3).eq.'g09') then
         open (unit=g09inf, status='unknown', file=g09in, err=9994)
         call g98inp(g09inf,esmeth(nume),esbas,geom,optl,tener,
     *  ver_lab)
         close (g09inf, err=9994)
         call system('./g09shuttle g09.inp g09.out')
         call mg98oute(1, esmeth, nume, ener,ver_lab)                      1409ZY03

      endif

      return

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


      end
c
c*****************************************************************************
c  MG98OUTE
c*****************************************************************************
c
      subroutine mg98oute (ppnum, esmeth, nume, ener,ver_lab)
c
c     Subroutine mg98oute
c     
c     Created:  July 6, 1999 by J. M. Rodgers
c     Revised:  October 23, 2000 by B. J. Lynch
c     Purpose:  Get a total of nume energies out of the Gaussian98
c        formatted checkpoint file.  Based on the assumption that the
c        highest level theory is in the last space of esmeth and ener.
c
c     Called by:  mprogehk, progehk, progghk, proghhk
c     Calls:
c
c     Variables defined here:
c
      use param, only : numes
      use files
      use numfmt
      implicit none
c 
c  Note: nume is the number of energies to be collected by this fxn.
c
      integer  nume, enerfnd(nume), i, fnd, ppnum, fchknum
      character*20  esmeth(nume)                                              0201BL01
      character*20  ver_lab                                                   0224BL02
      double precision  ener(nume), cfltfmt

      character*80 string, case
      character*30 label
      character*22 etxt
      character*14 fchkname

      do 20 i=1, nume                                                         0809BL00
         enerfnd(i) = 0
  20  continue

      fnd = 0

c
c  Open the formatted checkpoint file.
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)
      label = string(:llen(efmt))
      etxt = string(nstrt(efmt):nstrt(efmt)+nlen(efmt)-1)
c
c  For each line before the end of the energy section, check if the intro
c    matches with a know introductory phrase for a method being looked
c    for.  If so assign the energy on that line to the correct slot in
c    ener.
c
      do while( label(:12).ne.'total energy' .and. fnd.lt.nume )
         read( fchknum, '(a80)', end=9910 ) string           
         string = case(string)
         label = string(:llen(efmt))
         etxt = string(nstrt(efmt):nstrt(efmt)+nlen(efmt)-1)
         i = 1
         do while (i.le.nume .and. fnd.lt.nume)
            if (enerfnd(i) .eq. 1) then
               i = i+1
            else
               if (esmeth(i)(:2).eq.'hf' .and. 
     *              label(:10).eq.'scf energy') then
                  enerfnd(i) = 1
               elseif (esmeth(i)(:3).eq.'mp2' .and. 
     *              label(:10).eq.'mp2 energy') then
                  enerfnd(i) = 1
               elseif (esmeth(i)(:3).eq.'mp3' .and.
     *              label(:10).eq.'mp3 energy') then
                  enerfnd(i) = 1
               elseif (esmeth(i)(:6).eq.'mp4sdq' .and.
     *              label(:13).eq.'mp4sdq energy') then
                  enerfnd(i) = 1
               elseif (esmeth(i)(:3).eq.'mp4' .and.
     *              label(:10).eq.'mp4 energy') then
                  enerfnd(i) = 1
               elseif (esmeth(i)(:7).eq.'ccsd(t)' .and.
     *              label(:27).eq.'cluster energy with triples') then
                  enerfnd(i) = 1
               elseif (esmeth(i)(:8).eq.'qcisd(t)' .and.
     *              label(:27).eq.'cluster energy with triples') then
                  enerfnd(i) = 1
               elseif (esmeth(i)(:5).eq.'ccsd ' .and.
     *              label(:18).eq.'cluster energy    ') then
                  enerfnd(i) = 1
               elseif (esmeth(i)(:6).eq.'qcisd ' .and.
     *              label(:18).eq.'cluster energy    ') then
                  enerfnd(i) = 1
               endif
               if (enerfnd(i).eq.1) then
                  ener(i) = cfltfmt(etxt,efmt)
                  fnd = fnd+1
               endif
               i = i+1
            endif
         end do
      end do
c
c  If the highest level energy was not found, assign it the value from the
c    line with 'total energy'
c
      if (enerfnd(nume).eq.0)  then
         do while( label(:12).ne.'total energy' )
            read( fchknum, '(a80)', end=9910 ) string
            string = case(string)
            label = string(:llen(efmt))
            etxt = string(nstrt(efmt):nstrt(efmt)+nlen(efmt)-1)
         enddo
         ener(nume) = cfltfmt(etxt,efmt)
         enerfnd(nume) = 1
      endif
c
c  Make sure got all energies.
c
      do 40 i=1, nume
         if (enerfnd(i) .eq. 0) then
            write (outfile, 9800) esmeth(i)
9800        format ('ERROR: Problem getting energy with ',a)
            stop 'mg98oute 3'
         endif
  40  continue

      close( unit=fchknum )

      return

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

      end
c
c******************************************************************************
c  IMOHCEHK
c******************************************************************************
c
      subroutine imohcehk(hlprognme, llprognme, geom, imohcinp, ierr)
c
c     Subroutine imohcehk
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
c
c     Called by:  mlehook, optehk
c     Calls:  progehk, hnrg, imohcdisp
c  
c     Variables defined here:  none.
c
      use caltyp, only : tener
      use input, only : cartgeom, imoinf
      use files, only : outfile
      use energy, only : imohcener, imohces
      implicit none
c
      character*10 hlprognme, llprognme
      type (cartgeom) :: geom, lsgeom, ssgeom
      type (imoinf)  :: imohcinp
      integer ierr, lsnatm, ssnatm
      double precision  r, theta, phi, dumg(12), dumh(12,12)
c
c  Assign the appropriate geometries to lsgeom and ssgeom
c
      call hcgeom(geom,lsgeom,ssgeom, imohcinp%lsatm, imohcinp%lsnatm,
     *       imohcinp%ssatm, imohcinp%ssnatm)
c
c  High level calculation on the small system
c
      call progehk(hlprognme, imohcinp%hlmeth, imohcinp%hlbas, ssgeom,
     *                imohcinp%hloptl, imohces(1), ierr)
c
c  Low level calculation on the large system
c
      call progehk(llprognme, imohcinp%llmeth, imohcinp%llbas, lsgeom,
     *                imohcinp%lloptl, imohces(2), ierr)
c
c  Low level calculation on the small system
c
      call progehk(llprognme, imohcinp%llmeth, imohcinp%llbas, ssgeom,
     *                imohcinp%lloptl, imohces(3), ierr)
c
c  Calculate the IMOMO energy
c
      imohcener = imohces(1) + imohces(2) - imohces(3)
c
c  Call subroutine HNRG to calculate the harmonic contributions to the total
c    energy.  HNRG alters imohcener within.
c
      call hnrg( geom, imohcinp%bond, imohcinp%angle, imohcinp%tors, 
     *             r, theta, phi)
c
c  Display results
c
      call imohcdisp(r,theta,phi,dumg(:6),dumg(:9),dumg(:12),
     *   dumh(:6,:6),dumh(:9,:9),dumh(:12,:12),imohcinp%ssnatm,
     *   imohcinp%lsnatm,tener)

      return
      end
c
c
c******************************************************************************
c  HCGEOM
c******************************************************************************
c
      subroutine hcgeom(geom,lsgeom,ssgeom, lsatm, lsnatm, 
     *    ssatm, ssnatm)

c
c     Subroutine hcgeom
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 assign appropriate geometries to lsgeom and ssgeom
c
c     Called by:  imohcehk, imohcghk, imohchhk
c     Calls:
c
c     Variables defined here:  none.
c
      use input, only : cartgeom
      implicit none

      type (cartgeom) :: geom, lsgeom, ssgeom
      integer :: lsnatm, ssnatm, lsatm(lsnatm), ssatm(ssnatm), i
      double precision, parameter :: angtoau = 0.52918d0
c
c  Assign the entire system's geometry to lsgeom
c  
      lsgeom%natoms = lsnatm
      lsgeom%charge = geom%charge
      lsgeom%mult = geom%mult
      do 20 i=1, lsnatm
         lsgeom%atm(i) = geom%atm(lsatm(i))
         lsgeom%atmmss(i) = geom%atmmss(lsatm(i))
         lsgeom%angcoord(3*i-2) = geom%angcoord(3*lsatm(i)-2)
         lsgeom%angcoord(3*i-1) = geom%angcoord(3*lsatm(i)-1)
         lsgeom%angcoord(3*i) = geom%angcoord(3*lsatm(i))
  20  continue
      lsgeom%aucoord(:lsnatm) =  lsgeom%angcoord(:lsnatm)/angtoau
c  
c  Assign the small system's geometry to ssgeom
c
      ssgeom%natoms = ssnatm
      ssgeom%charge = geom%charge
      ssgeom%mult = geom%mult
      do 40 i=1, ssnatm
         ssgeom%atm(i) = geom%atm(ssatm(i))
         ssgeom%atmmss(i) = geom%atmmss(ssatm(i))
         ssgeom%angcoord(3*i-2) = geom%angcoord(3*ssatm(i)-2)
         ssgeom%angcoord(3*i-1) = geom%angcoord(3*ssatm(i)-1)
         ssgeom%angcoord(3*i) = geom%angcoord(3*ssatm(i))
  40  continue
      ssgeom%aucoord(:ssnatm) =  ssgeom%angcoord(:ssnatm)/angtoau

      return
      end
c
c******************************************************************************
c  HNRG
c******************************************************************************
c
      subroutine hnrg( geom, bond, angle, tors, r, theta, phi )
c
c     Subroutine hnrg
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 imohcener
c
c     Called by:  imohcehk, imohcghk, imohchhk
c     Calls: 
c
c     Variables defined here:  none.
c
      use input, only : cartgeom, hcinf
      use files, only : outfile
      use energy, only : imohcener
      implicit none

      type (cartgeom) :: geom
      type (hcinf)    :: bond, angle, tors
      integer         :: i, j
      double precision :: r, theta, phi, xyz(4,3), n, d, normal(2,3),
     *   comp(2,3)
c
c  Assign xyz the geom of the 2 atoms involved in the bond
c
      do 90 i=1, 2
         do 100 j=1, 3
            xyz(i+1,j) = geom%aucoord((bond%atoms(i)-1)*3+j)
 100     continue
  90  continue
c
c  Calculate bond distance 2-3
c
      r = SQRT((xyz(2,1)-xyz(3,1))**2+(xyz(2,2)-xyz(3,2))**2+  
     *     (xyz(2,3)-xyz(3,3))**2)

c
c  Assign xyz the geom of the 3 atoms involved in the angle
c
      do 70 i=1, 3
         do 80 j=1, 3
            xyz(I,J) = geom%aucoord((angle%atoms(i)-1)*3+j)
  80     continue
  70  continue
c
c  Calculate bond angle 1-2-3
c
      n = (xyz(3,1)-xyz(2,1))*(xyz(1,1)-xyz(2,1)) +
     *      (xyz(3,2)-xyz(2,2))*(xyz(1,2)-xyz(2,2)) +
     *      (xyz(3,3)-xyz(2,3))*(xyz(1,3)-xyz(2,3))

      d = (SQRT((xyz(3,1)-xyz(2,1))**2+(xyz(3,2)-xyz(2,2))**2
     *       + (xyz(3,3)-xyz(2,3))**2))*
     *       (SQRT((xyz(1,1)-xyz(2,1))**2+(xyz(1,2)-xyz(2,2))**2
     *       + (xyz(1,3)-xyz(2,3))**2))

      theta = ACOS(n/d)
c     
c  Assign xyz the geom of the 4 atoms involved in the torsion
c
      do 50 i=1, 4
         do 60 j=1, 3
            xyz(i,j) = geom%aucoord((tors%atoms(i)-1)*3+j)
  60     continue
  50  continue
c
c  Calculate bond torsion 1-2-3-4
c
      do 20 j=1, 3
         comp(1,J) =xyz(2,J)-xyz(1,J)
         comp(2,J) =xyz(1,J)-xyz(3,J)
  20  continue

      normal(1,1) = comp(1,2)*comp(2,3) -comp(1,3)*comp(2,2)
      normal(1,2) = comp(1,3)*comp(2,1) -comp(1,1)*comp(2,3)
      normal(1,3) = comp(1,1)*comp(2,2) -comp(1,2)*comp(2,1)

      do 30 j=1, 3
         comp(1,J) =xyz(3,J)-xyz(2,J)
         comp(2,J) =xyz(2,J)-xyz(4,J)
  30  continue

      normal(2,1) = comp(1,2)*comp(2,3) -comp(1,3)*comp(2,2)
      normal(2,2) = comp(1,3)*comp(2,1) -comp(1,1)*comp(2,3)
      normal(2,3) = comp(1,1)*comp(2,2) -comp(1,2)*comp(2,1)

      n = normal(1,1)*normal(2,1) + normal(1,2)*normal(2,2)
     *    + normal(1,3)*normal(2,3)

      d = (SQRT(normal(1,1)**2+normal(1,2)**2 + normal(1,3)**2))*
     *      (SQRT(normal(2,1)**2+normal(2,2)**2 + normal(2,3)**2))

      phi= ACOS(n/d)
c
c  Add on the harmonic contribution to the energy
c
      imohcener = imohcener + 0.5*bond%k*(r-bond%eqval)**2
     *             + 0.5*angle%k*(theta-angle%eqval)**2
     *             + 0.5*tors%k*(phi-tors%eqval)**2

      return
      end

      subroutine  definemqc(ver_lab, c,ver_lab2) 
      use input, only : cartgeom, mginf
      use gparam
      use energy, only : mg3ener,mg3es,eso,ecc,erel,g3es,mqces,mqcener

      implicit none

      character*20     ver_lab,tempml(6),ver_lab2
      double precision c(4)
      type (mginf)     :: mg3inp,mqcinp
      integer         ver,i
      
      if ((ver_lab(:3) .eq. 'v2m') .or. (ver_lab(:3) .eq. 'v2s') 
     *  .or. (ver_lab(:4) .eq. 'v2sc'))then
        ver_lab2 ='v2m'
        ver = g2m 
        do 10 i = 1, 4
         c(i) = mqcdefc(ver,i)
10      continue
      elseif (ver_lab(:3) .eq. 'cho') THEN                             
         ver = gchos
         ver_lab2 ='cho'                                             
          do 20 i = 1, 4                                           
          c(i) = mqcdefc(ver,i)                 
20        continue                                                 
      elseif (ver_lab(:3) .eq. 'v3m') THEN                           
         ver = g3m
         ver_lab2 ='v3m'                                              
         do 30 i = 1, 4                                         
           c(i) = mqcdefc(ver,i)            
30       continue                                                 
      elseif (ver_lab(:3) .eq. 'v3s') THEN                             
         ver = g3s         
         ver_lab2 ='v3s'                                      
         do 40 i = 1, 4                                           
         c(i) = mqcdefc(ver,i)               
40       continue                                           
       endif
      return 
      end
