c
c*******************************************************************************
c  MLHEDR
c*******************************************************************************
c
      subroutine mlhedr
c
c     Subroutine mlhedr
c
c     Created:  April 8, 1999 by P. L. Fast
c     Revised:  July 20, 2006 by B.A. Ellingson
c     Purpose:  write Multi-Level program header to outfile
c
c     Description:  this subroutine writes the general program information
c                   to the output file.
c
c     Called by:  main
c     Calls:
c
c     Variables defined here:
c
c
      use files, only : outfile
      implicit none
c
      write (outfile,1000)
      write (outfile,1050)
      write (outfile,1100)
      write (outfile,1200)
      write (outfile,1300)
      write (outfile,1000)


 1000 format (/,80(1h*))
 1050 format (/3x,'MULTILEVEL 4.4')
 1100 format (/3X,'Yan Zhao, Jocelyn M. Rodgers, Benjamin J. Lynch,'
     */3X,'Nuria Gonzalez-Garcia, Patton L. Fast, Jingzhi Pu,'
     */3X,'Yao-Yuan Chuang, Benjamin A. Ellingson, Ruben Meana-Paneda,',
     */3x,'and Donald G. Truhlar')
 1200 format (/3x,'Department of Chemistry and Supercomputer Institute',
     *        /3x,'University of Minnesota, Minneapolis, Minnesota',/)    
 
 1300 format (3x,'Copyright 2013',
     *        /3x,'Donald G. Truhlar and Regents of the University ',
     *            'of Minnesota')
c
      end
c
c************************************************************************
c     INSUMRY
c************************************************************************
c
      subroutine insumry( mlgeninp, progrms, mloptinp, 
     *      extoptinp, llc,
     *      mcinp,mgswit,hfmoinp,mcoptl, sacinp, mcsinp, ibinp, 
     *      mcoinp, mnminp, mutinp, g2inp, mg2inp, g3inp, mg3inp, 
     *      mqcinp, mcomp2inp,mccoinp,g3sxmp3inp,mc3bbinp,              0710PJ00
     *      mc3mpwinp,limohc, imohcinp, ltest, tmeth, tbas, toptl)      0224BL02
c
c     Created:  June 21, 1999 by J. M. Rodgers
c     Revised:  Feb 24, 2000 by B. J. Lynch
c     Purpose:  Write out a summary of all input parameters
c
c
      use input, only : general, mctype, mgtype, hfmoinf, mcinf,
     *     ginf, mginf, imoinf, mlopt, extopt, proglist
      use files, only : outfile
      use energy, only : eso, ecc, erel
      use param, only : linear, nonlin, lints, nonlints, uniths, 
     *      lowhs, highhs
      implicit none
c
      character*20  ver_lab
      character*1 cswit(0:2)
      character*3 swit(0:1)
      character*3 yswit(0:1)
      character*10   aswit(0:5)                                         1026PJ04
      integer i

      type (proglist) :: progrms
      type (general) :: mlgeninp
      integer           llc, limohc, ltest
      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,mc3mpwinp,               0112PF00
     *                  mcomp2inp, mccoinp,g3sxmp3inp,mc3bbinp          0712BL02
      type (imoinf)  :: imohcinp
      type (mlopt)   :: mloptinp
      type (extopt)  :: extoptinp
c          
      data swit /'off','on'/
      data yswit /'no','yes'/
      data aswit /'NR','BFGS','DFP','EF','GAUEXT','NEB'/                1026PJ04
      data cswit /'Z','X','Y'/
c            
           
      if(mgswit%lmcg3.eq.1)then
      ver_lab = mg3inp%version
      endif
      if(mgswit%lmcco.eq.1)then
      ver_lab = mccoinp%version
      endif
      if(mgswit%lmcomp2.eq.1)then
      ver_lab = mcomp2inp%version
      endif
      if(mgswit%lmqcisd.eq.1)then
      ver_lab = mqcinp%version
      endif
      if(mgswit%lg3sxmp3.eq.1)then
      ver_lab = g3sxmp3inp%version
      endif
      if(mgswit%lmc3bb.eq.1)then
      ver_lab = mc3bbinp%version
      endif
      if(mgswit%lmc3mpw.eq.1)then
      ver_lab = mc3mpwinp%version
      endif
     

c        
c*********************************************************************
c           write out current date and time and then the title
c
c*********************************************************************
c
      write(outfile,1000)
      call dattim(outfile)
      do 1 i=1,5
          if (mlgeninp%mtitle(i).ne.' ')
     *           write(outfile,1001) mlgeninp%mtitle(i)
1     continue
1000  format(//,80('-'),/80('-')/)
1001  format(a80)
c
c
c*********************************************************************
c           write out data read in *MULTIGEN section
c
c*********************************************************************
c
      write(outfile,1100)
1100  format(//,80('-'),/80('-'),//2x,' Multigen Section Parameters: ',
     *   //80('-')/)
c
c  NATOMS
c
      write(outfile,1200) mlgeninp%geom%natoms
1200  format (/2x,'NATOMS:',t50,i2)
c
c  Charge and Multiplicity
c
      write(outfile,1300) mlgeninp%geom%charge
      write(outfile,1350) mlgeninp%geom%mult
1300  format (/2x,'System CHARGE:',t50,i2)
1350  format (2x,'System MULTIPLICITY:',t50,i2)
c
c  Geometry unit and type
c
      if (mlgeninp%geomunit.eq.1) then
         write (outfile,1400) 'angstroms'
      else
         write (outfile,1400) 'a.u.'
      endif
      if (mlgeninp%geomtype.eq.0) then
         write (outfile,1450) 'cartesian'
      endif
1400  format (/2x,'GEOMUNIT: Units for input geometries:',t50,a10)
1450  format (2x,'GEOMTYPE: Form of input geometries:',t50,a10)
c
c  Input geometry
c
      write(outfile,1455)
1455  format(/2x,'** GEOMETRY:'/)
      write(outfile,1460)
1460  format(/5x,'Atomic information:',/12x,'Atom ',4x,
     *  'Atomic Symbol',5x,'Mass (amu)',/)
      do 2 i=1,mlgeninp%geom%natoms
         write(outfile,1465) i, mlgeninp%geom%atm(i),
     *          mlgeninp%geom%atmmss(i)
   2  continue
1465  format(13x,i2,15x,a2,10x,f10.6)
      write(outfile,1470)
1470  format(//5x,'Atomic Coordinates (in a.u.):',//8x,'Atom ',t28,
     *  'X', t48, 'Y', t68, 'Z'/)
      do 5 i=1, mlgeninp%geom%natoms
         write(outfile,1473) i, mlgeninp%geom%aucoord(3*i-2),
     *        mlgeninp%geom%aucoord(3*i-1), mlgeninp%geom%aucoord(3*i)
   5  continue
      write(outfile,1471)
1471  format(//5x,'Atomic Coordinates (in ang.):',//8x,'Atom ',t28,
     *  'X', t48, 'Y', t68, 'Z'/)
      do 7 i=1, mlgeninp%geom%natoms
         write(outfile,1473) i, mlgeninp%geom%angcoord(3*i-2),
     *      mlgeninp%geom%angcoord(3*i-1), mlgeninp%geom%angcoord(3*i)
   7  continue
1473  format(9x,i2,t20,d15.8,t40,d15.8,t60,d15.8)
c
c  SO and CC energies
c
      write(outfile,1474) eso, ecc, erel
1474  format(/2x,'ESO: Spin-Orbit Energy Correction:',t60,f10.6,
     *    /2x,'ECC: Core-Correlation Energy Correction:',t60,f10.6, 
     *    /2x,'EREL: Relativistic Energy Correction:',t60,f10.6)
c
c  Switches for calculations
c
      write(outfile,1500)
1500  format(/2x,'** Calculations:'/)
c
      write(outfile,1535) yswit(mlgeninp%lextopt)
      write(outfile,1540) yswit(mlgeninp%lopt)
      write(outfile,1510) yswit(mlgeninp%lener)
      write(outfile,1520) yswit(mlgeninp%lgrad)
      write(outfile,1530) yswit(mlgeninp%lhess)
c
1510  format(4x,'ENERGY:  the energy is calculated:',t60,a3)
1520  format(4x,'GRADIENT:  the gradient is calculated:',t60,a3)
1530  format(4x,'HESSIAN:  the hessian is calculated:',t60,a3)
1535  format(4x,'EXTOPT:  optimization with an external program:',
     *           t60, a3)
1540  format(4x,'MULTIOPT:  optimization with Multilevel:',t60,a3)

      if (mlgeninp%lextopt .eq. 1) then
         write(outfile,1600)
1600  format(//,80('-'),/80('-'),//2x,' EXTOPT Section Parameters: ',
     *   //80('-')/)
         write(outfile,1610) progrms%extoptprog
         write(outfile,1620) extoptinp%meth
         write(outfile,1630) extoptinp%bas
         write(outfile,1640)
         do 37 i=1,5   
            if (extoptinp%optl(i).ne.'                              ')
     *            write (outfile,1650) extoptinp%optl(i)
  37     continue
      endif
1610  format(5x,'PROGRAM:  external optimization program:',t60,a)
1620  format(5x,'METHOD:  electronic structure method:',t60,a)
1630  format(5x,'BASIS:  basis set:',t60,a)
1640  format(/5x,'OPTIONS for PROGRAM:')
1650  format(5x,a75)

      if (mlgeninp%lopt .eq. 1) then
         write(outfile,1660)        
1660  format(//,80('-'),/80('-'),//2x,' MULTIOPT Section Parameters: ',
     *   //80('-')/)
         write(outfile,1670) aswit(mloptinp%algrthm)
         write(outfile,1680) mloptinp%mlmeth
         if (mloptinp%iop .eq. linear) then
            write(outfile,1690) 'Linear Minimum'
         elseif (mloptinp%iop .eq. nonlin) then
            write(outfile,1690) 'Non-linear Minimum'
         elseif (mloptinp%iop .eq. lints) then
            write(outfile,1690) 'Linear Transition State'
         elseif (mloptinp%iop .eq. nonlints) then
            write(outfile,1690) 'Non-linear Transition State'
         endif
         if (mloptinp%htyp .eq. uniths) then
            write(outfile,1691) 'Scaled Unit Matrix'
         elseif (mloptinp%htyp .eq. lowhs) then
            write(outfile,1691) 'Low Level Hessian'
            write(outfile,1693) mloptinp%hmeth
            write(outfile,1694) mloptinp%hbas
         elseif (mloptinp%htyp .eq. highhs) then
            write(outfile,1691) 'High Level Hessian'
         endif
         write(outfile,1695) yswit(mloptinp%ihunit)
         if (mloptinp%ihunit.eq.0 .or.
     *           mloptinp%htyp .eq. uniths) then
            write(outfile,1696) mloptinp%hscale
         endif
         write(outfile,1710) mloptinp%gcomp
         write(outfile,1720) mloptinp%scale
         write(outfile,1730) mloptinp%stptol
         write(outfile,1740) mloptinp%hrec
         write(outfile,1750) mloptinp%niter
         write(outfile,1760) swit(mloptinp%retry)
         write(outfile,1765) 
         write(outfile,1767)
         write(outfile,*)  mloptinp%optl
         do 39 i=1, 3*mlgeninp%geom%natoms
            if (mloptinp%constant(i) .eq. 1) then
               write(outfile,1766) (i+2)/3, cswit(mod(i,3))
            endif
  39     continue
         if (mloptinp%nebset .eq. 1) then                               0706NG04
            write(outfile, 1768)                                        0706NG04
            write(outfile, 1769)                                        0706NG04
            do i=1, mlgeninp%geom%natoms                                0706NG04
                write(outfile,1473) i,                                  0706NG04
     *                mloptinp%nebinp%rgeom%angcoord(3*i-2),            0706NG04
     *                mloptinp%nebinp%rgeom%angcoord(3*i-1),            0706NG04
     *                mloptinp%nebinp%rgeom%angcoord(3*i)               0706NG04
            end do                                                      0706NG04
            write(outfile, 1770)                                        0706NG04
            do i=1, mlgeninp%geom%natoms                                0706NG04
                write(outfile,1473) i,                                  0706NG04
     *                mloptinp%nebinp%pgeom%angcoord(3*i-2),            0706NG04
     *                mloptinp%nebinp%pgeom%angcoord(3*i-1),            0706NG04
     *                mloptinp%nebinp%pgeom%angcoord(3*i)               0706NG04
            end do                                                      0706NG04
c
c write no. of NEB iterations and no. of image
c
            write(outfile, 1771) mloptinp%nebinp%nimg                   0706NG04
            write(outfile, 1772) mloptinp%nebinp%kspr                   0706NG04
c
c read the different options for the 3 algorithms used
c
            if (mloptinp%nebinp%interp.eq.1) then                       0706NG04
                write(outfile,1773) 'linear'                            0706NG04
            endif                                                       0706NG04
c
            if (mloptinp%nebinp%nebalg.eq.1) then                       0708NG06
                write(outfile, 1774) 'IT-NEB'                           0208NG06
            elseif (mloptinp%nebinp%nebalg.eq.2) then                   0208NG06
                write(outfile, 1774) 'CI-NEB'                           0208NG06
            elseif (mloptinp%nebinp%nebalg.eq.3) then                   0208NG06
                write(outfile, 1774) 'D-NEB'                            0208NG06
            elseif (mloptinp%nebinp%nebalg.eq.4) then                   0208NG06
                write(outfile, 1774) 'B-NEB'                            0208NG06
            endif                                                       0706NG04
c    
            if (mloptinp%nebinp%optm.eq.1) then                         0706NG04
                write(outfile, 1775) 'BFGS'                             0706NG04
            elseif (mloptinp%nebinp%optm.eq.2) then                     0706NG04
                write(outfile, 1775) 'DFP'                              0706NG04
            elseif (mloptinp%nebinp%optm.eq.3) then                     0706NG04
                write(outfile, 1775) 'NR'                               0706NG04
            elseif (mloptinp%nebinp%optm.eq.4) then                     1026PJ04
                write(outfile, 1775) 'VB'                               1026PJ04
            elseif (mloptinp%nebinp%optm.eq.5) then                     0706NG04
                write(outfile, 1775) 'EF'                               0706NG04
            elseif (mloptinp%nebinp%optm.eq.6) then                     0706NG04
               write(outfile, 1775) 'Gau-Ext'                           0706NG04
            endif                                                       0706NG04
            write(outfile, 1776) mloptinp%nebinp%nebiter                0706NG04
         endif
      endif
1670  format(5x,'ALGORITHM:  optimization process:',t60,a)
1680  format(5x,'METHOD:  Multilevel method used:',t60,a)
1690  format(5x,'MOLECULE TYPE:', t60, a)
1691  format(5x,'HESSIAN:  type used to calculate step size:',t60,a)
1693  format(5x,'HMETH:  low level hessian method:',t60,a)
1694  format(5x,'HBAS:  low level hessian basis set:',t60,a)
1695  format(5x,'HESSINIT:  hessian calculation at first step:',t60,a)
1696  format(5x,'HSCALE:  scaling of the unit matrix:',t60,d9.2)
1710  format(5x,'GCOMP:  convergence threshold for gradient:',
     *        t60, d10.3)
1720  format(5x,'SCALE:  max rms step size:', t60, d10.3)
1730  format(5x,'STPTOL:  optimization failure condition:',t60, d10.3)
1740  format(5x,'HREC:  number of steps between hessian ',
     *        'calculations:',t60, i3)
1750  format(5x,'NITER:  number of optimization iterations:',t60,i3)
1760  format(5x,'RETRY:  switch to full Newton if NR/BFGS/DFP fail:',
     *        t60, a)
1765  format(5x,'CONSTANT:  Coordinates to be held constant:')
1766  format(20x,i3,1x,a1)
1767  format(5x,'OPTIONS specified for Gau_External calculations:')
1768  format (5x,'NEB:  the nudged elasitc band method is used: ')      0706NG04
1769  format (//5x,'NEB React (in ang.):',//8x,'Atom ',t28,             0706NG04
     *  'X', t48, 'Y', t68, 'Z'/)                                       0706NG04
1770  format (//5x,'NEB Product (in ang.):',//8x,'Atom ',t28,           0706NG04
     *  'X', t48, 'Y', t68, 'Z'/)                                       0706NG04
1771  format (5x,'NIMG:  number of images used by NEB ', t60, i3)       0706NG04
1772  format (5x,'KSPR:  spring force in NEB ', t60, d10.3)             0706NG04
1773  format (5x,'INTERP: Interpolation algorithm used ', t60, a10)     0706NG04
1774  format (5x,'NEBALG: Algorithm used to calculate ',                0706NG04
     *        'the tangent' , t60, a10)                                 0706NG04
1775  format (5x,'OPTM: Minimization method used to converge ',         0706NG04
     *        'the NEB', t60, a10)                                      0706NG04
1776  format (5x,'NEBITER:  Max. no. of NEB iterations', t60, i3)       0706NG04
c
c
c
c
c*********************************************************************
c           write out data read in *TEST section
c
c*********************************************************************
c
      if (ltest.eq.1)  then
         write(outfile,1779)                                            0712NG04
c
c
1779  format(//,80('-'),/80('-'),//2x,' TEST Section Parameters: ',     0712NG04
     *   //80('-')/)
         write (outfile,1780) tmeth
         write (outfile,1782) tbas
         write (outfile,1783) progrms%testprog
         write (outfile,1785)
         do 1787 i=1,5
            if (toptl(i).ne.'                           ')
     *           write (outfile,8600) toptl(i)
1787     continue
         write (outfile,*)
      endif

1780  format (/10x,'METHOD:',t50,a20)
1782  format (10x,'BASIS:',t50,a20)
1783  format (/2x,'PROGRAM: Program called for the TEST cal.:',t60,a)
1785  format (/10x,'OPTIONS specified for TEST calculations:')

c
c*********************************************************************
c           write out data read in *IMO section
c
c*********************************************************************
c
      if (limohc.eq.1)  then
         write(outfile,1800)
1800  format(//,80('-'),/80('-'),//2x,' IMO Section Parameters: ',
     *   //80('-')/)
         write (outfile,1900) swit(limohc)
         write (outfile,1905) imohcinp%hlmeth
         write (outfile,1910) imohcinp%hlbas
         write (outfile,1911) progrms%imohlprog
         write (outfile,1912) 
         do 1805 i=1,5
            if (imohcinp%hloptl(i).ne.'                           ')
     *           write (outfile,8600) imohcinp%hloptl(i)
1805     continue

         write (outfile,1915) imohcinp%llmeth
         write (outfile,1920) imohcinp%llbas
         write (outfile,1921) progrms%imollprog
         write (outfile,1925)
         do 1810 i=1,5
            if (imohcinp%hloptl(i).ne.'                           ')
     *           write (outfile,8600) imohcinp%hloptl(i)
1810     continue
         write (outfile,*)
         write (outfile,1930) imohcinp%capatm
         write (outfile,1935) imohcinp%ssnatm
         write (outfile,1939)
         write (outfile,1940) imohcinp%ssatm(:imohcinp%ssnatm)
         write (outfile,1945) imohcinp%lsnatm
         write (outfile,1950)
         write (outfile,1940) imohcinp%lsatm(:imohcinp%lsnatm)
         write (outfile,1952)
         write (outfile,1955) imohcinp%bond%atoms(:2)
         write (outfile,1960) imohcinp%bond%k
         write (outfile,1965) imohcinp%bond%eqval
         write (outfile,1970) imohcinp%angle%atoms(:3)
         write (outfile,1975) imohcinp%angle%k
         write (outfile,1980) imohcinp%angle%eqval
         write (outfile,1985) imohcinp%tors%atoms(:4)
         write (outfile,1990) imohcinp%tors%k
         write (outfile,1995) imohcinp%tors%eqval
      endif
1900  format (/5x,'IMOHC:',t50,a3)
1905  format (/10x,'HLKEY:METHOD:  High level method:',t50,a20)
1910  format (10x,'HLKEY:BASIS:  High level basis:',t50,a20)
1911  format (10x,'HLKEY:PROGRAM:  E.S. Package called:',t50,a10)
1912  format (10x,'HLKEY:OPTIONS:')
1915  format (10x,'LLKEY:METHOD:  Low level method:',t50,a20)
1920  format (10x,'LLKEY:BASIS:  Low level basis:',t50,a20)
1921  format (10x,'LLKEY:PROGRAM:  E.S. Package called:',t50,a10)
1925  format (/10x,'LLKEY:OPTIONS:')
1930  format (10x,'CAPATOM:  Capping Atom:',t50,i3)
1935  format (10x,'# of atoms in small system:',t50,i3)
1939  format (10x,'CSS:  Atoms in small system:')
1940  format (15x,i3)
1945  format (/10x,'# of atoms in large system:',t50,i3)
1950  format (10x,'Atoms in large system:')
1952  format (/10x,'HC:  Harmonic Capping Information:')
1955  format (/12x,'Atoms in harmonic bond approx.:',t50,2(i3,2x))
1960  format (15x,'Force Constant =',t50,d11.4)
1965  format (15x,'Equilibrium Length =',t50,f10.6)
1970  format (/12x,'Atoms in harmonic angle approx.:',t50,3(i3,2x))
1975  format (15x,'Force Constant =',t50,d11.4)    
1980  format (15x,'Equilibrium Angle (in radians) =',t50,f10.6)
1985  format (/12x,'Atoms in harmonic torsion approx.:',t50,4(i3,2x))
1990  format (15x,'Force Constant =',t50,d11.4)    
1995  format (15x,'Equilibrium Torsion (in radians) =',t50,f10.6)

c
c*********************************************************************
c           write out data read in *LC section
c
c*********************************************************************
c
      if (llc.eq.1)   write (outfile,2000)
2000  format(//,80('-'),/80('-'),//2x,' LC Section Parameters: ',
     *   //80('-')/)
c
c  HFMO Parameters
c
      if (hfmoinp%lhfmo.eq.1) then
         write (outfile,2500) swit(hfmoinp%lhfmo)
         write (outfile,2600) hfmoinp%hfkbas
         write (outfile,2625) progrms%hfprog
         write (outfile,2650)
         do 2001 i=1,5
            if (hfmoinp%hfkoptl(i).ne.'                           ') 
     *           write (outfile,8600) hfmoinp%hfkoptl(i)
2001     continue 
         write (outfile,2700) hfmoinp%mokmeth
         write (outfile,2725) progrms%moprog
         write (outfile,2750)
         do 2002 i=1,5
            if (hfmoinp%mokoptl(i).ne.'                             ') 
     *            write (outfile,8600) hfmoinp%mokoptl(i)
2002     continue
         write (outfile,*)
         write (outfile,2800) hfmoinp%frachf
      endif
2500  format (/5x,'HFMO (Linear Mixing of HF and MO):',t50,a3)
2600  format (/10x,'Basis for HF calculation:', t50,a20)
2625  format (10x,'Program for HF calculation:',t50,a10)
2650  format (10x,'Options specificed for HF calculations:')
2700  format (10x,'MO Method used:',t50,a20)
2725  format (10x,'Program for MO calculation:',t50,a10)
2750  format (10x,'Options specified for MO calculations:')
2800  format (10x,'Fraction of HF used in HFMO calculations:', 
     *          t50,f10.6)
c
c  MC Options
c
      if (mcinp%lsac.eq.1 .or. mcinp%lmcsac.eq.1 .or.
     *     mcinp%lib.eq.1 .or. mcinp%lmccmco.eq.1 .or.
     *     mcinp%lmccmut.eq.1 .or. mcinp%lmccmnm.eq.1)  then
c
c  MC PROGRAM
c
         write (outfile,2845) progrms%mcprog
         write (outfile,2850)
         do 2855 i=1, 5
            if (mcoptl(i).ne.'                                   ')
     *         write (outfile,8600) mcoptl(i)
2855     continue
c
c  COOP/NOCOOP
c
         write (outfile, 2900) yswit(mcinp%lcoop)
      endif

2845  format (//5x,'MCPROGRAM:',t70,a10)
2850  format (/5x,'MC Options Specified for SAC, MCSAC, IB, ',
     *          'and MCCM calculations:')
2900  format(/5x,'COOP:  Do all possible calculations for ',
     *        'SAC/MCSAC/IB/MCCM:',t70,a3)
c
c  SAC Parameters
c
      if (mcinp%lsac.eq.1 .or.
     *      (mcinp%lcoop.eq.1 .and.
     *       (mcinp%lmccmco.eq.1 .or. mcinp%lmccmut.eq.1 .or.
     *        mcinp%lmccmnm.eq.1 .or. mcinp%lmcsac.eq.1 .or.
     *        mcinp%lib.eq.1 ) ) ) then
         write (outfile,3500) swit(mcinp%lsac)
         write (outfile,8100) sacinp%meth
         write (outfile,8500) sacinp%bas1
         write (outfile,3600) sacinp%version
         write (outfile,8700) 1,sacinp%coef(1)
      endif
3500  format (//5x,'SAC (Scaling All Correlation Method):',t50,a3)
3600  format (/10x,'SAC Coefficient:',t50,a5)
c
c  MCSAC Parameters
c
      if (mcinp%lmcsac.eq.1 .or.
     *      (mcinp%lcoop.eq.1 .and. 
     *       (mcinp%lmccmco.eq.1 .or. mcinp%lmccmut.eq.1 .or.
     *        mcinp%lmccmnm.eq.1 .or. mcinp%lsac.eq.1 .or.
     *        mcinp%lib.eq.1 ) ) ) then
         write (outfile,4000) swit(mcinp%lmcsac)
         write (outfile,8100) mcsinp%meth
         write (outfile,8500) mcsinp%bas1
         write (outfile,4100) mcsinp%version
         do 2006 i=1, 4
            write (outfile,8700) i, mcsinp%coef(i)
2006     continue
      endif
4000  format (//5x,'MCSAC (Multi-Coefficient SAC):',t50,a3)
4100  format (/10x,'MCSAC Coefficients:',t50,a5)
c
c  IB Parameters
c
      if (mcinp%lib.eq.1 .or. 
     *      (mcinp%lcoop.eq.1 .and. 
     *       (mcinp%lmccmco.eq.1 .or. mcinp%lmccmut.eq.1 .or.
     *        mcinp%lmccmnm.eq.1) ) ) then
         write (outfile,3000) swit(mcinp%lib)
         write (outfile,8100) ibinp%meth
         write (outfile,8200) ibinp%bas1
         write (outfile,8400) ibinp%bas2
         write (outfile,3250) ibinp%coef(1)
         write (outfile,3300) ibinp%coef(2)
      endif
3000  format (//5x,'IB (Infinite Basis Method):',t50,a3)
3250  format (/10x,'IB Alpha parameter (HF contribution):', 
     *        t50, f10.6)
3300  format (/10x,'IB Beta parameter (Corr. contribution):',
     *        t50, f10.6)
c
c  MCCM-CO Parameters
c
      if (mcinp%lmccmco.eq.1 .or. 
     *      (mcinp%lcoop.eq.1 .and.                  
     *       (mcinp%lib.eq.1 .or. mcinp%lmccmut.eq.1 .or.
     *        mcinp%lmccmnm.eq.1) ) ) then
         write (outfile,4500) swit(mcinp%lmccmco)
         write (outfile,8100) mcoinp%meth
         write (outfile,8200) mcoinp%bas1
         write (outfile,8400) mcoinp%bas2
         write (outfile,4600) mcoinp%version
         do 2008 i=1, 10
            write (outfile,8700) i, mcoinp%coef(i)
2008     continue
      endif
4500  format (//5x,'MCCM - Colorado Version:',t50,a3)
4600  format (/10x,'MCCM-CO Coefficients:',t50,a5)
c
c  MCCM-NM Parameters
c
      if (mcinp%lmccmnm.eq.1) then
         write(outfile,5000) swit(mcinp%lmccmnm)
         write (outfile,8100) mnminp%meth
         write (outfile,8200) mnminp%bas1
         write (outfile,8300) mnminp%bas2
         write (outfile,8400) mnminp%bas3
         write (outfile,5100) mnminp%version
         do 2010 i=1, 7
            write (outfile,8700) i, mnminp%coef(i)
2010     continue
      endif
5000  format (//5x,'MCCM - New Mexico Version:',t50,a3)
5100  format (/10x,'MCCM-NM Coefficients:',t50,a5)
c
c  MCCM-UT Parameters
c
      if (mcinp%lmccmut.eq.1 .or.
     *      (mcinp%lcoop.eq.1 .and.                  
     *       (mcinp%lmccmco.eq.1 .or. mcinp%lib.eq.1 .or.
     *        mcinp%lmccmnm.eq.1) ) ) then
         write(outfile,5500) swit(mcinp%lmccmut)
         write (outfile,8100) mutinp%meth
         write (outfile,8200) mutinp%bas1
         write (outfile,8400) mutinp%bas2
         write (outfile,5600) mutinp%version
         do 2012 i=1, 7
            write (outfile,8700) i, mutinp%coef(i)
2012     continue
      endif
5500  format (//5x,'MCCM - Utah Version:',t50,a3)
5600  format (/10x,'MCCM-UT Coefficients:',t50,a5)
c
c  MC-QCISD
c
      if (mgswit%lmqcisd.eq.1) then                                     0112PF00
         write (outfile, 5625)                                          0112PF00
         write (outfile, 5650) progrms%g3prog                           0112PF00
         write (outfile, 5655)                                          0112PF00
         do 5675 i = 1, 4                                               0112PF00
            if (mqcinp%optl(i) .ne. '                             ')    0112PF00
     *         write (outfile,8600) mqcinp%optl(i)                      0112PF00
5675     continue                                                       0112PF00
         write (outfile,5680) mqcinp%version                            0112PF00
         do 5690 i = 1, 4                                               0112PF00
            write(outfile,8700) i, mqcinp%mqcoef(i)                     0112PF00
5690     continue                                                       0112PF00
5625     format (//2x,'-- MC-QCISD --')                                 0112PF00
5650     format (/10x,'G3PROGRAM for MC-QCISD Calcs.:',t50,a)           0112PF00
5655     format (/10x,'G3OPTIONS for MC-QCISD Calcs.:')                 0112PF00
5680     format (/10x,'MC-QCISD Coefficients:',t50,a5)                  0112PF00
      endif                                                             0112PF00

c
c  MCOMP2
c
      if (mgswit%lmcomp2.eq.1) then                                     0170PJ00
         write (outfile, 5626)                                          0170PJ00
         write (outfile, 5651) progrms%g3prog                           0170PJ00
         write (outfile, 5656)                                          0170PJ00
         do 5676 i = 1, 4                                               0170PJ00
            if (mqcinp%optl(i) .ne. '                             ')    0170PJ00
     *         write (outfile,8600) mcomp2inp%optl(i)                   0170PJ00
5676     continue                                                       0170PJ00
         write (outfile,5681) mcomp2inp%version                         0170PJ00
         do 5691 i = 1, 4                                               0170PJ00
            write(outfile,8700) i, mcomp2inp%mcomp2coef(i)              0170PJ00
5691     continue                                                       0170PJ00
5626     format (//2x,'-- MCOMP2 --')                                   0170PJ00
5651     format (/10x,'G3PROGRAM for MCOMP2 Calcs.:',t50,a)             0170PJ00
5656     format (/10x,'G3OPTIONS for MCOMP2 Calcs.:')                   0170PJ00
5681     format (/10x,'MCOMP2 Coefficients:',t50,a5)                    0170PJ00
      endif                                                             0170PJ00


c  MCCO
c
      if (mgswit%lmcco.eq.1) then                                       0712BL02
         write (outfile, 5627)                                          0712BL02
         write (outfile, 5652) progrms%g3prog                           0712BL02
         write (outfile, 5657)                                          0712BL02
         do 5677 i = 1, 4                                               0712BL02
            if (mqcinp%optl(i) .ne. '                             ')    0712BL02
     *         write (outfile,8600) mccoinp%optl(i)                     0712BL02
5677     continue                                                       0712BL02
         write (outfile,5682) mccoinp%version                           0712BL02
         do 5692 i = 1, 4                                               0712BL02
            write(outfile,8700) i, mccoinp%mccocoef(i)                  0712BL02
5692     continue                                                       0712BL02
5627     format (//2x,'--- MCCO ---')                                   0712BL02
5652     format (/10x,'G3PROGRAM for MCCO Calcs.:',t50,a)               0712BL02
5657     format (/10x,'G3OPTIONS for MCCO Calcs.:')                     0712BL02
5682     format (/10x,'MCCO Coefficients:',t50,a5)                      0712BL02
      endif                                                             0712BL02

c
c  MCG# Methods
c
      if (mgswit%lg2.eq.1  .or. mgswit%lg3.eq.1  .or.
     *      mgswit%lmcg2.eq.1  .or.  mgswit%lmcg3.eq.1)
     *   write (outfile,5800)
5800  format (//2x,'--G# (Gaussian Methods)--')
c
c  Options and Program
c
      if (mgswit%lg2.eq.1 .or. mgswit%lmcg2.eq.1)  then
         write (outfile, 5875) progrms%g2prog
         write (outfile,5925)
         do 5913 i=1, 5
            if (g2inp%optl(i).ne.'                               ')
     *           write (outfile,8600) g2inp%optl(i)
5913     continue
      endif

5875  format (/10x,'G2PROGRAM for G2/MCG2 Calcs.:',t70,a)
5925  format (/10x,'G2OPTIONS for G2/MCG2 Calcs.:')
      
c
c  G2 Parameters
c
      if (mgswit%lg2.eq.1) then
         write(outfile,5900) swit(mgswit%lg2)
         write (outfile,5950) g2inp%alpha
         write (outfile,5975) g2inp%beta
      endif
5900  format (//5x,'G2:',t50,a3)
5950  format (/10x,'Alpha electrons:',t50, i3) 
5975  format (10x,'Beta electrons:',t50, i3)

c
c  MCG2 Parameters
c
      if (mgswit%lmcg2.eq.1) then
         write(outfile,6000) swit(mgswit%lmcg2)
         write (outfile,6050)
         do 2013 i=1, 5
            if (mg2inp%optl(i).ne.'                                ') 
     *           write (outfile,8600) mg2inp%optl(i)
2013     continue
         write (outfile,6100) mg2inp%version
         do 2014 i=1, 9
            write (outfile,8700) i, mg2inp%mcoef(i)
2014     continue
      endif
6000  format (//5x,'MCG2 (Multi-Coefficient G2):',t50,a3)
6050  format (/10x,'Options specified for the MCG2 calculations:')
6100  format (/10x,'MCG2 Coefficients:',t50,a5)
c
c  Options and Program
c
      if (mgswit%lg3.eq.1 .or. mgswit%lmcg3.eq.1)  then   
         write (outfile, 6710) progrms%g3prog
         write (outfile,6725)
         do 6700 i=1, 5
            if (g3inp%optl(i).ne.'                               ')
     *           write (outfile,8600) g3inp%optl(i)
6700     continue
      endif

6710  format (/10x,'G3PROGRAM for G3/MCG3 Calcs.:',t70,a)
6725  format (/10x,'G3OPTIONS for G3/MCG3 Calcs.:')
c
c  G3 Parameters
c
      if (mgswit%lg3.eq.1) then
         write(outfile,6900) swit(mgswit%lg3)  
         write (outfile,6925)
         do 6913 i=1, 5
            if (g3inp%optl(i).ne.'                                 ')
     *           write (outfile,8600) g3inp%optl(i)
6913     continue
         write (outfile,6950) g3inp%alpha
         write (outfile,6975) g3inp%beta
      endif
6900  format (//5x,'G3:',t50,a3)
6925  format (/10x,'Options specified for the G3 calculations:')
6950  format (/10x,'Alpha electrons:',t50, i3)
6975  format (10x,'Beta electrons:',t50, i3)
c
c  MCG3 Parameters
c
      if (mgswit%lmcg3.eq.1) then
         write(outfile,7000) swit(mgswit%lmcg3)
         write (outfile,7050)
         do 2017 i=1, 5
            if (mg3inp%optl(i).ne.'                              ')
     *            write (outfile,8600) mg3inp%optl(i)
2017     continue
         write (outfile,7100) mg3inp%version


      if((ver_lab(:3).eq.'v3m').or.(ver_lab(:3).eq.'v3s'))then
         do 2019 i=1, 7
            write (outfile,8700) i, mg3inp%mcoef(i)
2019     continue
      else
         do 2018 i=1, 9
            write (outfile,8700) i, mg3inp%mcoef(i)
2018     continue
      endif
    
      endif
7000  format (//5x,'MCG3 (Multi-Coefficient G3):',t50,a3)
7050  format (/10x,'Options specified for the MCG3 calculations:')
7100  format (/10x,'MCG3 Coefficients:',t50,a5)

c
c G3SXMP3 Parameters
c
      if (mgswit%lg3sxmp3.eq.1) then
         write(outfile,7200) swit(mgswit%lg3sxmp3)
         write (outfile,7250)
         do 2027 i=1, 5
          if (g3sxmp3inp%optl(i).ne.'                              ')
     *            write (outfile,8600) g3sxmp3inp%optl(i)
2027     continue
         write (outfile,7300) g3sxmp3inp%version


         do 2029 i=1, 5 
            write (outfile,8700) i, g3sxmp3inp%g3sxmp3coef(i)
2029     continue
    
      endif
7200  format (//5x,'G3SX(MP3) :',t50,a3)
7250  format (/10x,'Options specified for the G3SX(MP3) calculations:')
7300  format (/10x,'G3SX(MP3) Coefficients:',t50,a5)


c
c MC3BB Parameters
c
      if (mgswit%lmc3bb.eq.1) then
         write(outfile,7400) swit(mgswit%lmc3bb)
         write (outfile,7450)
         do 7210 i=1, 5
          if (mc3bbinp%optl(i).ne.'                              ')
     *            write (outfile,8600) mc3bbinp%optl(i)
7210     continue
         write (outfile,7500) mc3bbinp%version


         do 7229 i=1, 2
            write (outfile,8700) i, mc3bbinp%mc3bbcoef(i)
7229     continue
   
      endif
7400  format (//5x,'MC3BB :',t50,a3)
7450  format (/10x,'Options specified for the MC3BB calculations:')
7500  format (/10x,'MC3BB Coefficients:',t50,a5)


c
c MC3MPW Parameters
c
      if (mgswit%lmc3mpw.eq.1) then
         write(outfile,7520) swit(mgswit%lmc3mpw)
         write (outfile,7550)
         do 7510 i=1, 5
         if (mc3mpwinp%optl(i).ne.'                              ')
     *            write (outfile,8600) mc3mpwinp%optl(i)
7510     continue
         write (outfile,7600) mc3mpwinp%version


         do 7529 i=1, 2
            write (outfile,8700) i, mc3mpwinp%mc3mpwcoef(i)
7529     continue

      endif
7520  format (//5x,'MC3MPW :',t50,a3)
7550  format (/10x,'Options specified for the MC3MPW calculations:')
7600  format (/10x,'MC3MPW Coefficients:',t50,a5)


c
c  Common format statements
c
8100  format (/10x,'Electronic Structure Method:',t50,a20)
8200  format (10x,'Low Level Basis Set:',t50,a20)
8300  format (10x,'Middle Level Basis Set:',t50,a20)
8400  format (10x,'High Level Basis Set:',t50,a20)
8500  format (10x,'Basis Set:',t50,a20)
8600  format (5x,a75)
8700  format (15x,i2,5x,f10.6)
c
c

      return
      end
c
c
c***********************************************************************
c  DATE
c***********************************************************************
c
c      subroutine date(idate)
c
c   Pulled from Polyrate.
c
c   This is a machine-specific subprogram that writes the date and 
c   time to a file linked to FORTRAN unit IO.
c
c   Machine: Silicon Graphics Workstations
c
c   Called  by:  dattim
c
c      implicit none
c      character*9 idate
c                  
c      call fdate(idate)
c
c      return
c      end
c
c***********************************************************************
c  DATTIM
c***********************************************************************
c
      subroutine dattim(io)
c
c     version for Silicon Graphics computers
c     write date and time to device io
c     
c     Called by: insumry
c     Calls:     date_and_time
c                                                              0808RMP12 
      implicit none
      integer io
      character*8 today
      character*10 time

      call date_and_time(today,time)
      write(io,1100) today(5:6)//"/"//today(7:8)//"/"//today(1:4)//"   "
     &//time(1:2)//":"//time(3:4)//":"//time(5:10)

      return

1100  format(1x,a24)

      end
c
c*****************************************************************************
c  MCDISP
c*****************************************************************************
c
      subroutine mcdisp ( prognme, esswit, mcswit, ctr, natoms, type )
c
c     Subroutine mcdisp
c  
c     Created:  July 10, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display all energies, gradients, and hessians calculated
c               for the MC methods.
c
c     Called by:   mcehk, mcghk, mchhk 
c     Calls: mtoltm
c
c     Variables defined here:
c
      use param, only : mcmlist, fesmlist, fbaslist,verslist,
     *                       numes, numbas, nummc, numcalc
      use files, only : outfile
      use energy, only : mcener, esener
      use gradient, only : mcgrad, esgrad
      use hessian, only : mchess, eshess
      use caltyp
      implicit none
      
      integer           esswit(numes,numbas)
      integer           mcswit(5,numcalc)
      integer           ctr, i, j, k, l, natoms, type, prn
      character*10      prognme
      double precision  hdisp(3*natoms*(3*natoms+1)/2)
      integer           n3tm

      n3tm = 3*natoms

      prn = 0
1000  format(//,80('-'),/80('-')//3x,'Calculations Made by the ',
     *   'Electronic Structure Program ',a,/5x,'for MCCM, IB, MCSAC, ',
     *   'and SAC:',//80('-')/)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)

      do 20 j=1, numbas
         do 40 i=1, numes
            if (esswit(i,j).eq.1) then
               if (prn.eq.0) then
                   write(outfile,1000) prognme
                   write(outfile,1010)
                   prn = 1
               endif
               write(outfile,1020) fesmlist(i), fbaslist(j), 
     *                                esener(i,j)
               if (type.eq.tgrad .or. type.eq.thess) then
                  write(outfile,1022)
                  write(outfile,1025) esgrad(i,j,:n3tm)
                  write(outfile,*)
               endif
               if (type.eq.thess) then
                  write(outfile,1027)
                  call mtoltm(eshess(i,j,:n3tm,:n3tm), hdisp, n3tm)
                  write(outfile,1025) hdisp
                  write(outfile,*)
               endif
            endif
  40     continue
  20  continue

1020  format(5x,a,t25,a,t50,f19.12)
1022  format(/10x,'Cartesian Gradient:')
1025  format(t20,d15.8,t40,d15.8,t60,d15.8)
1027  format(10x,'Cartesian Hessian (lower triangular):')
 
      write(outfile,1030)
1030  format(//,80('-'),/80('-')//2x,' MCCM, IB, MCSAC, and SAC ',
     *   'Calculations Requested by User:',//80('-')/)
      write(outfile,1070)
     
      do 60 i=1, nummc
         if (mcswit(1,i).ne.0) then
            write(outfile,1080) mcmlist(mcswit(1,i)), 
     *            verslist(mcswit(5,i)),
     *            fesmlist(mcswit(3,i)), fbaslist(mcswit(4,i)),
     *            mcener(i)
            if (type.eq.tgrad .or. type.eq.thess) then
               write(outfile,1022)
               write(outfile,1025) mcgrad(i,:n3tm)
               write(outfile,*)
            endif
            if (type.eq.thess) then
               write(outfile,1027)
               call mtoltm(mchess(i,:n3tm,:n3tm),hdisp,n3tm)
               write(outfile,1025) hdisp
               write(outfile,*)
            endif
         endif
  60  continue
1050  format(3x,a,t20,a,t35,a,t50,f19.12)

      if (ctr.gt.0) then
         write(outfile,1060)
         write(outfile,1070)
      endif

1060  format(//,80('-'),/80('-')//2x,' All Possible Lower Level ',
     *   'MCCM, IB, MCSAC, and SAC Calculations',/5x,'Using Default ', 
     *   'Coefficients:',//80('-')/)

1070  format(3x,'Method:',t15,'Version:',t30,'Theory:',t45,'Basis Set:',
     *       t60,'Energy:',//80('-')/)

1080  format(3x,a,t15,a,t30,a,t45,a,t60,f19.12)
      
      do 80 i=nummc+1, nummc+ctr
         write(outfile,1080) mcmlist(mcswit(1,i)),
     *         verslist(mcswit(5,i)),
     *         fesmlist(mcswit(3,i)), fbaslist(mcswit(4,i)),
     *         mcener(i)

         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1022)
            write(outfile,1025) mcgrad(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1027)
            call mtoltm(mchess(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1025) hdisp
            write(outfile,*)
         endif
  80  continue
  
      return
      end
c
c*****************************************************************************
c  HFMODISP
c*****************************************************************************
c
      subroutine hfmodisp ( natoms, type )
c
c     Subroutine mchdisp
c
c     Created:  July 12, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display all energies, gradients, and hessians calculated
c               for the HFMO method.
c
c     Called by:   hfmoehk, hfmoghk, hfmohhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use param, only : fesmlist, phf
      use files, only : outfile
      use energy, only : hfmoener
      use gradient, only : hfmograd
      use hessian, only : hfmohess
      implicit none

      integer  n3tm, natoms, type
      double precision  hdisp(3*natoms*(3*natoms+1)/2)

      n3tm = 3*natoms

      write(outfile,500)
 500  format(//,80('-'),/80('-')//3x,'HF||MO Calculation ',
     *   'Requested by the User',//80('-')/)

      write(outfile,1100) hfmoener(1)
      write(outfile,1200) hfmoener(2)
      write(outfile,1300) hfmoener(3)
   
1100  format(/5x,'HF Energy =',t25,f19.12)
1200  format(5x,'MO Energy =',t25,f19.12)
1300  format(5x,'HF||MO Energy =',t25,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,2100)
         write(outfile,2400) hfmograd(1,:n3tm)
         write(outfile,2200)
         write(outfile,2400) hfmograd(2,:n3tm)
         write(outfile,2300)
         write(outfile,2400) hfmograd(3,:n3tm)
      endif

2100  format(/5x,'HF Cartesian Gradient:')
2200  format(/5x,'MO Cartesian Gradient:')
2300  format(/5x,'HF||MO Cartesian Gradient:')
2400  format(t20,d15.8,t40,d15.8,t60,d15.8)

      if (type.eq.thess) then
         write(outfile,3100)

         call mtoltm(hfmohess(1,:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,2400) hdisp

         write(outfile,3200)
         call mtoltm(hfmohess(2,:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,2400) hdisp   

         write(outfile,3300)
         call mtoltm(hfmohess(3,:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,2400) hdisp
      endif

3000  format(//3x,'Hessians Calculated by the program ',
     *            a, ' for HF||MO',//80('-')/)
3100  format(/5x,'HF Cartesian Hessian (lower triang.):')
3200  format(/5x,'MO Cartesian Hessian (lower triang.):') 
3300  format(/5x,'HF||MO Cartesian Hessian (lower triang.):')

      return
      end
c  
c*****************************************************************************
c  MQCDISP
c*****************************************************************************
c  
      subroutine mqcdisp(natoms, type,ver_lab)
c  
c     Subroutine mqcdisp
c
c     Created:  January 12, 2000 by P. L. Fast
c     Revised:  Feb 24, 2002 by B. J. Lynch
c     Purpose:  Display the MCQC energies/grad/hess and all
c        components calculated by Gaussian.
c
c     Called by: mqcehk, mqcghk, mqchhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use gparam
      use files, only : outfile
      use energy, only : mqcener, mqces
      use gradient, only : mqcgrad, mqcesgr
      use hessian, only : mqchess, mqceshs
      implicit none

      integer natoms, type, i
      double precision hdisp(3*natoms*(3*natoms+1)/2)
      integer  n3tm
      character*20 ver_lab
 
      n3tm = 3*natoms
   
      write(outfile,1000)
1000  format(//,80('-'),/80('-'),//3x,
     *   'MC-QCISD Calculation:',//80('-'),/)

      write(outfile,1010)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)

      if((ver_lab(:3).eq.'v3m').or.(ver_lab(:3).eq.'v3s'))then          0224BL02
      do 10 i=1, 5                                                      0224BL02
         write(outfile,1020) fmqcesml_3(i),fmqcbasl_3(i),mqces(i)       0224BL02
         if (type.eq.tgrad .or. type.eq.thess) then                     0224BL02
            write(outfile,1030)                                         0224BL02
            write(outfile,1040) mqcesgr(i,:n3tm)                        0224BL02
            write(outfile,*)                                            0224BL02
         endif                                                          0224BL02
         if (type.eq.thess) then                                        0224BL02
            write(outfile,1045)                                         0224BL02
            call mtoltm(mqceshs(i,:n3tm,:n3tm),hdisp,n3tm)              0224BL02
            write(outfile,1040) hdisp                                   0224BL02
            write(outfile,*)                                            0224BL02
         endif                                                          0224BL02
  10  continue                                                          0224BL02

      else                                                              0224BL02
      do 40 i=1, nummqces
         write(outfile,1020) fmqcesml(i), fmqcbasl(i), mqces(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1030)
            write(outfile,1040) mqcesgr(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1045)
            call mtoltm(mqceshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1040) hdisp
            write(outfile,*)
         endif
  40  continue
      endif                                                             0224BL02


1020  format(5x,a,t25,a,t50,f19.12)
1030  format(/10x,'Cartesian Gradient:')
1040  format(t20,d15.8,t40,d15.8,t60,d15.8)
1045  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1050) mqcener

1050  format(//5x,'Multi-Coefficient QCISD Energy:',t50,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1040) mqcgrad(:3*natoms)
      endif

1062  format(//5x,'MC-QCISD Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile,1066)
         call mtoltm(mqchess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1040) hdisp
      endif

1066  format(//5x,'MC-QCISD Cartesian Hessian (lower triang.):')

      return
      end
c
c*****************************************************************************
c  MCOMP2DISP
c*****************************************************************************
c
      subroutine mcomp2disp(natoms, type, ver_lab)
c
c     Subroutine mcomp2disp
c
c     Created:  January 12, 2000 by P. L. Fast
c     Revised:  July 10, 2000 by Jingzhi Pu
c     Purpose:  Display the MCOMP2 energies/grad/hess and all
c        components calculated by Gaussian.
c
c     Called by: mcomp2ehk, mcomp2ghk, mcomp2hhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use gparam
      use files, only : outfile
      use energy, only : mcomp2ener, mcomp2es
      use gradient, only : mcomp2grad, mcomp2esgr
      use hessian, only : mcomp2hess, mcomp2eshs
      implicit none

      integer natoms, type, i
      double precision hdisp(3*natoms*(3*natoms+1)/2)
      integer  n3tm
      character*20 ver_lab

      n3tm = 3*natoms

      write(outfile,1000)
1000  format(//,80('-'),/80('-'),//3x,
     *   'MCOMP2 Calculation:',//80('-'),/)

      write(outfile,1010)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)

      if((ver_lab(:3).eq.'v3s').or.(ver_lab(:3).eq.'v3m'))then
      do 20 i=1, nummcomp2es
         write(outfile,1020) fmcomp2esml_3(i), fmcomp2basl_3(i), 
     *                       mcomp2es(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1030)
            write(outfile,1040) mcomp2esgr(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1045)
            call mtoltm(mcomp2eshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1040) hdisp
            write(outfile,*)
         endif
  20  continue
      else
      do 40 i=1, nummcomp2es
         write(outfile,1020) fmcomp2esml(i), fmcomp2basl(i), 
     *                       mcomp2es(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1030)
            write(outfile,1040) mcomp2esgr(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1045)
            call mtoltm(mcomp2eshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1040) hdisp
            write(outfile,*)
         endif
  40  continue
      endif

1020  format(5x,a,t25,a,t50,f19.12)
1030  format(/10x,'Cartesian Gradient:')
1040  format(t20,d15.8,t40,d15.8,t60,d15.8)
1045  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1050) mcomp2ener

1050  format(//5x,'MCOMP2 Energy:',t50,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1040) mcomp2grad(:3*natoms)
      endif

1062  format(//5x,'MCOMP2 Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile,1066)
         call mtoltm(mcomp2hess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1040) hdisp
      endif

1066  format(//5x,'MCOMP2 Cartesian Hessian (lower triang.):')

      return
      end
c*****************************************************************************
c  MCCODISP
c*****************************************************************************
c
      subroutine mccodisp(natoms, type, ver_lab)
c
c     Subroutine mccodisp
c
c     Created:  July 12, 2002 by B. J. Lynch
c     Revised:  
c     Purpose:  Display the MCCO energies/grad/hess and all
c        components calculated by Gaussian.
c
c     Called by: mccoehk, mccoghk, mccohhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use gparam
      use files, only : outfile
      use energy, only : mccoener, mccoes
      use gradient, only : mccograd, mccoesgr
      use hessian, only : mccohess, mccoeshs
      implicit none

      integer natoms, type, i
      double precision hdisp(3*natoms*(3*natoms+1)/2)
      integer  n3tm
      character*20 ver_lab

      n3tm = 3*natoms

      write(outfile,1000)
1000  format(//,80('-'),/80('-'),//3x,
     *   'MCCO Calculation:',//80('-'),/)

      write(outfile,1010)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)


      do 40 i=1, nummccoes
         write(outfile,1020) fmccoesml(i), fmccobasl(i), 
     *                       mccoes(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1030)
            write(outfile,1040) mccoesgr(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1045)
            call mtoltm(mccoeshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1040) hdisp
            write(outfile,*)
         endif
  40  continue

1020  format(5x,a,t25,a,t50,f19.12)
1030  format(/10x,'Cartesian Gradient:')
1040  format(t20,d15.8,t40,d15.8,t60,d15.8)
1045  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1050) mccoener

1050  format(//5x,'MCCO Energy:',t50,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1040) mccograd(:3*natoms)
      endif

1062  format(//5x,'MCCO Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile,1066)
         call mtoltm(mccohess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1040) hdisp
      endif

1066  format(//5x,'MCCO Cartesian Hessian (lower triang.):')

      return
      end
 
c
c*****************************************************************************
c  MG3DISP
c*****************************************************************************
c     
      subroutine mg3disp(natoms, type, ver_lab)
c     
c     Subroutine mg3disp
c
c     Created:  July 10, 1999 by J. M. Rodgers
c     Revised:  Feb 24, 2002 by B. J. Lynch
c     Purpose:  Display the MCG3 and MCG3 energies/grad/hess and all
c        components calculated by Gaussian.
c
c     Called by: mg3ehk, mg3ghk, mg3hhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use gparam
      use files, only : outfile
      use energy, only : mg3ener, mg3es
      use gradient, only : mg3grad, mg3esgr
      use hessian, only : mg3hess, mg3eshs
      implicit none

      character*20     ver_lab
      integer natoms, type, i
      double precision hdisp(3*natoms*(3*natoms+1)/2)
      integer  n3tm

      n3tm = 3*natoms
      
      write(outfile,1000)
1000  format(//,80('-'),/80('-'),//3x,
     *   'MCG3 Calculations:',//80('-'),/)

      write(outfile,1010)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)
      


C  if using version 3m or 3s diplay MCG3 differently
C
         if((ver_lab(:3).eq.'v3m').or.(ver_lab(:3).eq.'v3s'))then 
      do 10 i=1,  nummg3es-1
         write(outfile,1020) fmg3esml_3(i),fmg3basl_3(i),mg3es(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1030)
            write(outfile,1040) mg3esgr(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1045)
            call mtoltm(mg3eshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1040) hdisp
            write(outfile,*)
         endif
  10  continue

         else     
      do 40 i=1, nummg3es
         write(outfile,1020) fmg3esml(i), fmg3basl(i), mg3es(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1030)
            write(outfile,1040) mg3esgr(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1045)
            call mtoltm(mg3eshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1040) hdisp
            write(outfile,*)
         endif
  40  continue
         endif


1020  format(5x,a,t25,a,t50,f19.12)
1030  format(/10x,'Cartesian Gradient:')
1040  format(t20,d15.8,t40,d15.8,t60,d15.8)
1045  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1050) mg3ener

1050  format(//5x,'Multi-Coefficient G3 Energy:',t50,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1040) mg3grad(:3*natoms)
      endif

1062  format(//5x,'MCG3 Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile,1066)
         call mtoltm(mg3hess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1040) hdisp
      endif

1066  format(//5x,'MCG3 Cartesian Hessian (lower triang.):')

      return
      end
c
c*****************************************************************************
c  MG2DISP   
c*****************************************************************************
c
      subroutine mg2disp(natoms, type)
c        
c     Subroutine mg2disp
c
c     Created:  July 10, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display the MCG2 and MMCG2 energies/grad/hess and all
c        components calculated by Gaussian.
c
c     Called by: mg2ehk, mg2ghk, mg2hhk
c     Calls:  mtoltm
c     
c     Variables defined here:
c
      use caltyp
      use gparam
      use files, only : outfile
      use energy, only : mg2ener, mg2es
      use gradient, only : mg2grad, mg2esgr
      use hessian, only : mg2hess, mg2eshs

      implicit none
         
      integer natoms, type, i
      double precision hdisp(3*natoms*(3*natoms+1)/2)
      integer n3tm

      n3tm = 3*natoms
 
      write(outfile,1000)
1000  format(//,80('-'),/80('-'),//3x,
     *   'MCG2 Calculations:',//80('-'),/)
  
      write(outfile,1010)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)
 
      do 40 i=1, nummg2es
         write(outfile,1020) fmg2esml(i), fmg2basl(i), mg2es(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1030)
            write(outfile,1040) mg2esgr(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1045)
            call mtoltm(mg2eshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1040) hdisp
            write(outfile,*)
         endif
  40  continue
1020  format(5x,a,t25,a,t50,f19.12)
1030  format(/10x,'Cartesian Gradient:')
1040  format(t20,d15.8,t40,d15.8,t60,d15.8)
1045  format(10x,'Cartesian Hessians (lower triangular):')

      write(outfile,1050) mg2ener
  
1050  format(//5x,'Multi-Coefficient G2 Energy:',t50,f19.12)
 
      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1040) mg2grad(:n3tm)
      endif

1062  format(//5x,'MCG2 Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile,1066)
         call mtoltm(mg2hess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1040) hdisp
      endif

1066  format(//5x,'MCG2 Cartesian Hessians (lower triang.):')

      return
      end

c
c*****************************************************************************
c  G3SX(MP3) DISP
c*****************************************************************************
c
      subroutine g3sxmp3disp(natoms, type)
c
c     Subroutine g3sxmp3disp
c
c     Created: Oct 12, 2003 by Yan Zhao
c     Revised:
c     Purpose:  Display the G3SX(MP3) energies/grad/hess and all
c        components calculated by Gaussian.
c
c     Called by: g3sxmp3ehk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use gparam
      use files, only : outfile
      use energy, only : g3sxmp3ener, g3sxmp3es
      use gradient, only : g3sxmp3grad, g3sxmp3esgr
      use hessian, only : g3sxmp3hess, g3sxmp3eshs

      implicit none

      integer natoms, type, i
      double precision hdisp(3*natoms*(3*natoms+1)/2)
      integer n3tm

      n3tm = 3*natoms

      write(outfile,1000)
1000  format(//,80('-'),/80('-'),//3x,
     *   'G3SX(MP3) Calculations:',//80('-'),/)
 
      write(outfile,1010)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)

      do 40 i=1, numg3sxmp3es
       write(outfile,1020) fg3sxmp3esml(i),fg3sxmp3basl(i),g3sxmp3es(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1030)
            write(outfile,1040) g3sxmp3esgr(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1045)
            call mtoltm(g3sxmp3eshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1040) hdisp
            write(outfile,*)
         endif
  40  continue
1020  format(5x,a,t25,a,t50,f19.12)
1030  format(/10x,'Cartesian Gradient:')
1040  format(t20,d15.8,t40,d15.8,t60,d15.8)
1045  format(10x,'Cartesian Hessians (lower triangular):')

      write(outfile,1050) g3sxmp3ener
 
1050  format(//5x,'G3SX(MP3) Energy:',t50,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1040) g3sxmp3grad(:n3tm)
      endif

1062  format(//5x,'G3SX(MP3) Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile,1066)
         call mtoltm(g3sxmp3hess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1040) hdisp
      endif

1066  format(//5x,'G3SX(MP3) Cartesian Hessians (lower triang.):')

      return
      end


c
c*****************************************************************************
c  MC3BB DISP
c*****************************************************************************
c
      subroutine mc3bbdisp(natoms, type)
c
c     Subroutine mc3bbdisp
c
c     Created: Oct 12, 2003 by Yan Zhao
c     Revised:
c     Purpose:  Display the mc3bb energies/grad/hess and all
c        components calculated by Gaussian.
c
c     Called by: mc3bbehk, mc3bbghk, mc3bbhhk, mc3bbohk 
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use gparam
      use files, only : outfile
      use energy, only : mc3bbener, mc3bbes
      use gradient, only : mc3bbgrad, mc3bbesgr
      use hessian, only : mc3bbhess, mc3bbeshs

      implicit none

      integer natoms, type, i
      double precision hdisp(3*natoms*(3*natoms+1)/2)
      integer n3tm

      n3tm = 3*natoms

      write(outfile,1000)
1000  format(//,80('-'),/80('-'),//3x,
     *   'MC3BB Calculations:',//80('-'),/)

      write(outfile,1010)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)

      do 40 i=1, nummc3bbes
       write(outfile,1020) fmc3bbesml(i),fmc3bbbasl(i),mc3bbes(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1030)
            write(outfile,1040) mc3bbesgr(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1045)
            call mtoltm(mc3bbeshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1040) hdisp
            write(outfile,*)
         endif
  40  continue
1020  format(5x,a,t25,a,t50,f19.12)
1030  format(/10x,'Cartesian Gradient:')
1040  format(t20,d15.8,t40,d15.8,t60,d15.8)
1045  format(10x,'Cartesian Hessians (lower triangular):')

      write(outfile,1050) mc3bbener

1050  format(//5x,'MC3BB Energy:',t50,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1040) mc3bbgrad(:n3tm)
      endif

1062  format(//5x,'MC3BB Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile,1066)
         call mtoltm(mc3bbhess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1040) hdisp
      endif

1066  format(//5x,'MC3BB Cartesian Hessians (lower triang.):')

      return
      end


c
c*****************************************************************************
c  MC3MPW DISP
c*****************************************************************************
c
      subroutine mc3mpwdisp(natoms, type)
c
c     Subroutine mc3mpwdisp
c
c     Created: Oct 12, 2003 by Yan Zhao
c     Revised:
c     Purpose:  Display the mc3mpw energies/grad/hess and all
c        components calculated by Gaussian.
c
c     Called by: mc3mpwehk, mc3mpwghk, mc3mpwhhk, mc3mpwohk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use gparam
      use files, only : outfile
      use energy, only : mc3mpwener, mc3mpwes
      use gradient, only : mc3mpwgrad, mc3mpwesgr
      use hessian, only : mc3mpwhess, mc3mpweshs

      implicit none

      integer natoms, type, i
      double precision hdisp(3*natoms*(3*natoms+1)/2)
      integer n3tm

      n3tm = 3*natoms

      write(outfile,1000)
1000  format(//,80('-'),/80('-'),//3x,
     *   'MC3MPW Calculations:',//80('-'),/)

      write(outfile,1010)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)

      do 40 i=1, nummc3mpwes
       write(outfile,1020) fmc3mpwesml(i),fmc3mpwbasl(i),mc3mpwes(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile,1030)
            write(outfile,1040) mc3mpwesgr(i,:n3tm)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile,1045)
            call mtoltm(mc3mpweshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1040) hdisp
            write(outfile,*)
         endif
  40  continue
1020  format(5x,a,t25,a,t50,f19.12)
1030  format(/10x,'Cartesian Gradient:')
1040  format(t20,d15.8,t40,d15.8,t60,d15.8)
1045  format(10x,'Cartesian Hessians (lower triangular):')

      write(outfile,1050) mc3mpwener

1050  format(//5x,'MC3MPW Energy:',t50,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1040) mc3mpwgrad(:n3tm)
      endif

1062  format(//5x,'MC3MPW Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile,1066)
         call mtoltm(mc3mpwhess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1040) hdisp
      endif

1066  format(//5x,'MC3MPW Cartesian Hessians (lower triang.):')

      return
      end



c
c*****************************************************************************
c  MCODISP
c*****************************************************************************
c        
      subroutine mcodisp ( swit, max, bas1, bas2, mcoes, mcoesgr,
     *                        mcoeshs, natoms, type )
c
c     Subroutine mcodisp
c
c     Created:  July 12, 1999 by J. M. Rodgers   
c     Revised:
c     Purpose:  Display all energies, gradients, and hessians calculated
c               for MCCM-CO when a nonstandard form of the method is
c               chosen.
c
c     Called by:   mcoehk, mcoghk, mcohhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use param
      use files, only : outfile
      use energy, only : mcener
      use gradient, only : mcgrad
      use hessian, only : mchess
      implicit none

      double precision  mcoes(5,2)
      double precision  mcoesgr(5,2,3*natoms)
      double precision  mcoeshs(5,2,3*natoms, 3*natoms)
      double precision  hdisp(3*natoms*(3*natoms+1)/2)
      character*20  bas1, bas2
      integer n3tm, swit(5), type, natoms, max, i

      n3tm = 3*natoms

      write(outfile,1030)
1030  format(//,80('-'),/80('-')//3x, 'Non-Standard MCCM-CO ',
     *   'Calculation Requested by User:',//80('-')/)
      write(outfile,1040)
1040  format(5x,'Theory:',t25,'Basis Set:',t50,
     *   'Energy:',//80('-')/)

      do 90 i=max, 1, -1
         write(outfile, 1050) fesmlist(swit(i)),bas2,mcoes(i,2)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile, 1052)
            write(outfile, 1055) mcoesgr(i,2,:)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile, 1057)
            call mtoltm(mcoeshs(i,2,:,:),hdisp,n3tm)
            write(outfile,1055) hdisp
            write(outfile,*)
         endif
  90  continue
      do 95 i=max, 1, -1
         write(outfile, 1050) fesmlist(swit(i)),bas1,mcoes(i,1)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile, 1052)
            write(outfile, 1055) mcoesgr(i,1,:)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile, 1057)
            call mtoltm(mcoeshs(i,1,:,:),hdisp,n3tm)
            write(outfile,1055) hdisp
            write(outfile,*)
         endif
  95  continue

1050  format(5x,a,t25,a,t50,f19.12)
1052  format(/10x,'Cartesian Gradient:')
1055  format(t20,d15.8,t40,d15.8,t60,d15.8)
1057  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1060) mcener(pmco)
1060  format(/5x,'MCCM-CO Energy =',t30,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1055) mcgrad(pmco,:n3tm)
      endif
1062  format(/5x,'MCCM-CO Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile, 1065)
         call mtoltm(mchess(pmco,:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1055) hdisp
      endif
1065  format(/5x,'MCCM-CO Cartesian Hessian (lower triang.):')

      return
      end
c
c*****************************************************************************
c  MUTDISP
c*****************************************************************************
c
      subroutine mutdisp ( swit, max, bas1, bas2, mutes, mutesgr,
     *                        muteshs, natoms, type )
c     
c     Subroutine mutdisp
c
c     Created:  July 12, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display all energies, gradients, and hessians calculated
c               for MCCM-UT when a nonstandard form of the method is
c               chosen.
c
c     Called by:   mutehk, mutghk, muthhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use param
      use files, only : outfile
      use energy, only : mcener
      use gradient, only : mcgrad
      use hessian, only : mchess

      implicit none

      double precision  mutes(5,2)
      double precision  mutesgr(5,2,3*natoms)
      double precision  muteshs(5,2,3*natoms, 3*natoms)
      double precision  hdisp(3*natoms*(3*natoms+1)/2)
      character*20  bas1, bas2
      integer n3tm, swit(5), type, natoms, max, i
         
      n3tm = 3*natoms

      write(outfile,1030)
1030  format(//,80('-'),/80('-')//3x, 'Non-Standard MCCM-UT ',
     *   'Calculation Requested by User:',//80('-')/)
      write(outfile,1040)
1040  format(5x,'Theory:',t25,'Basis Set:',t50,
     *   'Energy:',//80('-')/)

      do 90 i=max, 1, -1
         write(outfile, 1050) fesmlist(swit(i)),bas1,mutes(i,1)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile, 1052)
            write(outfile, 1055) mutesgr(i,1,:)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile, 1057)
            call mtoltm(muteshs(i,1,:,:),hdisp,n3tm)
            write(outfile,1055) hdisp
            write(outfile,*)
         endif
  90  continue
      do 95 i=2, 1, -1
         write(outfile, 1050) fesmlist(swit(i)),bas2,mutes(i,2)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile, 1052)
            write(outfile, 1055) mutesgr(i,2,:)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile, 1057)
            call mtoltm(muteshs(i,2,:,:),hdisp,n3tm)
            write(outfile,1055) hdisp
            write(outfile,*)
         endif
  95  continue

1050  format(5x,a,t25,a,t50,f19.12)
1052  format(/10x,'Cartesian Gradient:')
1055  format(t20,d15.8,t40,d15.8,t60,d15.8)
1057  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1060) mcener(pmut)
1060  format(/5x,'MCCM-UT Energy =',t30,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1055) mcgrad(pmut,:n3tm)
      endif
1062  format(/5x,'MCCM-UT Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile, 1065)
         call mtoltm(mchess(pmut,:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1055) hdisp
      endif

1065  format(/5x,'MCCM-UT Cartesian Hessian (lower triang.):')

      return
      end
c
c*****************************************************************************
c  MNMDISP
c*****************************************************************************
c
      subroutine mnmdisp( swit, max, bas1, bas2, bas3, mnmes, mnmesgr,
     *                        mnmeshs, natoms, type )
c
c     Subroutine mnmdisp
c
c     Created:  July 12, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display all energies, gradients, and hessians calculated
c               for MCCM-NM when a nonstandard form of the method is
c               chosen.
c
c     Called by:   mnmehk, mnmghk, mnmhhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use param
      use files, only : outfile
      use energy, only : mcener
      use gradient, only : mcgrad
      use hessian, only : mchess

      implicit none
            
      double precision  mnmes(5,3)
      double precision  mnmesgr(5,3,3*natoms)
      double precision  mnmeshs(5,3,3*natoms, 3*natoms)
      double precision  hdisp(3*natoms*(3*natoms+1)/2)
      character*20  bas1, bas2, bas3
      integer n3tm, swit(5), type, natoms, max, i

      n3tm = 3*natoms

      write(outfile,1030)
1030  format(//,80('-'),/80('-')//3x, 'Non-Standard MCCM-NM ',
     *   'Calculation Requested by User:',//80('-')/)
      write(outfile,1040)
1040  format(5x,'Theory:',t25,'Basis Set:',t50,
     *   'Energy:',//80('-')/)

      do 90 i=max, 1, -1
         write(outfile, 1050) fesmlist(swit(i)), bas1, mnmes(i,1)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile, 1052)
            write(outfile, 1055) mnmesgr(i,1,:)
            write(outfile, *)
         endif
         if (type.eq.thess) then
            write(outfile, 1057)
            call mtoltm(mnmeshs(i,1,:,:),hdisp,n3tm)
            write(outfile,1055) hdisp
            write(outfile,*)
         endif
  90  continue
      do 95 i=2, 1, -1
         write(outfile, 1050) fesmlist(swit(i)), bas3, mnmes(i,2)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile, 1052)
            write(outfile, 1055) mnmesgr(i,2,:)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile, 1057)
            call mtoltm(mnmeshs(i,2,:,:),hdisp,n3tm)
            write(outfile,1055) hdisp
            write(outfile,*)
         endif
  95  continue
 
      write(outfile, 1050) fesmlist(swit(1)), bas2, mnmes(1,3)
      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile, 1052)
         write(outfile, 1055) mnmesgr(1,3,:)
         write(outfile,*)
      endif
      if (type.eq.thess) then
         write(outfile, 1057)
         call mtoltm(mnmeshs(1,3,:,:),hdisp,n3tm)
         write(outfile,1055) hdisp
         write(outfile,*)
      endif

1050  format(5x,a,t25,a,t50,f19.12)
1052  format(/10x,'Cartesian Gradient:')
1055  format(t20,d15.8,t40,d15.8,t60,d15.8)
1057  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1060) mcener(pmnm)
1060  format(/5x,'MCCM-NM Energy =',t30,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1055) mcgrad(pmnm,:n3tm)
      endif
1062  format(/5x,'MCCM-NM Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile, 1065)
         call mtoltm(mchess(pmnm,:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1055) hdisp
      endif
1065  format(/5x,'MCCM-NM Cartesian Hessian (lower triang.):')

      return
      end
c
c*****************************************************************************
c  MCSDISP
c*****************************************************************************
c
      subroutine mcsdisp ( swit, max, bas1, mcses, mcsesgr,
     *                        mcseshs, natoms, type )
c
c     Subroutine mcsdisp
c
c     Created:  July 12, 1999 by J. M. Rodgers   
c     Revised:
c     Purpose:  Display all energies, gradients, and hessians calculated
c               for MCSAC when a nonstandard form of the method is
c               chosen.
c
c     Called by:   mcsehk, mcsghk, mcshhk
c     Calls:  mtoltm
c     
c     Variables defined here:
c
      use caltyp
      use param
      use files, only : outfile
      use energy, only : mcener
      use gradient, only : mcgrad
      use hessian, only : mchess
      implicit none
      
      double precision  mcses(5)
      double precision  mcsesgr(5,3*natoms)
      double precision  mcseshs(5,3*natoms, 3*natoms)
      double precision  hdisp(3*natoms*(3*natoms+1)/2)
      character*20  bas1
      integer n3tm, swit(5), type, natoms, max, i
      
      n3tm = 3*natoms
 
      write(outfile,1030)
1030  format(//,80('-'),/80('-')//3x, 'Non-Standard MCSAC ',
     *   'Calculation Requested by User:',//80('-')/)
      write(outfile,1040)
1040  format(5x,'Theory:',t25,'Basis Set:',t50,
     *   'Energy:',//80('-')/)

      do 90 i=max, 1, -1
         write(outfile, 1050) fesmlist(swit(i)),bas1,mcses(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile, 1052)
            write(outfile, 1055) mcsesgr(i,:)
            write(outfile,*)
         endif
         if (type.eq.thess) then
            write(outfile, 1057)
            call mtoltm(mcseshs(i,:,:),hdisp,n3tm)
            write(outfile,1055) hdisp
            write(outfile,*)
         endif
  90  continue

1050  format(5x,a,t25,a,t50,f19.12)
1052  format(/10x,'Cartesian Gradient:')                                0809BL00
1055  format(t20,d15.8,t40,d15.8,t60,d15.8)
1057  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1060) mcener(pmcs)
1060  format(/5x,'MCSAC Energy =',t30,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1055) mcgrad(pmcs,:n3tm)
      endif
1062  format(/5x,'MCSAC Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile, 1065)
         call mtoltm(mchess(pmcs,:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1055) hdisp
      endif
1065  format(/5x,'MCSAC Cartesian Hessian (lower triang.):')

      return
      end
c
c*****************************************************************************
c  IBDISP 
c*****************************************************************************
c     
      subroutine ibdisp ( meth, bas1, bas2, ibes, ibesgr,
     *                        ibeshs, natoms, type )
c
c     Subroutine ibdisp
c
c     Created:  July 12, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display all energies, gradients, and hessians calculated
c               for IB when a nonstandard form of the method is
c               chosen.
c
c     Called by:   ibehk, ibghk, ibhhk
c     Calls:  mtoltm
c
c     Variables defined here:
c 
      use caltyp
      use param
      use files, only : outfile
      use energy, only : mcener
      use gradient, only : mcgrad
      use hessian, only : mchess

      implicit none

      double precision  ibes(2,2)
      double precision  ibesgr(2,2,3*natoms)
      double precision  ibeshs(2,2,3*natoms, 3*natoms)
      double precision  hdisp(3*natoms*(3*natoms+1)/2)
      character*20  meth, bas1, bas2
      integer n3tm, type, natoms

      n3tm = 3*natoms

      write(outfile,1030)
1030  format(//,80('-'),/80('-')//3x, 'Non-Standard IB ',
     *   'Calculation Requested by User:',//80('-')/)
      write(outfile,1040)
1040  format(5x,'Theory:',t25,'Basis Set:',t50,
     *   'Energy:',//80('-')/)

      write(outfile, 1050) meth,bas2,ibes(2,2)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile, 1052)
         write(outfile, 1055) ibesgr(2,2,:)
         write(outfile,*)
      endif
      if (type.eq.thess) then
         write(outfile, 1057)
         call mtoltm(ibeshs(2,2,:,:),hdisp,n3tm)
         write(outfile,1055) hdisp
         write(outfile,*)
      endif

      write(outfile, 1050) fesmlist(phf),bas2,ibes(1,2)
      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile, 1052)
         write(outfile, 1055) ibesgr(1,2,:)
         write(outfile,*)
      endif
      if (type.eq.thess) then
         write(outfile, 1057)
         call mtoltm(ibeshs(1,2,:,:),hdisp,n3tm)
         write(outfile,1055) hdisp
         write(outfile,*)
      endif

      write(outfile, 1050) meth,bas1,ibes(2,1)
      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile, 1052)
         write(outfile, 1055) ibesgr(2,1,:)
         write(outfile,*)
      endif
      if (type.eq.thess) then
         write(outfile, 1057)
         call mtoltm(ibeshs(2,1,:,:),hdisp,n3tm)
         write(outfile,1055) hdisp
         write(outfile,*)
      endif

      write(outfile, 1050) fesmlist(phf),bas1,ibes(1,1)
      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile, 1052)
         write(outfile, 1055) ibesgr(1,1,:)
         write(outfile,*)
      endif
      if (type.eq.thess) then
         write(outfile, 1057)
         call mtoltm(ibeshs(1,1,:,:),hdisp,n3tm)
         write(outfile,1055) hdisp
         write(outfile,*)
      endif

1050  format(5x,a,t25,a,t50,f19.12)
1052  format(/10x,'Cartesian Gradient:')
1055  format(t20,d15.8,t40,d15.8,t60,d15.8)
1057  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1060) mcener(pib)
1060  format(/5x,'IB Energy =',t30,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1055) mcgrad(pib,:n3tm)
      endif
1062  format(/5x,'IB Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile, 1065)
         call mtoltm(mchess(pib,:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1055) hdisp
      endif
1065  format(/5x,'IB Cartesian Hessian (lower triang.):')

      return
      end
c
c*****************************************************************************
c  SACDISP
c*****************************************************************************
c
      subroutine sacdisp ( meth, bas1, saces, sacesgr,
     *                        saceshs, natoms, type )
c
c     Subroutine sacdisp
c
c     Created:  July 12, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display all energies, gradients, and hessians calculated
c               for SAC when a nonstandard form of the method is
c               chosen.
c
c     Called by:   sacehk, sacghk, sachhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use param
      use files, only : outfile
      use energy, only : mcener
      use gradient, only : mcgrad
      use hessian, only : mchess

      implicit none
      
      double precision  saces(2)
      double precision  sacesgr(2,3*natoms)
      double precision  saceshs(2,3*natoms, 3*natoms)
      double precision  hdisp(3*natoms*(3*natoms+1)/2)
      character*20  meth, bas1
      integer n3tm, type, natoms

      n3tm = 3*natoms
      
      write(outfile,1030)
1030  format(//,80('-'),/80('-')//3x, 'Non-Standard SAC ',
     *   'Calculation Requested by User:',//80('-')/)
      write(outfile,1040)
1040  format(5x,'Theory:',t25,'Basis Set:',t50,
     *   'Energy:',//80('-')/)

      write(outfile, 1050) meth,bas1,saces(2)
      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile, 1052)
         write(outfile, 1055) sacesgr(2,:)
         write(outfile,*)
      endif
      if (type.eq.thess) then
         write(outfile, 1057)
         call mtoltm(saceshs(2,:,:),hdisp,n3tm)
         write(outfile,1055) hdisp
         write(outfile,*)
      endif

      write(outfile, 1050) fesmlist(phf),bas1,saces(1)
      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile, 1052) 
         write(outfile, 1055) sacesgr(1,:) 
         write(outfile,*)
      endif
      if (type.eq.thess) then
         write(outfile, 1057)
         call mtoltm(saceshs(1,:,:),hdisp,n3tm)
         write(outfile,1055) hdisp
         write(outfile,*)
      endif

1050  format(5x,a,t25,a,t50,f19.12)
1052  format(/10x,'Cartesian Gradient:')
1055  format(t20,d15.8,t40,d15.8,t60,d15.8)
1057  format(10x,'Cartesian Force Constants (lower triangular):')

      write(outfile,1060) mcener(psac)
1060  format(/5x,'SAC Energy =',t30,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1055) mcgrad(psac,:n3tm)
      endif
1062  format(/5x,'SAC Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile, 1065)
         call mtoltm(mchess(psac,:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1055) hdisp
      endif
1065  format(/5x,'SAC Cartesian Force Constants (lower triang.):')

      return
      end
c
c*****************************************************************************
c  G3DISP
c*****************************************************************************
c
      subroutine g3disp(natoms, type)
c
c     Subroutine g3disp
c
c     Created:  July 14, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display the G3 electronic energy and all components
c        calculated by Gaussian, as well as the SO and HLC corrections.
c
c     Called by: g3ehk, g3ghk, g3hhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use gparam
      use caltyp
      use files, only : outfile
      use energy, only : g3ener, g3es
      use gradient, only : g3grad, g3esgr
      use hessian, only : g3hess, g3eshs

      implicit none

      integer natoms, type, i, n3tm
      double precision  hdisp(3*natoms*(3*natoms+1)/2)

      n3tm = 3*natoms

      write(outfile,1000)
1000  format(//,80('-'),/80('-')//3x,'G3 Calculation:',//80('-')/)

      write(outfile,1010)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)

      do 40 i=1, numg3es
         write(outfile,1020) fg3esml(i), fg3basl(i), g3es(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile, 1022)
            write(outfile, 1025) g3esgr(i,:n3tm)
            write(outfile, *)
         endif
         if (type.eq.thess) then
            write(outfile, 1027)
            call mtoltm(g3eshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1025) hdisp
            write(outfile,*)
         endif
  40  continue

1020  format(5x,a,t25,a,t50,f19.12)
1022  format(/10x,'Cartesian Gradient:')
1025  format(t20,d15.8,t40,d15.8,t60,d15.8)
1027  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1030) g3es(pso)
      write(outfile,1040) g3es(phlc)

1030  format(/5x,'Spin-Orbit Energy Correction',t50,f19.12)
1040  format(5x,'Higher-Level Energy Correction',t50,f19.12)

      write(outfile,1050) g3ener
1050  format(//5x,'Gaussian-3 Electronic Energy:',t50,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1052)
         write(outfile,1025) g3grad(:n3tm)
      endif
1052  format(/5x,'G3 Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile,1055)
         call mtoltm(g3hess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1025) hdisp
      endif
1055  format(/5x,'G3 Cartesian Hessian (lower triang.):')

      return
      end
c         
c*****************************************************************************
c  G2DISP   
c*****************************************************************************
c
      subroutine g2disp(natoms, type)
c         
c     Subroutine g2disp
c         
c     Created:  July 14, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display the G2 electronic energy and all components
c        calculated by Gaussian, as well as the SO and HLC corrections.
c
c     Called by: g2ehk, g2ghk, g2hhk
c     Calls:  mtoltm
c
c     Variables defined here:
c 
      use gparam
      use caltyp
      use files, only : outfile
      use energy, only : g2ener, g2es
      use gradient, only : g2grad, g2esgr
      use hessian, only : g2hess, g2eshs
      
      implicit none

      integer natoms, type, i, n3tm
      double precision  hdisp(3*natoms*(3*natoms+1)/2)

      n3tm = 3*natoms
      
      write(outfile,1000)
1000  format(//,80('-'),/80('-')//3x,'G2 Calculation:',//80('-')/)
      
      write(outfile,1010)
1010  format(5x,'Theory:',t25,'Basis Set:',t50,'Energy:',//80('-')/)

      do 40 i=1, numg2es
         write(outfile,1020) fg2esml(i), fg2basl(i), g2es(i)
         if (type.eq.tgrad .or. type.eq.thess) then
            write(outfile, 1022)
            write(outfile, 1025) g2esgr(i,:n3tm)
            write(outfile, *)
         endif
         if (type.eq.thess) then
            write(outfile, 1027)
            call mtoltm(g2eshs(i,:n3tm,:n3tm),hdisp,n3tm)
            write(outfile,1025) hdisp
            write(outfile,*)
         endif
  40  continue

1020  format(5x,a,t25,a,t50,f19.12)
1022  format(/10x,'Cartesian Gradient:')
1025  format(t20,d15.8,t40,d15.8,t60,d15.8)
1027  format(10x,'Cartesian Hessian (lower triangular):')

      write(outfile,1040) g2es(phlc)

1040  format(/5x,'Higher-Level Energy Correction',t50,f19.12)
 
      write(outfile,1050) g2ener
1050  format(//5x,'Gaussian-2 Electronic Energy:',t50,f19.12)
      
      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1052)
         write(outfile,1025) g2grad(:n3tm)
      endif
1052  format(/5x,'G2 Cartesian Gradient:')

      if (type.eq.thess) then
         write(outfile,1055)
         call mtoltm(g2hess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile,1025) hdisp
      endif
1055  format(/5x,'G2 Cartesian Hessian (lower triang.):')

      return
      end
c
c*****************************************************************************
c  LOWDISP
c*****************************************************************************
c
      subroutine lowdisp ( natoms )
c
c     Subroutine lowdisp
c
c     Created:  August 4, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display low level hessian collected for ML optimization
c
c     Called by:   opthhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use param 
      use files, only : outfile
      use optimize, only : hess
      implicit none
      
      double precision, dimension(:), allocatable :: hdisp
      integer n3tm, natoms
      
      n3tm = 3*natoms
      
      allocate( hdisp(n3tm*(n3tm+1)/2) )
      
      write(outfile,1030)
1030  format(//,80('-'),/80('-')//3x,
     *   'Low Level Hessian Requested by User:',//80('-')/)
     
1055  format(t20,d15.8,t40,d15.8,t60,d15.8)

      write(outfile, 1065)
      call mtoltm(hess(:n3tm,:n3tm),hdisp,n3tm)
      write(outfile, 1055) hdisp

1065  format(/5x,'Cartesian Force Constants (lower triang.):')
       
      return
      end
c
c*****************************************************************************
c  TESTDISP
c*****************************************************************************
c
      subroutine testdisp ( natoms, type )
c
c     Subroutine testdisp
c
c     Created:  July 12, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display all energies, gradients, and hessians collected
c               for test in the ML optimization routine.
c
c     Called by:   optehk, optghk, opthhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use param
      use files, only : outfile
      use optimize, only : ener, grad, hess
      implicit none

      double precision, dimension(:), allocatable :: hdisp 
      integer n3tm, type, natoms

      n3tm = 3*natoms

      allocate( hdisp(n3tm*(n3tm+1)/2) )

c
c 
      write(outfile,1030)
1030  format(//,80('-'),/80('-')//3x,
     *   'Test Calculation Requested by User:',//80('-')/)
      
1055  format(t20,d15.8,t40,d15.8,t60,d15.8)
      
      write(outfile,1060) ener
1060  format(/5x,'Energy =',t30,f19.12)

      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,1062)
         write(outfile,1055) grad(:n3tm)
      endif
1062  format(/5x,'Cartesian Gradient:')
      
      if (type.eq.thess) then
         write(outfile, 1065)
         call mtoltm(hess(:n3tm,:n3tm),hdisp,n3tm)
         write(outfile, 1055) hdisp
      endif
1065  format(/5x,'Cartesian Force Constants (lower triang.):')

      return
      end
c
c*****************************************************************************
c  IMOHCDISP
c*****************************************************************************
c
      subroutine imohcdisp ( r, theta, phi, rgrad, agrad, torgrad, 
     *   rhess, ahess, torhess, ssnatm, lsnatm, type ) 
c
c     Subroutine imohcdisp
c
c     Created:  July 12, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display all energies, gradients, and hessians calculated
c               for IMOHC.
c
c     Called by:   imohcehk, imohcghk, imohchhk
c     Calls:  mtoltm
c
c     Variables defined here:
c
      use caltyp
      use files, only : outfile
      use energy, only : imohcener, imohces
      use gradient, only : imohcgrad, imohcesgr
      use hessian, only : imohchess, imohceshs

      implicit none

      integer natoms, type, i, n3ss, n3ls, n3tm, ssnatm, lsnatm
      double precision  hdisps(3*ssnatm*(3*ssnatm+1)/2)
      double precision  hdispl(3*lsnatm*(3*lsnatm+1)/2)
      double precision  hdispf(3*(lsnatm+1)*(3*(lsnatm+1)+1)/2)
      double precision r, theta, phi, rgrad(6), agrad(9), torgrad(12)
      double precision  rhess(6,6), ahess(9,9), torhess(12,12)

      n3ss = 3*ssnatm
      n3ls = 3*lsnatm
      n3tm = 3*(lsnatm+1)

      write(outfile,500)
 500  format(//,80('-'),/80('-')//3x,'IMOHC Calculation ',
     *   'Requested by the User',//80('-')/)

      write(outfile,1100) imohces(1)
      write(outfile,1200) imohces(2)
      write(outfile,1300) imohces(3)
      write(outfile,1400) r, theta, phi
      write(outfile,1500) imohcener
      
1100  format(/5x,'High Level/Small System Energy =',t50,f19.12)
1200  format(5x,'Low Level/Large System Energy =',t50,f19.12)
1300  format(5x,'Low Level/Small System Energy =',t50,f19.12)
1400  format(/5x,'R = ',f10.6,t30,'Theta = ',f10.6,t60,'Phi = ',f10.6)
1500  format(/5x,'IMOHC Energy =',t50,f19.12)


      if (type.eq.tgrad .or. type.eq.thess) then
         write(outfile,2100)
         write(outfile,2900) imohcesgr(1,:n3ss)
         write(outfile,2200)
         write(outfile,2900) imohcesgr(2,:n3ls)
         write(outfile,2300)
         write(outfile,2900) imohcesgr(3,:n3ss)
         write(outfile,2400)
         write(outfile,2900) rgrad(:6)
         write(outfile,2500)
         write(outfile,2900) agrad(:9)
         write(outfile,2600)
         write(outfile,2900) torgrad(:12)
         write(outfile,2700)
         write(outfile,2900) imohcgrad(:n3tm)
      endif
 
2100  format(//5x,'High Level/Small System Cartesian Gradient:')
2200  format(/5x,'Low Level/Large System Cartesian Gradient:')
2300  format(/5x,'Low Level/Small System Cartesian Gradient:')
2400  format(/5x,'Harmonic Bond Cartesian Gradient Correction:')
2500  format(/5x,'Harmonic Angle Cartesian Gradient Correction:')
2600  format(/5x,'Harmonic Torsion Cartesian Gradient Correction:')
2700  format(//5x,'IMOHC Cartesian Gradient:')
2900  format(t20,d15.8,t40,d15.8,t60,d15.8)

      if (type.eq.thess) then
         write(outfile,3100)
         call mtoltm(imohceshs(1,:n3ss,:n3ss),hdisps,n3ss)
         write(outfile,2900) hdisps
         write(outfile,3200)
         call mtoltm(imohceshs(2,:n3ls,:n3ls),hdispl,n3ls)
         write(outfile,2900) hdispl
         write(outfile,3300)
         call mtoltm(imohceshs(3,:n3ss,:n3ss),hdisps,n3ss)
         write(outfile,2900) hdisps
         write(outfile,3400)
         write(outfile,2900) rhess(:6,:6)
c
         write(outfile,*) rhess(1,1)
         write(outfile,*) rhess(2,2)
         write(outfile,*) rhess(3,3)
c
         write(outfile,3500)      
         write(outfile,2900) ahess(:9,:9)
         write(outfile,3600)      
         write(outfile,2900) torhess(:12,:12)
         write(outfile,3700)
         call mtoltm(imohchess(:n3tm,:n3tm),hdispf,n3tm)
         write(outfile,2900) hdispf
      endif

3100  format(/5x,'High Level/Small System Cartesian Hessian (l.t.):')
3200  format(/5x,'Low Level/Large System Cartesian Hessian (l.t.):')
3300  format(/5x,'Low Level/Small System Cartesian Hessian (l.t.):')
3400  format(/5x,'Harmonic Bond Cartesian Hessian Correction:')
3500  format(/5x,'Harmonic Angle Cartesian Hessian Correction:')
3600  format(/5x,'Harmonic Torsion Cartesian Hessian Correction:')
3700  format(//5x,'IMOHC Cartesian Hessian (lower triang.):')
3900  format(t20,d15.8,t40,d15.8,t60,d15.8)

      return
      end   


c
c*****************************************************************************
c  SUMDISP
c*****************************************************************************
c
      subroutine sumdisp(geom, n3tm, type, ltest, limohc, hfmoinp,
     *                   mcinp, mgswit)

c
c     Created by : Jingzhi Pu, April 2001
c     Purpose    : generate a summary output file providing information to
c                  interface program MULTILEVELRATE
c     called by  :
c                  main
c

c
      use param
      use caltyp
      use input, only    : cartgeom, mctype, mgtype, hfmoinf
      use files, only    : sumfile
      use optimize, only : ener, grad, hess
      use energy
      use gradient
      use hessian


      implicit none
c
      type (cartgeom) :: geom
      type (mctype)   :: mcinp
      type (mgtype)   :: mgswit
      type (hfmoinf)  :: hfmoinp
c
      integer limohc, ltest, n3tm, type, i, id
      double precision  hdisp(n3tm*(n3tm+1)/2)



c --- NATOMS
      write(sumfile,1210) geom%natoms
1210  format ('Number of Atoms', I3)


c --- CHARGE and MULTIPLICITY
      write(sumfile,1310) geom%charge
      write(sumfile,1360) geom%mult
1310  format('Charge',I3)
1360  format('Multiplicity',I3)



c --- GEOMETRY
      write(sumfile, 1410)
      write(sumfile, 1450)

      do i = 1, geom%natoms
          write(sumfile,1500)  geom%atm(i), geom%aucoord(3*i-2),
     *                         geom%aucoord(3*i-1), geom%aucoord(3*i)

      end do

      write(sumfile, 1550)
      do i = 1, geom%natoms
          write(sumfile,1500)  geom%atm(i), geom%angcoord(3*i-2),
     *                         geom%angcoord(3*i-1), geom%angcoord(3*i)

      end do


1410  format(/, 'Geometry')
1450  format(/2x,'Atomic Coordinates (in a.u.):',//8x,'Atom', t28, 'X',
     *         t48, 'Y', t68, 'Z'/)
1500  format(9x,a2,t20,d15.8,t40,d15.8,t60,d15.8)
1550  format(/2x,'Atomic Coordinates (in ang.):',//8x,'Atom', t28, 'X',
     *         t48, 'Y', t68, 'Z'/)



c --- ENERGY, GRADIENT, HESSIAN



c
c TEST
c
      if (ltest .eq. 1) then

          write(sumfile, 1060) ener
          if (type .eq. tgrad .or. type .eq. thess) then
              write(sumfile, 1062)
              write(sumfile, 1055) grad(:n3tm)
          end if
          if (type .eq. thess) then
              write(sumfile, 1065)
              call mtoltm(hess(:n3tm, :n3tm), hdisp, n3tm)
              write(sumfile, 1055) hdisp
          end if

c
c IMOHC
c
      else if (limohc .eq. 1) then

          write(sumfile, 1060) imohcener
          if (type .eq. tgrad .or. type .eq. thess) then
              write(sumfile, 1062)
              write(sumfile, 1055) imohcgrad(:n3tm)
          end if
          if (type .eq. thess) then
              write(sumfile, 1065)
              call mtoltm(imohchess(:n3tm, :n3tm), hdisp, n3tm)
              write(sumfile, 1055) hdisp
          end if


c
c HFMO
c
      else if (hfmoinp%lhfmo .eq. 1) then

          write(sumfile, 1060) hfmoener(3)
          if (type .eq. tgrad .or. type .eq. thess) then
              write(sumfile, 1062)
              write(sumfile, 1055) hfmograd(3,:n3tm)
          end if
          if (type .eq. thess) then
              write(sumfile, 1065)
              call mtoltm(hfmohess(3,:n3tm,:n3tm),hdisp, n3tm)
              write(sumfile, 1055) hdisp
          end if

c
c G2
c
      else if (mgswit%lg2 .eq. 1) then
           write(sumfile,1060) g2ener
           if (type .eq. tgrad .or. type .eq. thess) then
               write(sumfile, 1062)
               write(sumfile,1055) g2grad(:n3tm)
           end if
           if (type .eq. thess) then
               write(sumfile, 1065)
               call mtoltm(g2hess(:n3tm,:n3tm),hdisp, n3tm)
               write(sumfile, 1055) hdisp
           end if


c
c G3
c
      else if (mgswit%lg3 .eq. 1) then
           write(sumfile,1060) g3ener
           if (type .eq. tgrad .or. type .eq. thess) then
               write(sumfile, 1062)
               write(sumfile,1055) g3grad(:n3tm)
           end if
           if (type .eq. thess) then
               write(sumfile, 1065)
               call mtoltm(g3hess(:n3tm,:n3tm),hdisp, n3tm)
               write(sumfile, 1055) hdisp
           end if


c
c MCG2
c
      else if (mgswit%lmcg2 .eq. 1) then

           write(sumfile,1060) mg2ener
           if (type .eq. tgrad .or. type .eq. thess) then
               write(sumfile, 1062)
               write(sumfile,1055) mg2grad(:n3tm)
           end if

           if (type .eq. thess) then
               write(sumfile, 1065)
               call mtoltm(mg2hess(:n3tm,:n3tm),hdisp, n3tm)
               write(sumfile, 1055) hdisp
           end if

c
c MCG3
c
      else if (mgswit%lmcg3 .eq. 1) then

           write(sumfile,1060) mg3ener
           if (type .eq. tgrad .or. type .eq. thess) then
               write(sumfile, 1062)
               write(sumfile,1055) mg3grad(:n3tm)
           end if
           if (type .eq. thess) then
               write(sumfile, 1065)
               call mtoltm(mg3hess(:n3tm,:n3tm),hdisp, n3tm)
               write(sumfile, 1055) hdisp
           end if


c
c MC-QCISD
c
      else if (mgswit%lmqcisd .eq. 1) then

           write(sumfile,1060) mqcener
           if (type .eq. tgrad .or. type .eq. thess) then
               write(sumfile, 1062)
               write(sumfile,1055) mqcgrad(:n3tm)
           end if
           if (type .eq. thess) then
               write(sumfile, 1065)
               call mtoltm(mqchess(:n3tm,:n3tm),hdisp, n3tm)
               write(sumfile, 1055) hdisp
           end if

c
c MCOMP2
c
      else if (mgswit%lmcomp2 .eq. 1) then

           write(sumfile,1060) mcomp2ener
           if (type .eq. tgrad .or. type .eq. thess) then
               write(sumfile, 1062)
               write(sumfile,1055) mcomp2grad(:n3tm)
           end if
           if (type .eq. thess) then
               write(sumfile, 1065)
               call mtoltm(mcomp2hess(:n3tm,:n3tm),hdisp, n3tm)
               write(sumfile, 1055) hdisp
           end if
c
c MCCO
c
      else if (mgswit%lmcco .eq. 1) then

           write(sumfile,1060) mccoener
           if (type .eq. tgrad .or. type .eq. thess) then
               write(sumfile, 1062)
               write(sumfile,1055) mccograd(:n3tm)
           end if
           if (type .eq. thess) then
               write(sumfile, 1065)
               call mtoltm(mccohess(:n3tm,:n3tm),hdisp, n3tm)
               write(sumfile, 1055) hdisp
           end if


c
c MC3BB
c
      else if (mgswit%lmc3bb .eq. 1) then

           write(sumfile,1060) mc3bbener
           if (type .eq. tgrad .or. type .eq. thess) then
               write(sumfile, 1062)
               write(sumfile,1055) mc3bbgrad(:n3tm)
           end if
           if (type .eq. thess) then
               write(sumfile, 1065)
               call mtoltm(mc3bbhess(:n3tm,:n3tm),hdisp, n3tm)
               write(sumfile, 1055) hdisp
           end if

c
c MC3MPW
c
      else if (mgswit%lmc3mpw .eq. 1) then

           write(sumfile,1060) mc3mpwener
           if (type .eq. tgrad .or. type .eq. thess) then
               write(sumfile, 1062)
               write(sumfile,1055) mc3mpwgrad(:n3tm)
           end if
           if (type .eq. thess) then
               write(sumfile, 1065)
               call mtoltm(mc3mpwhess(:n3tm,:n3tm),hdisp, n3tm)
               write(sumfile, 1055) hdisp
           end if



c
c G3SX(MP3) 
c
      else if (mgswit%lg3sxmp3 .eq. 1) then

           write(sumfile,1060) g3sxmp3ener
           if (type .eq. tgrad .or. type .eq. thess) then
               write(sumfile, 1062)
               write(sumfile,1055) g3sxmp3grad(:n3tm)
           end if
           if (type .eq. thess) then
               write(sumfile, 1065)
               call mtoltm(g3sxmp3hess(:n3tm,:n3tm),hdisp, n3tm)
               write(sumfile, 1055) hdisp
           end if


c
c SAC, MCSAC, IB, or MCCM
c
      else
          if (mcinp%lmccmco .eq. 1) then
              id = pmco
          else if (mcinp%lmccmnm .eq. 1) then
              id = pmnm
          else if (mcinp%lib .eq. 1) then
              id = pib
          else if(mcinp%lmcsac .eq. 1) then
              id = pmcs
          else if (mcinp%lsac .eq. 1) then
              id = psac
          end if

          write(sumfile,1060) mcener(id)

          if (type.eq.tgrad .or. type.eq.thess) then
              write(sumfile,1062)
              write(sumfile, 1055) mcgrad(id,:n3tm)
          end if

          if (type.eq.thess) then
              write(sumfile, 1065)
              call mtoltm(mchess(id,:n3tm,:n3tm),hdisp,n3tm)
              write(sumfile, 1055) hdisp
          end if

      end if

      write(sumfile, 1070)

1055  format(t20,d15.8,t40,d15.8,t60,d15.8)
1060  format(/,'Total energy',f19.12)
1062  format(/,'Cartesian Gradients')
1065  format(/, 'Cartesian Force Constants')
1070  format(//)


      return
      end

