c
c******************************************************************************
c  MLOHOOK
c******************************************************************************
c
      subroutine mlohook(progrms, geom, optinp, hfmoinp, mcoptl, sacinp,
     *   mcsinp, ibinp, mcoinp, mnminp, mutinp, g2inp, mg2inp, g3inp,
     *   mg3inp, mqcinp, mcomp2inp, mccoinp,g3sxmp3inp, mc3bbinp,       0713BL02
     *   mc3mpwinp,imohcinp, tmeth, tbas, toptl, ierr)                  0112PF00
c  
c     Subroutine mlohook
c
c     Created:  July 13, 1999 by J. M. Rodgers
c     Revised:  January 12, 2000 by P. L. Fast
c     Purpose:  To call the appropriate appropriate optimization
c        subroutine.  All information to get the requested energies,
c        gradients and hessians is stored in mlinp
c
c     Currently only the NEWT optimizer is available for optimization.
c
c     Called by:  main
c     Calls: newt, newt2
c
c     Variables defined here:
c
      use files, only : outfile
      use input, only : cartgeom, mlopt, hfmoinf, mcinf,
     *                   ginf, mginf, mlinp, imoinf, proglist

      implicit none
c
      integer            ierr, i, n
      integer, dimension(:), allocatable :: ind
      character*20       mlmeth, tmeth, tbas
      type (cartgeom) :: geom
      type (mlopt)    :: optinp
      type (hfmoinf)  :: hfmoinp
      character*80    :: mcoptl(5), toptl(5)
      type (mcinf)    :: sacinp, mcsinp, ibinp, mcoinp, mnminp, mutinp   
      type (ginf)     :: g2inp, g3inp
      type (mginf)    :: mg2inp, mg3inp, mqcinp,mc3mpwinp,              0112PF00
     *                   mcomp2inp, mccoinp, g3sxmp3inp,mc3bbinp        0713BL02
      type (imoinf)   :: imohcinp
      type (proglist) :: progrms
      character*10     :: aswit(0:5)                                    1026PJ04

      double precision, parameter :: angtoau = 0.52918d0

      data aswit /'NR','BFGS','DFP','EF','GAUEXT','NEB'/                1026PJ04

      allocate( ind(3*geom%natoms-5) )
c
c  Initialize the optimization portion of the output file
c
      write(outfile,1100) optinp%mlmeth, aswit(optinp%algrthm)
1100  format(/2(/80('-')),//2x,'Multilevel Optimization',/5x,
     *  'Method:',t20,a,/5x,'Algorithm:',t20,a,//80('-')/)
c
c  Set up indices to be optimized
c
      n = 0
      do 21 i=1, 3*geom%natoms
         if (optinp%constant(i).eq.0) then
            n = n+1
            ind(n) = i
         endif
  21  continue
c
c  Reorient the molecule along the appropriate axes
c
      mlinp%geom = geom
      if (optinp%algrthm .ne. 4 .and. optinp%algrthm .ne. 5) then       0714NG04
       call rotmol(geom%aucoord, mlinp%geom%aucoord, geom%natoms, 
     *    optinp%constant, optinp%iop)
       mlinp%geom%angcoord = angtoau*mlinp%geom%aucoord
      endif
c
c  Determine type of optimization occuring and set appropriate slot in 
c    the structure mlinp.
c
      mlmeth(:) = optinp%mlmeth(:)

      mlinp%progrms = progrms
      mlinp%mlmeth(:) = optinp%mlmeth(:)
      do 5 i=1, 4
         mlinp%mcoptl(i) = mcoptl(i)                                    0112PF00
   5  continue
      mlinp%htyp = optinp%htyp
      mlinp%hbas = optinp%hbas
      mlinp%hmeth = optinp%hmeth
      mlinp%tbas = tbas
      mlinp%tmeth = tmeth
      mlinp%toptl = toptl
      mlinp%hscale = optinp%hscale
      if (mlmeth(:4) .eq. 'hfmo') then
         mlinp%hfmoinp = hfmoinp
      elseif (mlmeth(:6) .eq. 'mccmco') then
         mlinp%mcinp   = mcoinp
      elseif (mlmeth(:6) .eq. 'mccmnm') then
         mlinp%mcinp   = mnminp
      elseif (mlmeth(:6) .eq. 'mccmut') then
         mlinp%mcinp   = mutinp
      elseif (mlmeth(:5) .eq. 'mcsac')  then
         mlinp%mcinp   = mcsinp
      elseif (mlmeth(:2) .eq. 'ib')	then
         mlinp%mcinp   = ibinp
      elseif (mlmeth(:3) .eq. 'sac')    then
         mlinp%mcinp   = sacinp
      elseif (mlmeth(:2) .eq. 'g2')     then
         mlinp%ginp    = g2inp
      elseif (mlmeth(:7) .eq. 'g3sxmp3') then                           1220YZ03
         mlinp%mginp   = g3sxmp3inp                                     1220YZ03
      elseif (mlmeth(:2) .eq. 'g3')     then
         mlinp%ginp    = g3inp
      elseif (mlmeth(:4) .eq. 'mcg2')   then
         mlinp%mginp   = mg2inp
      elseif (mlmeth(:4) .eq. 'mcg3')   then
         mlinp%mginp   = mg3inp
      elseif (mlmeth(:7) .eq. 'mcqcisd') then                           0112PF00
         mlinp%mqinp   = mqcinp                                         0112PF00
      elseif (mlmeth(:6) .eq. 'mcomp2') then                            0710PJ00
         mlinp%mqinp   = mcomp2inp                                      0710PJ00
      elseif (mlmeth(:4) .eq. 'mcco') then                              0713BL02
         mlinp%mqinp   = mccoinp                                        0713BL02
      elseif (mlmeth(:5) .eq. 'mc3bb') then                             1220YZ03
         mlinp%mginp   = mc3bbinp                                       1220YZ03
      elseif (mlmeth(:6) .eq. 'mc3mpw') then                            1220YZ03
         mlinp%mginp   = mc3mpwinp                                      1220YZ03
      elseif (mlmeth(:5) .eq. 'imohc')  then
         mlinp%imohcinp = imohcinp
      endif
c
c  Call the appropriate optimization algorithm based on the user input.
c  Currently only the NR, DFP, and BFGS algorithms are supported (in
c  newt and newt2).
c
       if (optinp%algrthm.eq.0) then
         call newt(optinp, ind, n, ierr)
       elseif (optinp%algrthm.eq.1 .or. optinp%algrthm.eq.2) then
         call newt2(optinp, ind, n, ierr)
       elseif (optinp%algrthm.eq.3) then
         call ef(optinp, ind, n, ierr)
       elseif (optinp%algrthm.eq.4) then
         call gau_ext_opt(optinp,geom,ierr,progrms)                     0808RMP12
         return
       elseif (optinp%algrthm.eq.5) then                                0714NG04
         call nebmin(optinp,ind,n*optinp%nebinp%nimg,ierr)              0714NG04
         return                                                         0714NG04
      endif
c
c  Set geom to new geometry (in initial orientation) if optimization
c       successful.  And print out the reoriented geometry.
c
      if (ierr.eq.0 .and. optinp%reorient.eq.1) then
         call rotmol(mlinp%geom%aucoord, geom%aucoord, geom%natoms, 
     *       optinp%constant, -optinp%iop)
         geom%angcoord = angtoau*geom%aucoord
         write(outfile,1400)
         write(outfile,1450)
         do 20 i=1, geom%natoms
            write(outfile,1500)  geom%atm(i), geom%aucoord(3*i-2),
     *          geom%aucoord(3*i-1), geom%aucoord(3*i)
  20     continue
         write(outfile,1550)
         do 40 i=1, geom%natoms
            write(outfile,1500)  geom%atm(i), geom%angcoord(3*i-2),
     *         geom%angcoord(3*i-1), geom%angcoord(3*i)
  40     continue
         write(outfile,*)
      elseif (ierr.eq.0) then
         geom%aucoord = mlinp%geom%aucoord
         geom%angcoord = mlinp%geom%angcoord
      endif

1400  format(/2(/80('-')),//2x,'Geometry after Reorientation:',
     *     //80('-')/)
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'/)

      return
      end
c
c******************************************************************************
c  NEWT
c******************************************************************************
c
      subroutine newt(optinp, ind, n, ierr)
c
c     Subroutine newt
c
c     Created:  July 14, 1999 by J. M. Rodgers
c               Adapted from the NEWT routines in Ben's IMOHC code
c                 and in POLYRATE.
c     Revised:
c     Purpose:  To perform NR optimization with Brent line minimization.
c        For each iteration the gradient is recalculated and the hessian
c        may or may not be depending on HREC as specified in the input
c     
c     Called by:  mlohook
c     Calls:  optghk, opthhk, optdisp, ludcmp, lubksb, linmn
c
c     Variables defined here:  none.
c
      use files, only : outfile
      use caltyp, only : tgrad
      use input, only : mlopt, mlinp
      use optimize, only : ener, grad, hess
      
      implicit none
c
      integer            ierr
      type (mlopt)    :: optinp
      logical         :: check

      integer, dimension(:), allocatable :: work, indx
      integer  idorec, nrecal, n3tm, jrank, n, ind(n)
      integer  its, mxind, fail, linmin, i, j, status, k
      double precision, dimension(:), allocatable :: xxi, x0, dx0,
     *    prod, tempsol
      double precision, dimension(:,:), allocatable :: luhess
      double precision  gtol, h2, gcomp, abxxi, fret, abgc,
     *    stepc, stepmx, d, sum, detf, chksum

      double precision, parameter :: eps = 1.0d-14
      double precision, parameter :: angtoau = 0.52918d0
      double precision, parameter :: maxstep = 1.0d0

      n3tm = 3*mlinp%geom%natoms

      allocate (work(n3tm), xxi(n3tm), x0(n3tm), dx0(n3tm), 
     *    prod(n3tm), indx(n3tm), luhess(n,n), tempsol(n) )

      fail = 0
      idorec = optinp%hrec
      nrecal = 0
      linmin = 1
      status = 0

      if (optinp%iop .gt. 4) then
         linmin = 0
      endif
c
c  Set up the default convergent values for the energy and derivative
c
      if (optinp%gcomp .le. eps) then
         gtol = 1.0d-7
      else
         gtol = optinp%gcomp
      endif
      if (optinp%niter .lt. 0) goto 300
      h2 = 2.0d0*optinp%dlx2
c
c  Get initial gradient
c
      call optghk

      gcomp = abs( grad(1) )
      do 5 i=2, n3tm
         abgc = abs( grad(i) )
         if (gcomp.lt.abgc)  gcomp = abgc
   5  continue
c
c  Make initial display of info
c
         do 10 i=1, n3tm
            xxi(i) = 0.0000d0
  10     continue
         call optdisp(0, mlinp%geom, ener, grad(:n3tm), xxi(:n3tm),
     *           gcomp, gtol)
c
c  Check if the geometry is already optimized.
c
      if (gcomp.le.gtol) then
         status = 3
         goto 300
      endif
c
c  Get initial hessian (by hhook if INITHESS is on;  I otherwise)
c
      if (optinp%ihunit.eq.1) then
         call opthhk
      elseif (optinp%ihunit.eq.0) then
         do 21 i=1, n3tm
            do 22 j=1, n3tm
               hess(i,j) = 0.0d0
  22        continue
            hess(i,i) = optinp%hscale
  21     continue
      endif
c
c  MAIN LOOP to perform the geometry optimization
c
      do 200 its=1, optinp%niter
c
c  initialize dx0 and x0
c
         do 40 i=1, n3tm
            dx0(i) = grad(i)
            x0(i) = mlinp%geom%aucoord(i)
  40     continue
c         write(outfile,'(/,a,i3)') 'Initial geometry at step ', its
c         write(outfile,1018) x0
1018     format(3(1x,f10.6))
c         write(outfile,'(/,a,i3)') 'Initial gradient at step ', its
c         write(outfile,1023) dx0
1023     format(3(1x,d15.8))
c
c  Write out the Hessian.
c
         write(outfile,'(/a)') 'Hessian:'
         write(outfile,'(6(1x,d12.5))') hess(:n3tm,:n3tm)
c
c  Calculate Newton-Raphson step - different from way done in Polyrate
c
         do 29 i=1, n
            tempsol(i) = -dx0(ind(i))
            do 30 j=1, n
               luhess(i,j) = hess(ind(i),ind(j))
  30        continue
  29     continue
         call ludcmp(luhess, n, n, indx, d)
c
c  Write out the LU decomposed Hessian
c
         write(outfile,'(/a)') 'LU Decomposed Hessian:'
         write(outfile,'(6(1x,d12.5))') luhess(:n,:n)
         call lubksb(luhess, n, n, indx, tempsol)
c
c  Check solution to H*XXI = -Grad
c
         do 41 i=1, n
            prod(i) = 0.0d0
            do 42 j=1, n
               prod(i) = prod(i) + hess(ind(i),ind(j))*tempsol(j)
  42        continue
  41     continue

         chksum = 0.0d0
         do 59 i=1, n
            chksum = chksum + prod(i) + grad(ind(i))
  59     continue

c         write(outfile,'(/a,3x,d12.5)') 'Sum that should be ~0:',
c     *           chksum

         do 43 i=1, n3tm
            xxi(i) = 0.0000d0
  43     continue
         do 44 i=1, n
            xxi(ind(i)) = tempsol(i)
  44     continue

         write(outfile,'(/a,i3)') 'Calculated XXI at step ', its
         write(outfile,1023) xxi(:n3tm)
c
c  Scale calculated step so that rms value not greater than scale
c
         sum = 0.0d0
         do 7 i=1, n3tm
            sum = sum + xxi(i)*xxi(i)
   7     continue
         sum = sqrt(sum)
         if (sum.gt.optinp%scale)  xxi = xxi*optinp%scale/sum

         stepc = abs(xxi(1))
         mxind = 1
         do 105 i=2, n3tm
            abxxi = abs(xxi(i))
            if (stepc.lt.abxxi) then
                stepc = abxxi
                mxind = i
            endif
 105     continue
         write(outfile,'(/,a,i3)') 'XXI at step ', its
         write(outfile,1018) xxi
c
c  Add to make sure that step not zero before send into linmn.
c
         if (stepc .eq. 0.0d0) then
            status = 4
            goto 300
         endif
c
c  ... then scale the Newton-Raphson step (yet not bigger than scale)
c
         stepmx = optinp%scale/stepc
         if (linmin.eq.1) then

            call linmn(x0, xxi, n3tm, fret, stepmx)
            sum = 0.0d0
            do 8 i=1, n3tm
               sum = sum + xxi(i)*xxi(i)
   8        continue
            sum = sqrt(sum)
            if (sum.gt.optinp%scale)  xxi = xxi*optinp%scale/sum
            stepc = abs(xxi(mxind))
         endif
c
c  Move to a new geometry and calculate new energy and gradient
c  Be careful with units - Gaussian is called with angcoord, yet the
c    optimizer operates on aucoord
c
         do 120 i=1, n3tm
            mlinp%geom%aucoord(i) = x0(i) + xxi(i)
 120     continue
         mlinp%geom%angcoord = mlinp%geom%aucoord*angtoau

c         write(outfile,'(/,a)') 'Ang. Geom after step'
c         write(outfile,1018) mlinp%geom%angcoord(:n3tm)         
c         write(outfile,'(/,a)') 'A.U. Geom after step'
c         write(outfile,1018) mlinp%geom%aucoord(:n3tm)
c
c  Get gradient and energy
c
         call optghk

         gcomp = abs(grad(1))
         do 130 i=2, n3tm
            abgc = abs(grad(i))
            if (gcomp.lt.abgc)  gcomp=abgc
 130     continue
c
c  Test for convergence
c
         if (gcomp.le.gtol) then
            status = 1
            goto 300
         endif
c
c  Test for magnitude of stepsize
c
         if (stepc.lt.optinp%stptol) then
            fail = 1
            write(outfile, 1350) stepc
1350        format(/,'Maximum displacement component change smaller ',
     *               'than STPTOL:',3x,d12.5)
            if (optinp%retry .eq. 0)  then
               status = 2
               goto 300
            endif
         endif

         if (fail .eq. 1) then
            write(outfile, 1375)
1375        format(/,'Switching to full Newton optimization')
            idorec = 1
            nrecal = idorec
            linmin = 0
            fail = 0
         else
            nrecal = nrecal+1
         endif
c
c  Display current step in optimization
c
         call optdisp(its, mlinp%geom, ener, grad(:n3tm), xxi(:n3tm), 
     *           gcomp, gtol)
c
c  Get new hessian if necessary (but not if on last step of optimization.
c
         if (nrecal.eq.idorec .and. its.ne.optinp%niter) then
            nrecal = 0
            write (outfile, 1400)
1400        format(/,'Hessian recalculated.')
            call opthhk 
         else
            write (outfile, 1450)
1450        format(/,'Hessian kept frozen.')
         endif
 200  continue
c
c  If at this point the iterations have maxed out - print message and 
c    exit routine.
c
      write (outfile, 2200)
2200  format (/5x,'OPTIMIZATION FAILURE: Max iterations reached.',/)
      ierr = 1
 
      return

 300  continue
c
c  Display final step in optimization and print appropriate exit message.
c

      if (status .eq. 1) then
         call optdisp(its, mlinp%geom, ener, grad(:n3tm), xxi(:n3tm),
     *           gcomp, gtol)
         write (outfile, 2000)
      elseif (status .eq. 2) then
         call optdisp(its, mlinp%geom, ener, grad(:n3tm), xxi(:n3tm),
     *           gcomp, gtol)
         write (outfile, 2100)
         ierr = 1
      elseif (status .eq. 3) then
         write (outfile, 2300)
      elseif (status .eq. 4) then
         write (outfile, 2400)
         ierr = 1
      endif

      return

2000  format (/80('*'),/28x,'OPTIMIZATION SUCCESSFUL.',
     *          /80('*'),/)
2100  format (/5x,'OPTIMIZATION FAILURE: Geometry not changing.',/)
2300  format (/80('*'),/26x,'GEOMETRY ALREADY OPTIMIZED.',
     *          /80('*'),/)
2400  format (/5x,'OPTIMIZATION FAILURE: Step Size is 0.',/)

      end
c
c******************************************************************************
c  NEWT2
c******************************************************************************
c
      subroutine newt2(optinp, ind, n, ierr)
c
c     Subroutine newt
c
c     Created:  July 30, 1999 by J. M. Rodgers
c               Adapted from the NEWT routines in Ben's IMOHC code
c                 and in POLYRATE with the update formulas taken from
c                 Numerical Recipes (instead of polyrate).
c     Revised:
c     Purpose:  To perform NR optimization with BFGS or DFP hessian
c        updates by calling the appropriate ghook based on the user input.
c        Currently only valid for use with the scaled unit hessian.
c 
c     NOTE: testing on methanol has shown updates on the unit matrix to be
c        an inefficient idea.
c     
c     Called by:  mlohook
c     Calls:  optghk, opthhk, optdisp, linmn, mxlneq
c
c     Variables defined here:  none.
c
      use files, only : outfile
      use input, only : mlopt, mlinp
      use optimize, only : ener, grad, hess
      
      implicit none
c
      integer            ierr
      type (mlopt)    :: optinp
      logical         :: check

      integer, dimension(:), allocatable :: work
      integer  idorec, nrecal, n3tm, n, ind(n)
      integer  jrank, its, mxind, fail, linmin, i, j, status, k
      double precision, dimension(:), allocatable :: xxi, x0, dx0,
     *    deltag, prod, hdg
      double precision, dimension(:,:), allocatable :: hessin
      double precision  gtol, h2, gcomp, abxxi, fret, abgc,
     *    detf, stepc, stepmx, d, fac, fae, sumdg, sumxi, fad, sum

      double precision, parameter :: eps = 1.0d-14
      double precision, parameter :: angtoau = 0.52918d0
      double precision, parameter :: maxstep = 1.0d0

      n3tm = 3*mlinp%geom%natoms

      allocate (work(n3tm), xxi(n3tm), x0(n3tm), dx0(n3tm), 
     *    deltag(n), hessin(n,n), prod(n3tm), hdg(n) )

      fail = 0
      idorec = optinp%hrec
      nrecal = 0
      linmin = 1
      status = 0

      if (optinp%iop .gt. 4) then
         linmin = 0
      endif
c
c  Set up the default convergent values for the energy and derivative
c
      if (optinp%gcomp .le. eps) then
         gtol = 1.0d-7
      else
         gtol = optinp%gcomp
      endif
      if (optinp%niter .lt. 0) goto 300
      h2 = 2.0d0*optinp%dlx2
c
c  Get initial gradient
c
      call optghk

      gcomp = abs( grad(1) )
      do 5 i=2, n3tm
         abgc = abs( grad(i) )
         if (gcomp.lt.abgc)  gcomp = abgc
   5  continue
c
c  Make initial display of info
c
         do 10 i=1, n3tm
            xxi(i) = 0.0000d0
  10     continue
         call optdisp(0, mlinp%geom, ener, grad(:n3tm), xxi(:n3tm),
     *           gcomp, gtol)
c
c  Check if the geometry is already optimized.
c
      if (gcomp.le.gtol) then
         status = 3
         goto 300
      endif
c
c  Set initial hessian (by hhook if INITHESS is on; I otherwise)
c
      if (optinp%ihunit.eq.1) then
         call opthhk
      elseif (optinp%ihunit.eq.0) then
         do 21 i=1, n3tm
            do 22 j=1, n3tm
               hess(i,j) = 0.0d0
  22        continue
            hess(i,i) = optinp%hscale
  21     continue
      endif
c
c  Get inverse of the small hessian
c
      do 23 i=1, n
         do 24 j=1, n
            hessin(i,j) = hess(ind(i),ind(j))
  24     continue
  23  continue
      call mxlneq( hessin(:n,:n),n,n,detf,jrank,eps,work,0,n )

      sum = 0.0
      do 25 i=1, n
         do 26 j=1, n
            sum = sum + hessin(i,j)
  26     continue
  25  continue
      sum = sum - dble(n)
      write(outfile,'(/a,3x,d12.5)') 'Sum that should be ~0:', sum
c
c  MAIN LOOP to perform the geometry optimization
c
      do 200 its=1, optinp%niter
c
c  initialize dx0 and x0
c
         do 40 i=1, n3tm
            dx0(i) = grad(i)
            x0(i) = mlinp%geom%aucoord(i)
  40     continue
c         write(outfile,'(/,a,i3)') 'Initial geometry at step ', its
c         write(outfile,1018) x0
1018     format(3(1x,f10.6))
c         write(outfile,'(/,a,i3)') 'Initial gradient at step ', its
c         write(outfile,1023) dx0
1023     format(3(1x,d15.8))
c
c  Calculate Newton-Raphson step
c
         do 29 i=1, n3tm
            xxi(i) = 0.0d0
  29     continue
         do 30 i=1, n
            do 31 j=1, n
               xxi(ind(i)) = xxi(ind(i)) - hessin(i,j)*dx0(ind(j))
  31        continue
  30     continue
c
c  Scale calculated step so that rms value not greater than scale
c
         sum = 0.0d0
         do 7 i=1, n3tm
            sum = sum + xxi(i)*xxi(i)
   7     continue
         sum = sqrt(sum)
         if (sum.gt.optinp%scale)  xxi = xxi*optinp%scale/sum
 
         stepc = abs(xxi(1))
         mxind = 1  
         do 105 i=2, n3tm
            abxxi = abs(xxi(i))
            if (stepc.lt.abxxi) then
                stepc = abxxi
                mxind = i
            endif
 105     continue
c         write(outfile,'(/,a,i3)') 'XXI at step ', its
c         write(outfile,1018) xxi
c
c  Add to make sure that step not zero before send into linmn.
c
         if (stepc .eq. 0.0d0) then
            status = 4
            goto 300  
         endif
c
c  ... then scale the Newton-Raphson step
c
         stepmx = optinp%scale/stepc
         if (linmin.eq.1) then
            call linmn(x0, xxi, n3tm, fret, stepmx)
            sum = 0.0d0
            do 8 i=1, n3tm
               sum = sum + xxi(i)*xxi(i)
   8        continue
            sum = sqrt(sum)
            if (sum.gt.optinp%scale)  xxi = xxi*optinp%scale/sum
            stepc = abs(xxi(mxind))
         endif
c
c  Move to a new geometry and calculate new energy and gradient
c  Be careful with units - Gaussian is called with angcoord, yet the
c    optimizer operates on aucoord
c
         do 120 i=1, n3tm
            mlinp%geom%aucoord(i) = x0(i) + xxi(i)
 120     continue
         mlinp%geom%angcoord = mlinp%geom%aucoord*angtoau

c         write(outfile,'(/,a)') 'Ang. Geom after scaling'
c         write(outfile,1018) mlinp%geom%angcoord(:n3tm)         
c         write(outfile,'(/,a)') 'A.U. Geom after scaling'
c         write(outfile,1018) mlinp%geom%aucoord(:n3tm)
c
c  Get gradient and energy
c
         call optghk

         gcomp = abs(grad(1))
         do 130 i=2, n3tm
            abgc = abs(grad(i))
            if (gcomp.lt.abgc)  gcomp=abgc
 130     continue
c
c  Test for convergence
c
         if (gcomp.le.gtol) then
            status = 1
            goto 300
         endif
c
c  Test for magnitude of stepsize
c
         if (stepc.lt.optinp%stptol) then
            fail = 1
            write(outfile, 1350) stepc
1350        format(/,'Maximum displacement component change smaller ',
     *               'than STPTOL:',3x,d12.5)
            if (optinp%retry .eq. 0)  then
               status = 2
               goto 300
            endif
         endif

         if (fail .eq. 1) then
            write(outfile, 1375)
1375        format(/,'Switching to full Newton optimization')
            idorec = 1
            nrecal = idorec
            linmin = 0
            fail = 0
         else
            nrecal = nrecal+1
         endif
c
c  Display current step in optimization
c
         call optdisp(its, mlinp%geom, ener, grad(:n3tm), xxi(:n3tm), 
     *           gcomp, gtol)
c
c  Get new hessian if necessary (but not if on last step of optimization.
c
         if (nrecal.eq.idorec .and. its.ne.optinp%niter) then
            nrecal = 0
            write (outfile, 1400)
1400        format(/,'Hessian recalculated.')
            call opthhk
c
c  Get inverse of the small hessian
c
            do 101 i=1, n   
               do 102 j=1, n
                  hessin(i,j) = hess(ind(i),ind(j))
 102           continue
 101        continue
            call mxlneq( hessin(:n,:n),n,n,detf,jrank,eps,work,0,n )
 
            sum = 0.0
            do 103 i=1, n
               do 104 j=1, n
                  sum = sum + hessin(i,j)
 104           continue
 103        continue   
            sum = sum - dble(n)
            write(outfile,'(/a,3x,d12.5)') 'Sum that should be ~0:', sum
c
c  Otherwise, do BFGS or DFP update
c
         else
c
c  ... Compute differences of gradients and difference times hessin
c
            do 152 i=1, n
               deltag(i) = grad(ind(i)) - dx0(ind(i))
 152        continue
            do 153 i=1, n
               hdg(i) = 0.0d0
               do 154 j=1, n
                  hdg(i) = hdg(i)+hessin(i,j)*deltag(j)
 154           continue
 153        continue
c
c  ... Calculate dot products for the denominators
c
            fac = 0.0d0
            fae = 0.0d0
            sumdg = 0.0d0
            sumxi = 0.0d0
            do 155 i=1, n
               fac = fac + deltag(i)*xxi(ind(i))
               fae = fae + deltag(i)*hdg(i)
               sumdg = sumdg + deltag(i)*deltag(i)
               sumxi = sumxi + xxi(ind(i))*xxi(ind(i))
 155        continue
c
c  ... Skip update if fac not sufficiently positive
c
            if (fac*fac.gt.eps*sumdg*sumxi) then
               fac = 1.0d0/fac
               fad = 1.0d0/fae
c
c  ... Compute DFP update
c
               do 156 i=1, n
                  do 157 j=1, n
                     hessin(i,j) = hessin(i,j) 
     *                  + fac*xxi(ind(i))*xxi(ind(j))
     *                  - fad*hdg(i)*hdg(j)
 157              continue
 156           continue
c
c  ... Add on special BFGS element if BFGS has been chosen.
c
               if (optinp%algrthm.eq.1) then
                  do 160 i=1, n
                     deltag(i) = fac*xxi(ind(i)) - fad*hdg(i)
 160              continue
                  do 158 i=1, n
                     do 159 j=1, n
                        hessin(i,j) = hessin(i,j) 
     *                     + fae*deltag(i)*deltag(j)
 159                 continue
 158              continue
                 write (outfile, 1410)
1410             format(/,'Hessian updated using BFGS formula')
               elseif (optinp%algrthm.eq.2) then
                  write (outfile,1420)
1420              format(/,'Hessian updated using DFP formula')
               endif
            else
               write (outfile,1092)
1092           format(/,'Update skipped because factor too small.')
            endif
         endif

c         write(outfile,1027) hessin(:n,:n)
1027     format(6(1x,d12.5))

 200  continue
c
c  If at this point the iterations have maxed out - print message and 
c    exit routine.
c
      write (outfile, 2200)
2200  format (/5x,'OPTIMIZATION FAILURE: Max iterations reached.',/)
      ierr = 1
 
      return

 300  continue
c
c  Display final step in optimization and print appropriate exit message.
c

      if (status .eq. 1) then
         call optdisp(its, mlinp%geom, ener, grad(:n3tm), xxi(:n3tm),
     *           gcomp, gtol)
         write (outfile, 2000)
      elseif (status .eq. 2) then
         call optdisp(its, mlinp%geom, ener, grad(:n3tm), xxi(:n3tm),
     *           gcomp, gtol)
         write (outfile, 2100)
         ierr = 1
      elseif (status .eq. 3) then
         write (outfile, 2300)
      elseif (status .eq. 4) then
         write (outfile, 2400)
         ierr = 1
      endif

2000  format (/80('*'),/28x,'OPTIMIZATION SUCCESSFUL.',
     *          /80('*'),/)
2100  format (/5x,'OPTIMIZATION FAILURE: Geometry not changing.',/)
2300  format (/80('*'),/26x,'GEOMETRY ALREADY OPTIMIZED.',
     *          /80('*'),/)
2400  format (/5x,'OPTIMIZATION FAILURE: Step Size is 0.',/)

      return
      end
c
c***********************************************************************
c  LINMN
c***********************************************************************
c
      subroutine linmn (xl, xil, n, fret, stpmx)
c
c     Subroutine linmn
c
c     Created:  July 15, 1999 by J. M. Rodgers
c               Adapted from the LINMN routines in Ben's IMOHC code
c                 and in POLYRATE.
c     Revised:
c     Purpose:  A line search routine.
c
c     Called by:  newt, newt2
c     Calls:  mnbrak, brent
c
c     Variables defined here:  none.
c
      use files, only : outfile
      use optimize, only : xcom, xicom

      implicit none

      external f1dim

      integer n, ncom, i
      double precision  fret, stpmx, tol, ax, xx, bx, sum
      double precision  fa, fx, fb, brent, xmin, xl(n), xil(n)

      data tol /1.0000d-4/

c         write(outfile,'(/,a)') 'XL at start of LINMN:'
c         write(outfile,1018) xl   
1018     format(3(5x,d12.5))

c         write(outfile,'(/,a)') 'XIL at start of LINMN:'
c         write(outfile,1018) xil   

c      write(outfile,'(/,a)') 'Step initially:'
c      write(outfile,1018) xil

      ncom = n
      do 10 i=1, n
         xcom(i) = xl(i)
         xicom(i) = xil(i)
  10  continue

      ax = 0.0000d0
      if (stpmx .gt. 2.0d0) then
         xx = 1.0d0
         bx = 2.0d0
      else
         xx = stpmx*0.5d0
         bx = stpmx
      endif

      call mnbrak(ax,xx,bx,fa,fx,fb,f1dim)
      fret = brent(ax,xx,bx,f1dim,tol,xmin)

c
c  abs(XMIN) only allowed to be greater than 0.0001
c
      xmin = sign(max(abs(xmin),1.0d-4),xmin)


      do 20 i=1, n
         xil(i) = xil(i)*xmin
  20  continue


      return
      end
c
c***********************************************************************
c  MNBRAK
c***********************************************************************
c
      subroutine mnbrak (ax, bx, cx, fa, fb, fc, func)
c  
c     Subroutine mnbrak
c
c     Created:  July 15, 1999 by J. M. Rodgers
c               Adapted from the MNBRAK routines in Ben's IMOHC code
c                 and in POLYRATE.
c     Revised:
c     Purpose:  Given a function func and distinct initial points ax
c       and bx, this routine searches in the downhill direction and
c       returns new points ax, bx, and cx which bracket a minimum of the
c       function.
c        
c     Called by:  linmn
c     Calls:  func
c
c     Variables defined here:
c     
      use files, only : outfile

      implicit none

      external func

      double precision  ax, bx, cx, fa, fb, fc, fu, r, q, u, a
      double precision  dum, ulim, func, gold, glimit, tiny

      data gold /1.618034d0/, glimit /100.0d0/, tiny /1.0d-20/

1001  format(/5x,'ax = ',d15.8,t40,'fa = ',d22.15,
     *       /5x,'bx = ',d15.8,t40,'fb = ',d22.15,
     *       /5x,'cx = ',d15.8,t40,'fc = ',d22.15,
     *       /5x,'u  = ',d15.8,t40,'fu = ',d22.15 )

      fa = func(ax)
c      write(outfile,1001) ax,fa,bx,fb,cx,fc,u,fu
      fb = func(bx)
c      write(outfile,1001) ax,fa,bx,fb,cx,fc,u,fu

      if (fb .gt. fa) then
         dum = ax
         ax = bx
         bx = dum
         dum = fb
         fb = fa
         fa = dum
      endif

      cx = bx + gold*(bx-ax)
      fc = func(cx)
c      write(outfile,1001) ax,fa,bx,fb,cx,fc,u,fu

  10  if (fb .ge. fc) then
         r = (bx-ax)*(fb-fc)
         q = (bx-cx)*(fb-fa)
         u = bx-((bx-cx)*q-(bx-ax)*r)/
     *        (2.0d0*sign(max(abs(q-r),tiny),q-r))
         ulim = bx + glimit*(cx-bx)
         if ((bx-u)*(u-cx) .gt. 0.0d0) then
            fu = func(u)
c            write(outfile,1001) ax,fa,bx,fb,cx,fc,u,fu
            if (fu .lt. fc) then
               ax = bx
               fa = fb
               bx = u
               fb = fu
               goto 10
            elseif (fu .gt. fb) then
               cx = u
               fc = fu
               goto 10
            endif
            u = cx + gold*(cx-bx)
            fu = func(u)
c            write(outfile,1001) ax,fa,bx,fb,cx,fc,u,fu
         elseif ((cx-u)*(u-ulim) .gt. 0.0d0) then
            fu = func(u)
            if (fu .lt. fc) then
               bx = cx
               cx = u
               u = cx + gold*(cx-bx)
               fb = fc
               fc = fu
               fu = func(u)
c               write(outfile,1001) ax,fa,bx,fb,cx,fc,u,fu
            endif
         elseif ((u-ulim)*(ulim-cx) .ge. 0.0d0) then
            u = ulim
            fu = func(u)
c            write(outfile,1001) ax,fa,bx,fb,cx,fc,u,fu
         else
            u = cx + gold*(cx-bx)
            fu = func(u)
c            write(outfile,1001) ax,fa,bx,fb,cx,fc,u,fu
         endif

         ax = bx
         bx = cx
         cx = u
         fa = fb
         fb = fc
         fc = fu
         goto 10

      endif

      return
      end
c
c***********************************************************************
c  BRENT
c***********************************************************************
c
      function brent (ax, bx, cx, f, tol, xmin)
c
c     function brent
c
c     Created:  July 15, 1999 by J. M. Rodgers
c               Adapted from the BRENT routines in Ben's IMOHC code
c                 and in POLYRATE.
c     Revised:   
c     Purpose:  Given a function func and a bracketing triplet of
c       abscissas ax, bx, and cx (such that bx is between ax and cx and
c       f(bx) is less than both f(ax) and f(cx), this routine isolates the
c       minimum to a fractional precision of about tol using Brent's
c       method.
c
c     Called by:  linmn
c     Calls:  f
c        
c     Variables defined here:
c
      use files, only : outfile
         
      implicit none
         
      external f

      double precision  ax, bx, cx, f, tol, xmin, brent
      double precision  z, b, v, w, x, e, a
      double precision  fx, fv, fw, xm, tol1, tol2, r, q, p
      double precision  etemp, d, u, fu

      integer iter
  
      integer, parameter :: itmax = 100
      double precision, parameter :: cgold = 0.381966d0
      double precision, parameter :: zeps = 1.0d-10

      a = min(ax,cx)
      b = max(ax,cx)
      v = bx
      w = v
      x = v
      e = 0.0d0
      fx = f(x)
      fv = fx
      fw = fx
      do 50 iter = 1, itmax
         xm = 0.5d0*(a+b)
         tol1 = tol*abs(x) + zeps
         tol2 = 2.0d0*tol1

         if (abs(x-xm) .le. (tol2-0.5d0*(b-a)) )  goto 100

         if (abs(e) .gt. tol1) then
            r = (x-w)*(fx-fv)
            q = (x-v)*(fx-fw)
            p = (x-v)*q - (x-w)*r
            q = 2.0d0*(q-r)
            if (q .gt. 0.0d0)  p = -p
            q = abs(q)
            etemp = e
            e = d
            if ( abs(p).ge.abs(0.5d0*q*etemp) .or. p.le.q*(a-x) .or.
     *           p.ge.q*(b-x) )  goto 10
            d = p/q
            u = x + d
            if ( (u-a).lt.tol2 .or. (b-u).lt.tol2)  d = sign(tol1,xm-x)
            goto 20
         endif

  10     if (x.ge.xm) then
            e = a-x
         else
            e = b-x
         endif

         d = cgold*e

  20     if (abs(d) .ge. tol1) then
            u = x+d
         else
            u = x+sign(tol1,d)
         endif

         fu = f(u)

         if (fu .le. fx) then
            if (u .ge. x) then
               a = x
            else
               b = x
            endif
            v = w
            fv = fw
            w = x
            fw = fx
            x = u
            fx = fu
         else
            if (u .lt. x) then
               a = u
            else
               b = u
            endif
            if (fu.le.fw .or. w.eq.x) then
               v = w
               fv = fw
               w = u
               fw = fu
            elseif (fu.le.fv .or. v.eq.x .or. v.eq.w) then
               v = u
               fv = fu
            endif
         endif

  50  continue

      write(outfile, 1001)
1001  format('ERROR:  BRENT exceeded the maximum of 100 iterations.')

 100  xmin = x
      brent = fx

      return
      end
c
c***********************************************************************
c  F1DIM
c***********************************************************************
c
      function f1dim (rfac)
c
c     function f1dim
c
c     Created:  July 15, 1999 by J. M. Rodgers
c               Adapted from the F1DIM routines in Ben's IMOHC code
c                 and in POLYRATE.
c     Revised:
c     Purpose:  Returns the energy specified within mlinp based on a
c        geometry altered according to xcom, xicom, and rfac.
c
c     Called by:  mnbrak, brent, linmn
c     Calls:  
c
c     Variables defined here:
c
      use files, only : outfile
      use input, only : mlinp
      use optimize, only : xcom, xicom, ener

      implicit  none

      double precision  f1dim, rfac
      integer i, n3tm, n

      double precision, parameter :: angtoau = 0.52918d0

      n = mlinp%geom%natoms
      n3tm = 3*n

      mlinp%geom%aucoord(:n3tm) = xcom(:n3tm) + rfac*xicom(:n3tm)
      mlinp%geom%angcoord(:n3tm) = mlinp%geom%aucoord(:n3tm)*angtoau

      call optehk

c         write(outfile,'(/5x,a,d12.5,a)') 'Step Scaled by ',rfac,' to:'
c         write(outfile,1018) rfac*xicom(:n3tm)
1018     format(3(5x,d12.5))

      f1dim = ener

      return
      end
c
c***********************************************************************
c  DGEMM
c***********************************************************************
c
      subroutine dgemm (transa, transb, m, n, k, alpha, a, lda,
     *                   b, ldb, beta, c, ldc)
c
c     function dgemm
c           
c     Created:  July 15, 1999 by J. M. Rodgers
c               Adapted from the DGEMM routines in Ben's IMOHC code
c                 and in POLYRATE.
c
c     Never called in this version of Multilevel.
c     Calls:  lsame, xerbla, max
c
c  Purpose
c  =======
c
c  DGEMM  performs one of the matrix-matrix operations
c
c     C := alpha*op( A )*op( B ) + beta*C,
c
c  where  op( X ) is one of
c
c     op( X ) = X   or   op( X ) = X',
c
c  alpha and beta are scalars, and A, B and C are matrices, with op( A )
c  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
c
c  Parameters
c  ==========
c
c  TRANSA - CHARACTER*1.
c           On entry, TRANSA specifies the form of op( A ) to be used in
c           the matrix multiplication as follows:
c              TRANSA = 'N' or 'n',  op( A ) = A.
c              TRANSA = 'T' or 't',  op( A ) = A'.
c              TRANSA = 'C' or 'c',  op( A ) = A'.
c           Unchanged on exit.
c
c  TRANSB - CHARACTER*1.
c           On entry, TRANSB specifies the form of op( B ) to be used in
c           the matrix multiplication as follows:
c              TRANSB = 'N' or 'n',  op( B ) = B.
c              TRANSB = 'T' or 't',  op( B ) = B'.
c              TRANSB = 'C' or 'c',  op( B ) = B'.
c           Unchanged on exit.
c
c  M      - INTEGER.
c           On entry,  M  specifies  the number  of rows  of the  matrix
c           op( A )  and of the  matrix  C.  M  must  be at least  zero.
c           Unchanged on exit.
c
c  N      - INTEGER.
c           On entry,  N  specifies the number  of columns of the matrix
c           op( B ) and the number of columns of the matrix C. N must be
c           at least zero.
c           Unchanged on exit.
c
c  K      - INTEGER.
c           On entry,  K  specifies  the number of columns of the matrix
c           op( A ) and the number of rows of the matrix op( B ). K must
c           be at least  zero.
c           Unchanged on exit.
c
c  ALPHA  - DOUBLE PRECISION.
c           On entry, ALPHA specifies the scalar alpha.
c           Unchanged on exit.
c  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
c           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
c           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
c           part of the array  A  must contain the matrix  A,  otherwise
c           the leading  k by m  part of the array  A  must contain  the
c           matrix A.
c           Unchanged on exit.
c
c  LDA    - INTEGER.
c           On entry, LDA specifies the first dimension of A as declared
c           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
c           LDA must be at least  max( 1, m ), otherwise  LDA must be at
c           least  max( 1, k ).
c           Unchanged on exit.
c
c  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
c           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
c           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
c           part of the array  B  must contain the matrix  B,  otherwise
c           the leading  n by k  part of the array  B  must contain  the
c           matrix B.
c           Unchanged on exit.
c
c  LDB    - INTEGER.
c           On entry, LDB specifies the first dimension of B as declared
c           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
c           LDB must be at least  max( 1, k ), otherwise  LDB must be at
c           least  max( 1, n ).
c           Unchanged on exit.
c
c  BETA   - DOUBLE PRECISION.
c           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
c           supplied as zero then C need not be set on input.
c           Unchanged on exit.
c
c  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
c           Before entry, the leading  m by n  part of the array  C must
c           contain the matrix  C,  except when  beta  is zero, in which
c           case C need not be set on entry.
c           On exit, the array  C  is overwritten by the  m by n  matrix
c           ( alpha*op( A )*op( B ) + beta*C ).
c
c  LDC    - INTEGER.
c           On entry, LDC specifies the first dimension of C as declared
c           in  the  calling  (sub)  program.   LDC  must  be  at  least
c           max( 1, m ).
c           Unchanged on exit.
c
c  Level 3 Blas routine.
c
c  -- Written on 8-February-1989.
c     Jack Dongarra, Argonne National Laboratory.
c     Iain Duff, AERE Harwell.
c     Jeremy Du Croz, Numerical Algorithms Group Ltd.
c     Sven Hammarling, Numerical Algorithms Group Ltd.
c
c     
c
c     Variables defined here:
c
      implicit none

      logical, external :: lsame
      external             xerbla
      intrinsic            max

      logical  nota, notb
      integer  i, info, j, l, ncola, nrowa, nrowb
      double precision  temp
      double precision, parameter :: one=1.0d+0, zero=0.0d+0

      character*1  transa, transb
      integer      m, n, k, lda, ldb, ldc
      double precision  alpha, beta
      double precision  a(lda,*), b(ldb,*), c(ldc,*)

c
c  Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
c  transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
c  and  columns of  A  and the  number of  rows  of  B  respectively.
c
      nota = lsame( transa, 'N' )
      notb = lsame( transb, 'N' )

      if (nota) then
         nrowa = m
         ncola = k
      else
         nrowa = k
         ncola = m
      endif

      if (notb) then
         nrowb = k
      else
         nrowb = n
      endif
c
c  Test the input parameters
c
      info = 0
      if ((.not.nota) .and. (.not.lsame(transa,'C')) .and.
     *         (.not.lsame(transa,'T'))) then
         info = 1
      elseif ((.not.notb) .and. (.not.lsame(transb,'C')) .and.
     *           (.not.lsame(transb,'T'))) then
         info = 2
      elseif (m .lt. 0) then
         info = 3
      elseif (n .lt. 0) then
         info = 4
      elseif (k .lt. 0) then
         info = 5
      elseif (lda .lt. max(1,nrowa) ) then
         info = 8
      elseif (ldb .lt. max(1,nrowb) ) then
         info = 10
      elseif (ldc .lt. max(1,m) ) then
         info = 13
      endif

      if (info.ne.0) then
         call xerbla( 'DGEMM ', info )
         return
      endif
c
c  Quick return if possible
c
      if ((m.eq.0) .or. (n.eq.0) .or.
     *     (((alpha.eq.zero) .or. (k.eq.0)) .and. (beta.eq.one)) )
     *   return
c
c  And if alpha equals zero
c
      if (alpha.eq.zero) then
         if (beta.eq.zero) then
            do 20, j=1, n
               do 10, i=1, m
                  c(i,j) = zero
  10           continue
  20        continue
         else
            do 40, j=1, n
               do 30, i=i, m
                  c(i,j) = beta*c(i,j)
  30           continue
  40        continue
         endif

         return
      endif
c
c  Start the operations
c
      if (notb) then
         if (nota) then
c
c  Form C = alpha*A*B + beta*C.
c
            do 90, j=1, n
               if (beta.eq.zero) then
                  do 50, i=1, m
                     c(i,j) = zero
  50              continue
               elseif (beta.ne.one) then
                  do 60, i=1, m
                     c(i,j) = beta*c(i,j)
  60              continue
               endif
               do 80, l=1, k
                  if (b(l,j) .ne. zero) then
                     temp = alpha*b(l,j)
                     do 70, i=1, m
                        c(i,j) = c(i,j) + temp*a(i,l)
  70                 continue
                  endif
  80           continue
  90        continue
         else
c
c  Form C := alpha*A'*B + beta*C
c
            do 120, j=1, n
               do 110, i=1, M
                  temp = zero
                  do 100, l=1, k
                     temp = temp + a(l,i)*b(l,j)
 100              continue
                  if (beta.eq.zero) then
                     c(i,j) = alpha*temp
                  else
                     c(i,j) = alpha*temp + beta*c(i,j)
                  endif
 110           continue
 120        continue
         endif
      else
         if (nota) then
c
c  Form C := alpha*a*B' + beta*C
c
            do 170, j=1, n
               if (beta.eq.zero) then
                  do 130, i=1, m
                     c(i,j) = zero
 130              continue
               elseif (beta.ne.one) then
                  do 140, i=1, m
                     c(i,j) = beta*c(i,j)
 140              continue
               endif
               do 160, l=1, k
                  if (b(j,l) .ne. zero) then
                     temp = alpha*b(j,l)
                     do 150, i=1, m
                        c(i,j) = c(i,j) + temp*a(i,l)
 150                 continue
                  endif
 160           continue
 170        continue
         else
c
c  Form C := alpha*A'*B' + beta*C
c
            do 200, j=1, n
               do 190, i=1, m
                  temp = zero
                  do 180, l=1, k
                     temp = temp + a(l,i)*b(j,l)
 180              continue
                  if (beta.eq.zero) then
                     c(i,j) = alpha*temp
                  else
                     c(i,j) = alpha*temp + beta*c(i,j)
                  endif
 190           continue
 200        continue
         endif
      endif

      return
      end
c  
c***********************************************************************
c  XERBLA
c***********************************************************************
c           
      subroutine xerbla (srname, info)
c           
c     subroutine xerbla
c           
c     Created:  July 15, 1999 by J. M. Rodgers
c               Adapted from the XERBLA routines in Ben's IMOHC code
c                 and in POLYRATE.
c
c  -- LAPACK auxiliary routine (preliminary version) --
c     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
c     Courant Institute, Argonne National Lab, and Rice University
c     February 29, 1992
c           
c     Called by:  dgemm
c
c  Purpose
c  =======
c
c  XERBLA  is an error handler for the LAPACK routines.
c  It is called by an LAPACK routine if an input parameter has an
c  invalid value.  A message is printed and execution stops.
c
c  Installers may consider modifying the STOP statement in order to
c  call system-specific exception-handling facilities.
c
c  Arguments
c  =========
c
c  SRNAME  (input) CHARACTER*6
c          The name of the routine which called XERBLA.
c
c  INFO    (input) INTEGER
c          The position of the invalid parameter in the parameter list
c          of the calling routine.
c
      implicit none

      character*6  srname
      integer      info

      write( *, fmt=9999) srname, info

      stop 'xerbla 1'

9999  format(' ** On entry to ', a6,' parameter number ',i2,' had ',
     *         'an illegal value.' )

      end
c
c***********************************************************************
c  LSAME
c***********************************************************************
c
      function lsame (ca, cb)
c
c     function lsame
c
c     Created:  July 15, 1999 by J. M. Rodgers
c               Adapted from the LSAME routines in Ben's IMOHC code
c                 and in POLYRATE.
c
c  -- LAPACK auxiliary routine (preliminary version) --
c     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 
c     Courant Institute, Argonne National Lab, and Rice University
c     February 29, 1992
c
c     Called by:  dgemm
c  
c  Purpose
c  =======
c
c  LSAME returns .TRUE. if CA is the same letter as CB regardless of
c  case.
c
c  Arguments
c  =========
c
c  CA      (input) CHARACTER*1
c  CB      (input) CHARACTER*1
c          CA and CB specify the single characters to be compared.
c
      implicit none

      logical    lsame
      character  ca, cb
      intrinsic  ichar
      integer    inta, intb, zcode

c
c  Test if the characters are equal
c
      lsame = ca.eq.cb
      if (lsame)   return
c
c  Now test for equivalence if both characters are alphabetic
c
      zcode = ichar( 'Z' )
c
c  Use 'Z' rather than 'A' so that ASCII can be detected on Prime
c  machines, on which ICHAR returns a value with bit 8 set.
c  ICHAR('A') on Prime machines returns 193 which is the same as
c  ICHAR('A') on an EBCDIC machine.
c
      inta = ichar(ca)
      intb = ichar(cb)

      if (zcode.eq.90 .or. zcode.eq.122) then
c
c        ASCII is assumed - ZCODE is the ASCII code of either lower or
c        upper case 'Z'.
c
         if (inta.ge.97 .and. inta.le.122)  inta = inta - 32
         if (intb.ge.97 .and. intb.le.122)  intb = intb - 32

      elseif (zcode.eq.233 .or. zcode.eq.169) then
c
c        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
c        upper case 'Z'.
c
         if (  inta.ge.129 .and. inta.le.137 .or.
     *         inta.ge.145 .and. inta.le.153 .or.
     *         inta.ge.162 .and. inta.le.169)        inta = inta + 64
         if (  intb.ge.129 .and. intb.le.137 .or.
     *         intb.ge.145 .and. intb.le.153 .or.
     *         intb.ge.162 .and. intb.le.169)        intb = intb + 64

      elseif (zcode.eq.218 .or. zcode.eq.250) then
c
c        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
c        plus 128 of either lower or upper case 'Z'.
c
         if (inta.ge.225 .and. inta.le.250)  inta = inta - 32
         if (intb.ge.225 .and. intb.le.250)  intb = intb - 32
      endif

      lsame = inta.eq.intb

      return
      end
c     
c***********************************************************************
c  MXLNEQ
c***********************************************************************
c
      subroutine mxlneq (a, nn, ida, dett, jrank, eps, in, mm, nabsm)
c  
c     subroutine mxlneq
c  
c     Created:  July 15, 1999 by J. M. Rodgers
c               Adapted from the MXLNEQ routines in Ben's IMOHC code
c                 and in POLYRATE.
c     Revised:
c     Purpose:  Solves for the matrix X in C*X = B.  C must be a square
c        matrix.  A(NN,NN+abs(MM)) contains matrices C and B, A(i,j) =
c        C(i,j), A(i,j+NN) = B(i,j)
c
c       IDA = first dimension of A
c       NN = order of matrix C (i.e. # of eqns)
c       IN(NN) = work array
c       MM = 0 is used to calculate the inverse of C
c
c       Notice that NABSM = NN + abs(MM)
c
c PROGRAMMED BY R. HOTCHKISS, U. COMP. CTR., U. OF MINN., REVISED OCT.73
c      modified for the VAX by Bruce Garrett, Nov. 1980
c
c    Dimensions changed by Tom Joseph Jan. 1988.
c
c     Called by:  newt2
c     Calls:
c
c     Variables defined here:
c     
      use files, only : outfile

      implicit none

      integer  nn, ida, jrank, mm, nabsm, intmx, id, in(ida)
      integer  nm, nmida, k1, nflag, mod, k, l, i
      integer  j, i1, m, n
      double precision  dett, eps, machep, ops, det, a(ida,nabsm)
      double precision  zero, one, pivot, piv, z, p

      data  zero, one  / 0.0d0, 1.0d0 / , machep /1.0d+38/
      data  intmx  /400000/
c
c ?
c
      save
c
c  Initiate some local and output variables
c
      jrank = nn
      n = nn
      id = ida
      ops = eps
c
c  Error checking
c
      if (n.gt.0 .and. n.le.id)  goto 10
      write (outfile,1700)
      write (outfile,1000) n, id
      stop 'mxlneq 1'
  10  if (id.ge.n .and. id.lt.intmx)  goto 20
      write (outfile,1700)
      write (outfile,1100) id, n, intmx
      stop 'mxlneq 2'
  20  if ((one+ops).ne.one .and. ops.ge.zero)  goto 30
      write (outfile,1700)
      write (outfile,1200)  ops
      stop 'mxlneq 3'
  30  mod = mm
      nm = abs(mm)
      if (nm.lt.intmx)  goto 40
      write (outfile,1700) 
      write (outfile,1300)  mm, intmx
      stop 'mxlneq 4'
  40  nm = nn + nm
      nmida = nm*id*2
      if (nmida .lt. intmx)  goto 50
      write (outfile, 1700)
      write (outfile, 1400)  nmida, intmx
  50  continue
c
c  Continue with initialization
c
      k1 = 1
      nflag = 0
      det = one
c
c  Main Gauss-Jordan loop begins
c
      do 150 k=1, n
c
c  Search for largest pivot candidate in remaining lower right square
c    matrix.
c
         piv = zero
         l = k
         do 60 i=k, n
            p = abs(a(i,k))
            if (piv.ge.p)  goto 60
            piv = p
            l = i
  60     continue
c
c  Pivot with abs value piv and subscripts l and k has been found.
c	
         pivot = a(l,k)
c
c  Continue if piv larger than user eps
c
         if (piv.gt.ops)  goto 80
         if (eps.eq.ops)  jrank = k-1
c
c  EPS test failed, check for zero pivot
c
         if (piv.gt.zero)  goto 70
c
c  Pivot is zero, terminate program
c
         write (outfile, 1700)
         write (outfile, 1500) k
         stop 'mxlneq 6'
c
c  issue non-fatal message, piv .le. eqs
c
  70     write (outfile, 1700)
         write (outfile, 1600) k, eps
c
c  set ops to 0 so solution may continue after error message
c
         ops = zero
         piv = pivot
c
c  calculate determinant and check for overflow
c
  80     det = pivot*det
         if (abs(det).lt.machep)  goto 90
         write (outfile,1700)
         write (outfile,1800) k, det
         stop 'mxlneq 7'
c
c  Reset leading row do index for det only and lin eqn only case
c
  90     if (mod.lt.0) k1 = k
c
c  Save pivot index
c
         in(k) = l
c
c  Check for row interchange
c
         if (l.eq.k)  goto 110
         det = -det
c
c  Interchange row containing pivot and current row.
c  Only partial rows need be exchanged for det only or lin eqn only
c    since lower left partially formed triangle is not needed.
c
         do 100 j=k1, nm
            z = a(l,j)
            a(l,j) = a(k,j)
            a(k,j) = z
 100     continue
c
c  Pivot element is now on diagonal.  save division time by using
c    reciprocal of pivot.
c
 110     pivot = one/pivot
c
c  Pre-divide necessary portion of pivot row
c
         do 120 j=k1, nm
            a(k,j) = a(k,j)*pivot
 120     continue
c
c  Set pivot element to 0 so main reduction step doesn't operate on pivot
c    row
c
         a(k,k) = zero
c
c  Sweep through all or part of matrix using kth row, pivot row, to reduce
c    the matrix.
c
         do 140 i=k1, n
            z = a(i,k)
            if (z.eq.zero) goto 140
c
c  This check not only prevents operating on pivot row, but catches other
c    zeroes in pivot columns.  Thes other zeroes would leave jth row
c    unchanged in following loop so considerable time may be saved by
c    skipping operation.
c
            do 130 j=k1, nm
               a(i,j) = a(i,j) - z*a(k,j)
 130        continue
c
c  The inverse is created in place by substituting an identity matrix col
c    by col, since we are substituting the pivot row from off diagonal 0
c    elements at this point, we now, place -A(i,k)/A(k,k) at this point
c    in the pivot col. 
c
            a(i,k) = -z*pivot
 140     continue
c
c  Similarly dividing pivot row by the pivot is equivalent to placing
c    1/a(k,k) at the pivot point for the inverse.
c
         a(k,k) = pivot
 150  continue
      if (n.eq.1)  goto 210
      if (mod.ge.0)  goto 180
c
c  Back substitution for lin eqn only case
c
      k1 = k1+1
      do 170 k=k1, nm
         i = n
         do 170 l=2, n
            i1 = i
            i = i-1
            z = zero
            do 160 j=i1, n
               z = z+a(i,j)*a(j,k)
 160        continue
            a(i,k) = a(i,k) - z
 170  continue

      goto 210
c
c  Final reordering of the matrix
c
 180  k = n
c
c  Skip last step since no interchange could occur there
c
      do 200 j=2, n
c
c  Perform interchanges in exact reverse order of previous execution
c
         k = k-1
c
c  Row interchange during inversion implies col interchange here
c
         m = in(k)
         if (m.eq.k)  goto 200
c
c  Col interchange
c
         do 190 i=1, n
            z = a(i,k)
            a(i,k) = a(i,m)
            a(i,m) = z
 190     continue
 200  continue

 210  dett = det
      return

1000  format(11H arg 2, n = ,I10/7X,4H id=,I10/
     *       29H n must be .ge. 1 and .le. id)
1100  format(12H arg 3, id = ,I10 /9X,3H n=,I10/
     *       27H id must be .ge. N and .le.,I10)
1200  format(13H arg 6, eps = ,1PE13.5/
     *       33H eps must be .ge. zero and finite)
1300  format(11H arg 8, m = ,I10/
     *       20H abs(m) must be .le. ,I10 )
1400  format(7H size = ,I10/
     *       36H size = id*(n+abs(m))*2 must be .le. ,I10)
1500  format(4H k =,I10/
     *       46H at step k a gauss-jordan pivot value was zero)
1600  format(4H k = ,I10/6H eps = ,1PE13.5/
     *       50H at step k a gauss-jordan pivot value was .le. eps )
1700  format(15H *** mxlneq *** )
1800  format(4H k = ,I10/6H det = ,1PE13.5/
     *        27H at step k det is too large )

      end
c
c******************************************************************************
c  PROGOHK
c******************************************************************************
c
      subroutine progohk( geom, optinp, prognme, ierr )
c
c     Subroutine progohk
c
c     Created:  July 16, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To call the specified external program to optimize the
c       geometry at the specified theory and basis level.
c     
c     Note:  Currently only G98 is enabled but should be easily expandable
c
c     Called by:  main
c     Calls:  g98inp, g98outo, system
c
c     Variables defined here:  none.
c
      use input, only : cartgeom, extopt
      use caltyp, only : topt
      use files

      implicit none

      character*10     :: prognme
      type (cartgeom)  :: geom, oldgeom
      type (extopt)    :: optinp
      integer          :: ierr, i
      double precision :: ener, grad(3*geom%natoms)

      oldgeom = geom
c
c  GAUSSIAN98
c
      if (prognme(:3).eq.'g98') then
         open (unit=extoinf, status='unknown', file=extin, err=9991)
         call g98inp(extoinf, optinp%meth, optinp%bas, geom, 
     *       optinp%optl, topt)
         close (extoinf, err=9991)
         call system('./g98shuttle extopt.inp extopt.out')
         call g98outo(geom, ener, grad, ierr)
c  
c  GAUSSIAN94   
c    Just reuse g98inp and g98outo since formats in the FChk files have
c    remained essentially the same.
c
      elseif (prognme(:3).eq.'g94') then
         open (unit=extoinf, status='unknown', file=extin, err=9992)
         call g98inp(extoinf, optinp%meth, optinp%bas, geom, 
     *         optinp%optl, topt)
         close (extoinf, err=9992)
         call system('./g94shuttle extopt.inp extopt.out')
         call g98outo(geom, ener, grad, ierr)
c 
c  GAUSSIAN03  
c    Just reuse g98inp and g98outo since formats in the FChk files have
c    remained essentially the same.
c
      elseif (prognme(:3).eq.'g03') then
         open (unit=extoinf, status='unknown', file=extin, err=9993)
         call g98inp(extoinf, optinp%meth, optinp%bas, geom,
     *            optinp%optl, topt)
         close (extoinf, err=9993)
         call system('./g03shuttle extopt.inp extopt.out')
         call g98outo(geom, ener, grad, ierr)                           1409ZY03
c 
c  GAUSSIAN09                                                           0808RMP12
c
      elseif (prognme(:3).eq.'g09') then
         open (unit=extoinf, status='unknown', file=extin, err=9994)
         call g98inp(extoinf, optinp%meth, optinp%bas, geom,
     *            optinp%optl, topt)
         close (extoinf, err=9994)
         call system('./g09shuttle extopt.inp extopt.out')
         call g98outo(geom, ener, grad, ierr)               

      endif

      if (ierr.eq.1)  return
c
c  Display the results of the optimization
c
      write(outfile,1100)  prognme
      write(outfile,1150)  optinp%meth
      write(outfile,1200)  optinp%bas
      write(outfile,1250)  ener
      write(outfile,1300)
      write(outfile,1350)  grad
      write(outfile,1400)
      write(outfile,1450)
      do 20 i=1, geom%natoms
         write(outfile,1500) geom%atm(i), geom%aucoord(3*i-2),
     *       geom%aucoord(3*i-1), geom%aucoord(3*i)
  20  continue
      write(outfile,1550)
      do 40 i=1, geom%natoms
         write(outfile,1500) geom%atm(i), geom%angcoord(3*i-2),
     *       geom%angcoord(3*i-1), geom%angcoord(3*i)
  40  continue

1100  format(/2(/80('-')),//2x,'External Optimization with ',
     *         a,//80('-')/)
1150  format(/2x,'Theory:',t30,a)
1200  format(2x,'Basis Set:',t30,a)
1250  format(/2x,'Optimized Energy:',t30,f19.12)
1300  format(/2x,'Optimized Cartesian Gradient:')
1350  format(t20,d15.8,t40,d15.8,t60,d15.8)
1400  format(/2x,'Optimized Geometry:')
1450  format(//5x,'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(//5x,'Atomic Coordinates (in ang.):',//8x,'Atom', t28, 'X',
     *         t48, 'Y', t68, 'Z'/)  

      return

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

      end
c
c******************************************************************************
c  G98OUTO
c******************************************************************************
c
      subroutine g98outo (geom, ener, grad, ierr)
c
c     Subroutine g98outo
c
c     Created:  July 16, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Get the energy, gradient, and optimized geometry out of
c        the Gaussian formatted checkpoint file.   
c     
c     Called by:  progohk
c     Calls:
c
c     Variables defined here:
c
      use files
      use numfmt
      use input, only : cartgeom

      implicit none

      type (cartgeom)  :: geom
      double precision  ener, cfltfmt, grad(3*geom%natoms)

      integer  i, ctr, j, ierr, gstrt, gend, opt
      character*80 string, case
      character*30 label
      character*22 etxt    
      character*15 gtxt(3*geom%natoms), otxt(3*geom%natoms)

      double precision, parameter :: angtoau = 0.52918d0
c
c  Check that the optimization is complete.
c
      opt = 0

      open( unit=extoout, status='unknown', file=extout, err=9920 )

      read( extoout, '(a80)', end=9930 ) string
      string = case(string)

      do while( string(:23) .ne. ' optimization completed')             0808RMP12
         read( extoout, '(a80)', end=9930 ) string
         string = case(string)
      end do

      close ( unit=extoout )
c     
c  Open the formatted checkpoint file.
c
      open( unit=fchk, status='unknown', file=testfchk, err=9900)
c
c  Find energy
c
      read( fchk, '(a80)', end=9910 ) string
      string = case(string)
      label = string(:llen(efmt))
      etxt = string(nstrt(efmt):nstrt(efmt)+nlen(efmt)-1)
      
      do while( label(:12).ne.'total energy' )
         read( fchk, '(a80)', end=9910 ) string
         string = case(string)
         label = string(:llen(efmt))
         etxt = string(nstrt(efmt):nstrt(efmt)+nlen(efmt)-1)
      end do  
 
      ener = cfltfmt(etxt,efmt)
c
c From the version G03 Revision E01 the order of the items in the 
c formatted checkpoint file have been modified. 
c    G03 older revisions than E01                G09
c   -------------------------------  -----------------------------
c       Total energy                 Current cartesian coordinates
c    Current Cartesian coordinates           Total Energy
c     
c                                                           0808RMP12

      rewind(fchk)
c
c  Find geometry
c
      do while( string(:29) .ne. 'current cartesian coordinates')
         read( fchk, '(a80)', end=9910 ) string
         string = case(string)
      enddo

      ctr = 1
      do while( ctr .le. 3*geom%natoms )
         read( fchk, '(a80)', end=9910 ) string
         string = case(string)
         i = 0
         do while( ctr.le.3*geom%natoms .and. i.lt.5 )
            gstrt = i*(nlen(gfmt)+1)+2  
            gend  = (i+1)*(nlen(gfmt)+2)  
            otxt(ctr) = string(gstrt:gend)
            ctr = ctr+1
            i = i+1
         end do
      end do
      
      do 10 j=1, 3*geom%natoms
         geom%aucoord(j) = cfltfmt(otxt(j),gfmt)
  10  continue
      geom%angcoord = geom%aucoord*angtoau
c
c  Find gradient
c
      do while( string(:18).ne.'cartesian gradient' .and. 
     *              string(:16).ne.'cartesian forces' )
         read( fchk, '(a80)', end=9910 ) string
         string = case(string)
      enddo

      ctr = 1
      do while( ctr .le. 3*geom%natoms )
         read( fchk, '(a80)', end=9910 ) string
         string = case(string)
         i = 0
         do while( ctr.le.3*geom%natoms .and. i.lt.5 )
            gstrt = i*(nlen(gfmt)+1)+2
            gend  = (i+1)*(nlen(gfmt)+2)
            gtxt(ctr) = string(gstrt:gend)
            ctr = ctr+1
            i = i+1
         end do
      end do

      do 20 j=1, 3*geom%natoms
         grad(j) = cfltfmt(gtxt(j),gfmt)
  20  continue

      close( unit=fchk )
 
      return
      
9900  write( outfile,*) 'Error opening Gaussian98 checkpoint file.'
      stop 'g98outo 1'
9910  write( outfile,*) 'Error reading Gaussian98 checkpoint file.'
      stop 'g98outo 2'
9920  write( outfile,*) 'Error opening Gaussian98 output file.'
      stop 'g98outo 3'

9930  ierr=1
      return

      end
c
c******************************************************************************
c  OPTEHK
c******************************************************************************
c
      subroutine optehk
c
c     Subroutine optehk
c
c     Created:  July 16, 1999 by J. M. Rodgers
c     Revised:  January 12, 2000 by P. L. Fast
c     Purpose:  Based on the specifed ML optimization method, call the
c       appropriate sub ehook and set ener to the appropriate value.
c
c     Called by:  f1dim
c     Calls:  hfmoehk, mcoehk, mnmehk, mutehk, mcsehk, ibehk, sacehk, 
c             g2ehk, mg2ehk, g3ehk, mg3ehk, mqcehk, mcomp2ehk,mccoehk   0713BL02
c             mc3bbehk, g3sxmp3ehk,imohcehk, progehk
c     
c     Variables defined here:  none.
c     
      use files
      use energy
      use param, only : pmco, pmnm, pmut, pib, psac, pmcs
      use input, only : mlinp
      use optimize, only : ener
      use caltyp, only : tener

      implicit none


      integer  ierr

c HFMO
      if (mlinp%mlmeth(:4).eq.'hfmo') then
         call hfmoehk(mlinp%progrms%hfprog, mlinp%progrms%moprog, 
     *            mlinp%geom, mlinp%hfmoinp, ierr)
         ener = hfmoener(3)
c MCCM-CO
      elseif (mlinp%mlmeth(:6).eq.'mccmco') then
         call mcoehk(mlinp%progrms%mcprog, mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmco)
c MCCM-NM
      elseif (mlinp%mlmeth(:6).eq.'mccmnm') then
         call mnmehk(mlinp%progrms%mcprog, mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmnm)
c MCCM-UT
      elseif (mlinp%mlmeth(:6).eq.'mccmut') then
         call mutehk(mlinp%progrms%mcprog, mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmut)
c MCSAC
      elseif (mlinp%mlmeth(:5).eq.'mcsac') then
         call mcsehk(mlinp%progrms%mcprog, mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmcs)
c IB
      elseif (mlinp%mlmeth(:2).eq.'ib') then
         call ibehk(mlinp%progrms%mcprog, mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pib)
c SAC
      elseif (mlinp%mlmeth(:3).eq.'sac') then
         call sacehk(mlinp%progrms%mcprog, mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(psac)
c G2
      elseif (mlinp%mlmeth(:2).eq.'g2') then
         call g2ehk(mlinp%progrms%g2prog, mlinp%geom, 0, 
     *            mlinp%ginp, ierr)
         ener = g2ener
c MCG2
      elseif (mlinp%mlmeth(:4).eq.'mcg2') then
         call mg2ehk(mlinp%progrms%g2prog, mlinp%geom, 
     *           mlinp%mginp, ierr)
         ener = mg2ener
c G3SX(MP3)                                                             0113YZ04
      elseif (mlinp%mlmeth(:7).eq.'g3sxmp3') then                       0113YZ04
      call g3sxmp3ehk(mlinp%progrms%g3prog, mlinp%geom, 0,              0113YZ04
     *                       mlinp%mginp, ierr)                         0113YZ04
         ener = g3sxmp3ener                                             0113YZ04
c G3
      elseif (mlinp%mlmeth(:2).eq.'g3') then
         call g3ehk(mlinp%progrms%g3prog, mlinp%geom,
     *               0, mlinp%ginp, ierr)
         ener = g3ener
c MCG3         
      elseif (mlinp%mlmeth(:4).eq.'mcg3') then
         call mg3ehk(mlinp%progrms%g3prog, mlinp%geom,
     *                       mlinp%mginp, ierr)
         ener = mg3ener
c MC-QCISD                                                              0112PF00
      elseif (mlinp%mlmeth(:7).eq.'mcqcisd') then                       0112PF00
         call mqcehk(mlinp%progrms%g3prog, mlinp%geom, 0,               0112PF00
     *                       mlinp%mqinp, ierr)                         0112PF00
         ener = mqcener                                                 0112PF00
c MCOMP2                                                                0710PJ00
      elseif (mlinp%mlmeth(:6).eq.'mcomp2') then                        0710PJ00
         call mcomp2ehk(mlinp%progrms%g3prog, mlinp%geom, 0,            0710PJ00
     *                       mlinp%mqinp, ierr)                         0710PJ00
         ener = mcomp2ener                                              0710PJ00

c MCCO                                                                  0713BL02
      elseif (mlinp%mlmeth(:4).eq.'mcco') then                          0713BL02
         call mccoehk(mlinp%progrms%g3prog, mlinp%geom, 0,              0713BL02
     *                       mlinp%mqinp, ierr)                         0713BL02
         ener = mccoener                                                0713BL02

c MC3BB                                                                 0113YZ04
      elseif (mlinp%mlmeth(:5).eq.'mc3bb') then                         0113YZ04
         call mc3bbehk(mlinp%progrms%g3prog, mlinp%geom, 0,             0113YZ04
     *                       mlinp%mginp, ierr)                         0113YZ04
         ener = mc3bbener                                               0113YZ04

c MC3MPW                                                                0113YZ04
      elseif (mlinp%mlmeth(:6).eq.'mc3mpw') then                        0113YZ04
         call mc3mpwehk(mlinp%progrms%g3prog, mlinp%geom, 0,            0113YZ04
     *                       mlinp%mginp, ierr)                         0113YZ04
         ener = mc3mpwener                                              0113YZ04


c IMOHC
      elseif (mlinp%mlmeth(:5).eq.'imohc') then
         call imohcehk(mlinp%progrms%imohlprog, 
     *            mlinp%progrms%imollprog, 
     *            mlinp%geom, mlinp%imohcinp, ierr)
         ener = imohcener
c TEST
      elseif (mlinp%mlmeth(:4).eq.'test') then
         call progehk(mlinp%progrms%testprog,
     *      mlinp%tmeth,mlinp%tbas,
     *      mlinp%geom , mlinp%toptl, ener, ierr)
         ener = ener + eso + ecc + erel
c
         call testdisp ( mlinp%geom%natoms, tener )                  
      endif

      return
      end
c
c******************************************************************************
c  OPTGHK
c******************************************************************************
c
      subroutine optghk
c
c     Subroutine optghk
c
c     Created:  July 16, 1999 by J. M. Rodgers
c     Revised:  January 12, 2000 by P. L. Fast
c     Purpose:  Based on the specifed ML optimization method, call the
c       appropriate sub ghookk and set ener and grad to the appropriate
c       values.
c
c     Called by:  newt, newt2
c     Calls:  hfmoghk, mcoghk, mnmghk, mutghk, mcsghk, ibghk, sacghk, 
c             g2ghk, mg2ghk, g3ghk, mg3ghk, mqcghk, mcomp2ghk,          0710PJ00
c             imohcghk, progghk, mccoghk, mc3bbghk
c     
c     Variables defined here:  none.
c   
      use files 
      use optimize, only : ener, grad
      use input, only : mlinp
      use energy
      use gradient
      use param, only : pmco, pmnm, pmut, pib, psac, pmcs
      use caltyp, only : tgrad
 
      implicit none


      integer  n3tm, natoms, ierr
     
      natoms = mlinp%geom%natoms
      n3tm = 3*natoms

c HFMO
      if (mlinp%mlmeth(:4).eq.'hfmo') then
         call hfmoghk(mlinp%progrms%hfprog,
     *            mlinp%progrms%moprog, 
     *           mlinp%geom, mlinp%hfmoinp, ierr)
         ener = hfmoener(3)
         grad(:n3tm) = hfmograd(3,:n3tm)
c MCCM-CO
      elseif (mlinp%mlmeth(:6).eq.'mccmco') then
         call mcoghk(mlinp%progrms%mcprog, 
     *          mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmco)
         grad(:n3tm) = mcgrad(pmco,:n3tm)
c MCCM-NM
      elseif (mlinp%mlmeth(:6).eq.'mccmnm') then
         call mnmghk(mlinp%progrms%mcprog, 
     *          mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmnm)
         grad(:n3tm) = mcgrad(pmnm,:n3tm)
c MCCM-UT
      elseif (mlinp%mlmeth(:6).eq.'mccmut') then
         call mutghk(mlinp%progrms%mcprog, 
     *          mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmut)
         grad(:n3tm) = mcgrad(pmut,:n3tm)
c MCSAC
      elseif (mlinp%mlmeth(:5).eq.'mcsac') then
         call mcsghk(mlinp%progrms%mcprog, 
     *          mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmcs)
         grad(:n3tm) = mcgrad(pmcs,:n3tm)
c IB
      elseif (mlinp%mlmeth(:2).eq.'ib') then
         call ibghk(mlinp%progrms%mcprog, 
     *          mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pib)
         grad(:n3tm) = mcgrad(pib,:n3tm)
c SAC
      elseif (mlinp%mlmeth(:3).eq.'sac') then
         call sacghk(mlinp%progrms%mcprog, 
     *          mlinp%geom, mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(psac)
         grad(:n3tm) = mcgrad(psac,:n3tm)
c G2
      elseif (mlinp%mlmeth(:2).eq.'g2') then
         call g2ghk(mlinp%progrms%g2prog, mlinp%geom, 
     *          0, mlinp%ginp, ierr)
         ener = g2ener
         grad(:n3tm) = g2grad(:n3tm)
c MCG2
      elseif (mlinp%mlmeth(:4).eq.'mcg2') then
         call mg2ghk(mlinp%progrms%g2prog, mlinp%geom,
     *          mlinp%mginp, ierr)
         ener = mg2ener
         grad(:n3tm) = mg2grad(:n3tm)
c G3SX(MP3) 
      elseif (mlinp%mlmeth(:7).eq.'g3sxmp3') then                       1220YZ03
         call g3sxmp3ghk(mlinp%progrms%g3prog, mlinp%geom, 0,           1220YZ03
     *           mlinp%mginp, ierr)                                     1220YZ03
         ener = g3sxmp3ener                                             1220YZ03
         grad(:n3tm) = g3sxmp3grad(:n3tm)                               1220YZ03
c G3
      elseif (mlinp%mlmeth(:2).eq.'g3') then
         call g3ghk(mlinp%progrms%g3prog, mlinp%geom, 0, 
     *            mlinp%ginp, ierr)
         ener = g3ener
         grad(:n3tm) = g3grad(:n3tm)
c MCG3         
      elseif (mlinp%mlmeth(:4).eq.'mcg3') then
         call mg3ghk(mlinp%progrms%g3prog, mlinp%geom,
     *           mlinp%mginp, ierr)
         ener = mg3ener
         grad(:n3tm) = mg3grad(:n3tm)
c MC-QCISD                                                              0112PF00
      elseif (mlinp%mlmeth(:7).eq.'mcqcisd') then                       0112PF00
         call mqcghk(mlinp%progrms%g3prog, mlinp%geom, 0,               0112PF00
     *           mlinp%mqinp, ierr)                                     0112PF00
         ener = mqcener                                                 0112PF00
         grad(:n3tm) = mqcgrad(:n3tm)                                   0112PF00
c MCOMP2                                                                0710PJ00
      elseif (mlinp%mlmeth(:6).eq.'mcomp2') then                        0710PJ00
         call mcomp2ghk(mlinp%progrms%g3prog, mlinp%geom, 0,            0710PJ00
     *           mlinp%mqinp, ierr)                                     0710PJ00
         ener = mcomp2ener                                              0710PJ00
         grad(:n3tm) = mcomp2grad(:n3tm)                                0710PJ00

c MCCO                                                                  0713BL02
      elseif (mlinp%mlmeth(:4).eq.'mcco') then                          0713BL02
         call mccoghk(mlinp%progrms%g3prog, mlinp%geom, 0,              0713BL02
     *           mlinp%mqinp, ierr)                                     0713BL02
         ener = mccoener                                                0713BL02
         grad(:n3tm) = mccograd(:n3tm)                                  0713BL02

c MC3BB                                                                 
      elseif (mlinp%mlmeth(:5).eq.'mc3bb') then                         1220YZ03
         call mc3bbghk(mlinp%progrms%g3prog, mlinp%geom, 0,             1220YZ03
     *           mlinp%mginp, ierr)                                     1220YZ03
         ener = mc3bbener                                               1220YZ03
         grad(:n3tm) = mc3bbgrad(:n3tm)                                 1220YZ03

c MC3MPW
      elseif (mlinp%mlmeth(:6).eq.'mc3mpw') then                        1220YZ03
         call mc3mpwghk(mlinp%progrms%g3prog, mlinp%geom, 0,            1220YZ03
     *           mlinp%mginp, ierr)                                     1220YZ03
         ener = mc3mpwener                                              1220YZ03
         grad(:n3tm) = mc3mpwgrad(:n3tm)                                1220YZ03


c IMOHC
      elseif (mlinp%mlmeth(:5).eq.'imohc') then
         call imohcghk(mlinp%progrms%imohlprog,
     *              mlinp%progrms%imollprog,
     *              mlinp%geom, mlinp%imohcinp, ierr)
         ener = imohcener
         grad(:n3tm) = imohcgrad(:n3tm)
c TEST
      elseif (mlinp%mlmeth(:4).eq.'test') then
c
c bug fixed. The progghk interface has been changed.                    1026PJ04
c
c        call progghk(mlinp%progrms%testprog,mlinp%tmeth,
c    8      mlinp%tbas,
c    *      mlinp%geom , mlinp%toptl, ener, grad(:n3tm), ierr)
         call progghk(1,mlinp%progrms%testprog,mlinp%tmeth,             1026PJ04  
     8      mlinp%tbas,                                                 1026PJ04
     *      mlinp%geom , mlinp%toptl, ener, grad(:n3tm), ierr,'null')   1026PJ04
         ener = ener + eso + ecc + erel
c
         call testdisp ( mlinp%geom%natoms, tgrad )              
      endif

      return
      end
c
c******************************************************************************
c  OPTHHK
c******************************************************************************
c
      subroutine opthhk
c
c     Subroutine opthhk
c
c     Created:  July 16, 1999 by J. M. Rodgers
c     Revised:  January 12, 2000 by P. L. Fast
c     Purpose:  Based on the specifed ML optimization method, call the
c       appropriate sub hhk and set ener, grad, and hess to the
c       appropriate values, if a high level hessian has been requested.
c       If a low level hessian or a scaled unit matrix has been requested
c       then only hess is updated 
c
c     Called by:  newt
c     Calls:  hfmohhk, mcohhk, mnmhhk, muthhk, mcshhk, ibhhk, sachhk, 
c             g2hhk, mg2hhk, g3hhk, mg3hhk, mqchhk, mcomp2hhk,          0710PJ00
c             imohchhk, proghhk, mccohhk, mc3bbhhk
c     
c     Variables defined here:  none.
c     
      use optimize, only : ener, grad, hess
      use input, only : mlinp
      use energy
      use gradient
      use hessian
      use param, only : pmco, pmnm, pmut, pib, psac, pmcs, 
     *       lowhs, uniths
      use caltyp, only : thess
 
      implicit none


      double precision dum
      double precision, dimension(:), allocatable :: dum2
      integer  n3tm, natoms, ierr, i, j

      natoms = mlinp%geom%natoms
      n3tm = 3*natoms

      allocate(dum2(n3tm))

c
c Unit Hessian scaled by hscale
c
      if (mlinp%htyp.eq.uniths) then
         do 21 i=1, n3tm
            do 22 j=1, n3tm
               hess(i,j) = 0.0d0
  22        continue
            hess(i,i) = mlinp%hscale
  21     continue
c
c Low level Hessian - make sure that not set energy and gradient to low
c   level values as well.
c
      elseif (mlinp%htyp.eq.lowhs) then 
         call proghhk(mlinp%progrms%hessprog,mlinp%hmeth,mlinp%hbas,
     *      mlinp%geom, mlinp%toptl, dum, dum2,
     *      hess(:n3tm,:n3tm), ierr)
         call lowdisp( mlinp%geom%natoms )
c
c Otherwise will be doing a high level Hessian from one of these
c  Multilevel methods.
c

c HFMO
      elseif (mlinp%mlmeth(:4).eq.'hfmo') then
         call hfmohhk(mlinp%progrms%hfprog, mlinp%progrms%moprog, 
     *           mlinp%geom, mlinp%hfmoinp, ierr)
         ener = hfmoener(3)
         grad(:n3tm) = hfmograd(3,:n3tm)
         hess(:n3tm,:n3tm) = hfmohess(3,:n3tm,:n3tm)
c MCCM-CO
      elseif (mlinp%mlmeth(:6).eq.'mccmco') then
         call mcohhk(mlinp%progrms%mcprog, mlinp%geom,
     *          mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmco)
         grad(:n3tm) = mcgrad(pmco,:n3tm)
         hess(:n3tm,:n3tm) = mchess(pmco,:n3tm,:n3tm)
c MCCM-NM
      elseif (mlinp%mlmeth(:6).eq.'mccmnm') then
         call mnmhhk(mlinp%progrms%mcprog, mlinp%geom,
     *          mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmnm)
         grad(:n3tm) = mcgrad(pmnm,:n3tm)
         hess(:n3tm,:n3tm) = mchess(pmnm,:n3tm,:n3tm)
c MCCM-UT
      elseif (mlinp%mlmeth(:6).eq.'mccmut') then
         call muthhk(mlinp%progrms%mcprog, mlinp%geom,
     *          mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmut)
         grad(:n3tm) = mcgrad(pmut,:n3tm)
         hess(:n3tm,:n3tm) = mchess(pmut,:n3tm,:n3tm)
c MCSAC
      elseif (mlinp%mlmeth(:5).eq.'mcsac') then
         call mcshhk(mlinp%progrms%mcprog, mlinp%geom,
     *          mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pmcs)
         grad(:n3tm) = mcgrad(pmcs,:n3tm)
         hess(:n3tm,:n3tm) = mchess(pmcs,:n3tm,:n3tm)
c IB
      elseif (mlinp%mlmeth(:2).eq.'ib') then
         call ibhhk(mlinp%progrms%mcprog, mlinp%geom,
     *          mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(pib)
         grad(:n3tm) = mcgrad(pib,:n3tm)
         hess(:n3tm,:n3tm) = mchess(pib,:n3tm,:n3tm)
c SAC
      elseif (mlinp%mlmeth(:3).eq.'sac') then
         call sachhk(mlinp%progrms%mcprog, mlinp%geom,
     *          mlinp%mcinp,
     *          mlinp%mcoptl)
         ener = mcener(psac)
         grad(:n3tm) = mcgrad(psac,:n3tm)
         hess(:n3tm,:n3tm) = mchess(psac,:n3tm,:n3tm)
c G2
      elseif (mlinp%mlmeth(:2).eq.'g2') then
         call g2hhk(mlinp%progrms%g2prog, mlinp%geom, 0,
     *          mlinp%ginp, ierr)
         ener = g2ener
         grad(:n3tm) = g2grad(:n3tm)
         hess(:n3tm,:n3tm) = g2hess(:n3tm,:n3tm)
c MCG2
      elseif (mlinp%mlmeth(:4).eq.'mcg2') then
         call mg2hhk(mlinp%progrms%g2prog, mlinp%geom,
     *           mlinp%mginp, ierr)
         ener = mg2ener
         grad(:n3tm) = mg2grad(:n3tm)
         hess(:n3tm,:n3tm) = mg2hess(:n3tm,:n3tm)
c G3SX(MP3)
      elseif (mlinp%mlmeth(:7).eq.'g3sxmp3') then                       0130YZ04
         call g3sxmp3hhk(mlinp%progrms%g3prog, mlinp%geom, 0,           0130YZ04
     *           mlinp%mginp, ierr)                                     0130YZ04
         ener = g3sxmp3ener                                             0130YZ04
         grad(:n3tm) = g3sxmp3grad(:n3tm)                               0130YZ04
         hess(:n3tm,:n3tm) = g3sxmp3hess(:n3tm,:n3tm)                   0130YZ04
c G3
      elseif (mlinp%mlmeth(:2).eq.'g3') then
         call g3hhk(mlinp%progrms%g3prog, mlinp%geom, 0,
     *            mlinp%ginp, ierr)
         ener = g3ener
         grad(:n3tm) = g3grad(:n3tm)
         hess(:n3tm,:n3tm) = g3hess(:n3tm,:n3tm)
c MCG3         
      elseif (mlinp%mlmeth(:4).eq.'mcg3') then
         call mg3hhk(mlinp%progrms%g3prog, mlinp%geom,
     *           mlinp%mginp, ierr)
         ener = mg3ener
         grad(:n3tm) = mg3grad(:n3tm)
         hess(:n3tm,:n3tm) = mg3hess(:n3tm,:n3tm)
c MCQCISD                                                               0112PF00
      elseif (mlinp%mlmeth(:7).eq.'mcqcisd') then                       0112PF00
         call mqchhk(mlinp%progrms%g3prog, mlinp%geom, 0,               0112PF00
     *           mlinp%mqinp, ierr)                                     0112PF00
         ener = mqcener                                                 0112PF00
         grad(:n3tm) = mqcgrad(:n3tm)                                   0112PF00
         hess(:n3tm,:n3tm) = mqchess(:n3tm,:n3tm)                       0112PF00
c MCOMP2                                                                0710PJ00
      elseif (mlinp%mlmeth(:6).eq.'mcomp2') then                        0710PJ00
         call mcomp2hhk(mlinp%progrms%g3prog, mlinp%geom, 0,            0710PJ00
     *           mlinp%mqinp, ierr)                                     0710PJ00
         ener = mcomp2ener                                              0710PJ00
         grad(:n3tm) = mcomp2grad(:n3tm)                                0710PJ00
         hess(:n3tm,:n3tm) = mcomp2hess(:n3tm,:n3tm)                    0710PJ00

c MCCO                                                                  0713BL02
      elseif (mlinp%mlmeth(:4).eq.'mcco') then                          0713BL02
         call mccohhk(mlinp%progrms%g3prog, mlinp%geom, 0,              0713BL02
     *           mlinp%mqinp, ierr)                                     0713BL02
         ener = mccoener                                                0713BL02
         grad(:n3tm) = mccograd(:n3tm)                                  0713BL02
         hess(:n3tm,:n3tm) = mccohess(:n3tm,:n3tm)                      0713BL02

c MC3BB                                                                 0302YZ04
      elseif (mlinp%mlmeth(:5).eq.'mc3bb') then                         0302YZ04
         call mc3bbhhk(mlinp%progrms%g3prog, mlinp%geom, 0,             0302YZ04
     *           mlinp%mginp, ierr)                                     0302YZ04
         ener = mc3bbener                                               0302YZ04
         grad(:n3tm) = mc3bbgrad(:n3tm)                                 0302YZ04
         hess(:n3tm,:n3tm) = mc3bbhess(:n3tm,:n3tm)                     0302YZ04


c MC3MPW                                                                0302YZ04
      elseif (mlinp%mlmeth(:6).eq.'mc3mpw') then                        0302YZ04
         call mc3mpwhhk(mlinp%progrms%g3prog, mlinp%geom, 0,            0302YZ04
     *           mlinp%mginp, ierr)                                     0302YZ04
         ener = mc3mpwener                                              0302YZ04
         grad(:n3tm) = mc3mpwgrad(:n3tm)                                0302YZ04
         hess(:n3tm,:n3tm) = mc3mpwhess(:n3tm,:n3tm)                    0302YZ04


c IMOHC
      elseif (mlinp%mlmeth(:5).eq.'imohc') then
         call imohchhk(mlinp%progrms%imohlprog,
     *             mlinp%progrms%imollprog,
     *             mlinp%geom, mlinp%imohcinp, ierr)
         ener = imohcener
         grad(:n3tm) = imohcgrad(:n3tm)
         hess(:n3tm,:n3tm) = imohchess(:n3tm,:n3tm)
c TEST
      elseif (mlinp%mlmeth(:4).eq.'test') then
         call proghhk(mlinp%progrms%testprog,
     *      mlinp%tmeth,mlinp%tbas,
     *      mlinp%geom , mlinp%toptl, ener, grad(:n3tm),
     *      hess(:n3tm,:n3tm), ierr)
         ener = ener + eso + ecc + erel

c
         call testdisp( mlinp%geom%natoms, thess )
      endif

      return
      end
c
c******************************************************************************
c  OPTDISP
c******************************************************************************
c
      subroutine optdisp( iter, geom, ener, grad, xxi, gcomp, gtol )
c
c     Subroutine optdisp
c
c     Created:  July 16, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  Display all information for the current optimization step.
c
c     Called by:  newt, newt2
c     Calls:  
c
c     Variables defined here:  none.
c
      use files, only : outfile
      use input, only : cartgeom

      implicit none

      type (cartgeom) :: geom

      integer iter, i
      double precision  ener, grad(3*geom%natoms), xxi(3*geom%natoms)
      double precision  gcomp, gtol

      write(outfile,1000)  iter
      write(outfile,1150)  ener
      write(outfile,1200)
      write(outfile,1250)  grad
      write(outfile,1300)  gcomp, gtol
      write(outfile,1350)
      write(outfile,1250)  xxi
      write(outfile,1450)
      do 20 i=1, geom%natoms
         write(outfile,1500)  geom%atm(i), geom%aucoord(3*i-2),
     *       geom%aucoord(3*i-1), geom%aucoord(3*i)
  20  continue
      write(outfile,1550)
      do 40 i=1, geom%natoms
         write(outfile,1500)  geom%atm(i), geom%angcoord(3*i-2),
     *      geom%angcoord(3*i-1), geom%angcoord(3*i)
  40  continue
      write(outfile,*)

1000  format(/2x,14('-'),/2x,'Iteration: ',i3,/2x,14('-')/)
1150  format(/2x,'Energy:',t30,f19.12)
1200  format(/2x,'Cartesian Gradient:')
1250  format(t20,d15.8,t40,d15.8,t60,d15.8)
1300  format(/2x,'Maximum Force = ',d10.3,t40,
     *          'Convergence Requirement = ',d10.3)
1350  format(/2x,'Scaled Step:')
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'/)  

      return
      end
c
c***********************************************************************
c  LUDCMP
c***********************************************************************
c
      SUBROUTINE ludcmp(a,n,np,indx,d)
c           
c     subroutine ludcmp
c
c     Created:  July 22, 1999 by J. M. Rodgers
c               From ludcmp in Numerical Recipes
c     Revised:
c     Purpose:  Carry out an LU decomposition of the matrix a
c
c       a    - on entry the matrix a, will be destroyed on exit
c              on exit the LU decomposition of the matrix
c       n    - order of the matrix a
c       np   - the leading dimension of the array a >= max(1,n)
c       indx - a work  array containing the row
c       d    - on exit +/- 1 depending on whether odd/even # of
c                 interchanges
c
c     Called by:  newt
c
      use files, only : outfile

      implicit none

      integer  n, np, indx(np), i, imax, j, k
      double precision  d, a(np,np), aamax, dum, sum
      double precision, dimension(:), allocatable :: vv

      double precision, parameter :: one = 1.0d0, zero = 0.0d0,
     *  tiny = 1.0d-20

      allocate( vv(np) )
c
c  No row interchanges yet.
c
      d=one
c
c  Loop over the rows to get the implicit scaling information and save it
c    in vv.
c
      do 12 i=1, n
         aamax = zero
         do 11 j=1, n
            if (abs(a(i,j)) .gt. aamax)  aamax = abs(a(i,j))
  11     continue
         if (aamax.eq.zero)  then
            write (outfile,*) 'ERROR:  hessian is a singular matrix.'
            stop 'ludcmp 1'
         endif
         vv(i) = one/aamax
  12  continue
c
c  Loop over columns of Crout's method.
c
      do 19 j=1, n
         do 14 i=1, j-1
            sum=a(i,j)
            do 13 k=1, i-1
               sum = sum-a(i,k)*a(k,j)
  13        continue
            a(i,j) = sum
  14     continue
c
c  Search for the largest pivot element.
c
         aamax = zero
         do 16 i=j, n
            sum = a(i,j)
            do 15 k=1, j-1
               sum = sum-a(i,k)*a(k,j)
  15        continue
            a(i,j) = sum
            dum = vv(i)*abs(sum)
            if (dum.ge.aamax) then
               imax = i
               aamax = dum
            endif
  16     continue
c
c  Interchange rows, change the parity of d, and interchange the scale
c    factor if necessary.
c
         if (j.ne.imax) then
            do 17 k=1, n
               dum = a(imax,k)
               a(imax,k) = a(j,k)
               a(j,k) = dum
  17        continue
            d = -d
            vv(imax) = vv(j)
         endif
         indx(j) = imax
c
c  If the pivot element is zero then the matrix is singular.
c
         if (abs(a(j,j)).lt.tiny) then
            write (outfile,*) 'ERROR:  Singular Matrix.'
            write (outfile,*) '  Substituting in a TINY value.'
            a(j,j) = sign(tiny,a(j,j))
c            stop 'ludcmp 2'
         endif

         if (j.ne.n) then
            dum = one/a(j,j)
            do 18 i=j+1, n
               a(i,j) = a(i,j)*dum
  18        continue
         endif
  19  continue

      return
      end
c
c***********************************************************************
c     LUBKSB
c***********************************************************************
c
      SUBROUTINE lubksb(a,n,np,indx,b)
c
c     subroutine lubksb
c
c     Created:  July 22, 1999 by J. M. Rodgers
c               From lubksb in Numerical Recipes
c     Revised:
c     Purpose:  Solves a*x = b.  Second step in finding an inverse
c
c       a    - the LU decomposition of the matrix
c       n    - order of the matrix a
c       np   - the leading dimension of the array a >= max(1,n)
c       indx - a work  array from ludcmp
c       b    - on entry, the vector b in the equation a*x = b
c              on exit, the vector x in the same equation
c
c     Called by:  newt
c
      implicit none

      integer  n, np, indx(np), i, ii, j, ll
      double precision  a(np,np), b(np), sum

      ii = 0
c 
c  Do the forward substition
c  ii will be set to the index of the first nonvanishing element of b.
c  Once ii is nonzero the sum below will actually be calculated.
c
      do 12 i=1, n
         ll = indx(i)
         sum = b(ll)
         b(ll) = b(i)
         if (ii.ne.0) then
            do 11 j=ii, i-1
               sum = sum-a(i,j)*b(j)
  11        continue
         elseif (sum.ne.0) then
            ii = i
         endif
         b(i) = sum
  12  continue
c
c  Now do the back substition.
c
      do 14 i=n, 1, -1
         sum = b(i)
         do 13 j=i+1, n
            sum = sum-a(i,j)*b(j)
  13     continue
c
c  Store component of solution in b
c
         b(i) = sum/a(i,i)
  14  continue

      return
      end
c
c******************************************************************************
c  ROTMOL
c******************************************************************************
c
      subroutine rotmol(oldcoord, newcoord, n, constant, iop)
c  
c     Subroutine rotmol
c
c     Created:  August 11, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  
c        IF IOP>0   To rotate the molecule to new coordinates so that the
c            appropriate atoms are at the origin, on the specified axis,
c            and on the specifed plane.
c        IF IOP<0   To reverse the rotation so that the 3 molecules which
c            were supposed to be on the origin/axis/plane are returned to
c            the plane they were originally on.  Rotation angles, axes,
c            atoms, and translation amounts are saved from the first run
c            with IOP>0 so that this may be possible 
c
c     Called by:  mlohooks
c     Calls:  setrot, rotcol
c
c     Variables defined here:
c
      use param, only : linear, nonlin, lints, nonlints
      use files, only : outfile
      implicit none

      double precision, parameter :: rtod = 180.0d0/3.14159d0

      double precision  oldcoord(3*n), newcoord(3*n), xyz(3,n)
      double precision  savept(3), angle(3)
      integer  constant(3*n), atm(3), axis(3,2), i, iop, n
c
c  Save the rotation angles for when come into routine to undo rotation
c
      save

      write(outfile,1119)
1119  format(/2(/80('-')),/,'Reorienting Geometry:',/80('-'))
      write(outfile,'(/a)') 'Initial Coordinates:'
      do 20 i=1, n
         xyz(1,i) = oldcoord(3*i-2)
         xyz(2,i) = oldcoord(3*i-1)
         xyz(3,i) = oldcoord(3*i)
         write(outfile,1018) xyz(:,i)
  20  continue

      if (iop .gt. 0) then

         call setrot( constant, n, atm, axis )
         savept(:) = xyz(:,atm(1))
c
c  Move atm(1) to the origin
c
         do 25 i=1, n
            xyz(:,i) = xyz(:,i) - savept(:)
  25     continue
c
c  Rotate geometry so that the value of atm(2)'s coordinate on axis(1,2)
c     is zero.
c
         angle(1) = datan2( xyz(axis(1,2),atm(2)),
     *         xyz(axis(1,1),atm(2)) )
         call rotcol( xyz(axis(1,1),:), xyz(axis(1,2),:), n, atm(1),
     *                  0, -angle(1) )
c
c  Rotate the geometry so that the value of atm(2)'s coordinate on
c     axis(2,2) is zero.
c
         angle(2) = datan2( xyz(axis(2,2),atm(2)), 
     *         xyz(axis(2,1),atm(2)) )     
         call rotcol( xyz(axis(2,1),:), xyz(axis(2,2),:), n, atm(1),
     *                  0, -angle(2) )

c
c  For non-linear molecules, rotate the geometry so that the value of
c    atm(3)'s coordinate on axis(3,2) is zero.
c
         if (iop.eq.nonlin .or. iop.eq.nonlints) then
            angle(3) = datan2( xyz(axis(3,2),atm(3)), 
     *            xyz(axis(3,1),atm(3)) )     
            call rotcol( xyz(axis(3,1),:), xyz(axis(3,2),:), n, atm(1),
     *                  atm(2), -angle(3) )
         endif

         write(outfile,'(/a)') 'Rotation Angles:'
         write(outfile,1019) -angle(:)*rtod
c
c  Undo Rotation if IOP is less than zero. - Just do the above in the
c    exact reverse order with the angles and the translation negated.
c
      elseif (iop .lt.0) then
         if (iop.eq.-nonlin .or. iop.eq.-nonlints) then
            call rotcol( xyz(axis(3,1),:), xyz(axis(3,2),:), n, atm(1),
     *                  atm(2), angle(3) )
         endif
         call rotcol( xyz(axis(2,1),:), xyz(axis(2,2),:), n, atm(1),
     *                  0, angle(2) )
         call rotcol( xyz(axis(1,1),:), xyz(axis(1,2),:), n, atm(1),
     *                  0, angle(1) )
         do 40 i=1, n
            xyz(:,i) = xyz(:,i) + savept(:)
  40     continue

         write(outfile,'(/a)') 'Rotation Angles:' 
         write(outfile,1019) angle(3)*rtod,angle(2)*rtod,angle(1)*rtod
      endif

      write(outfile,'(/a)') 'Reoriented Coordinates:'
      do 60 i=1, n
         write(outfile,1018) xyz(:,i)
         newcoord(3*i-2) = xyz(1,i)
         newcoord(3*i-1) = xyz(2,i)
         newcoord(3*i) = xyz(3,i)
  60  continue
      write(outfile,1025)
1025  format(/,80('-'),//)

1018  format(3(3x,d16.9))
1019  format(3(3x,f10.4))

      return
      end
c
c******************************************************************************
c  SETROT
c******************************************************************************
c
      subroutine setrot( c, n, atm, axis )
c
c     Subroutine setrot
c
c     Created:  August 11, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To set the atoms and axes important for the rotation of
c        the molecule based on the information provided in constant in
c        mlopt.
c
c     Note:  axis(3,2) has the two columns in the geometry which may
c       change in the ith rotation in axis(i,1) and axis(i,2)
c
c     Called by:  rotmol
c     
c     Variables defined here:
c     
      use files, only : outfile
      implicit none

      integer n, c(3*n), atm(3), axis(3,2), i

      do 10 i=1, 3
         atm(i) = 0
         axis(i,1) = 0
         axis(i,2) = 0
  10  continue

      do 20 i=1, n
         if (c(3*i-2).eq.1 .and. c(3*i-1).eq.1 .and. 
     *            c(3*i).eq.1)  then
            atm(1) = i
         elseif (c(3*i-2).eq.1 .and. c(3*i-1).eq.1)  then
            atm(2) = i
            axis(1,2) = 1
            axis(2,2) = 2
            axis(1,1) = 3
            axis(2,1) = 3
         elseif (c(3*i-2).eq.1 .and. c(3*i).eq.1)  then
            atm(2) = i
            axis(1,2) = 1
            axis(2,2) = 3
            axis(1,1) = 2
            axis(2,1) = 2
         elseif (c(3*i-1).eq.1 .and. c(3*i).eq.1)  then
            atm(2) = i
            axis(1,2) = 2
            axis(2,2) = 3
            axis(1,1) = 1
            axis(2,1) = 1
         elseif (c(3*i-2).eq.1)  then
            atm(3) = i
            axis(3,2) = 1
         elseif (c(3*i-1).eq.1)  then
            atm(3) = i
            axis(3,2) = 2
         elseif (c(3*i).eq.1)  then
            atm(3) = i
            axis(3,2) = 3
         endif
  20  continue

      if (axis(1,1) .eq. axis(3,2)) then
         write (outfile,*) 'ERROR in creating rotation axes:'
         write (outfile,1115)
         stop 'setrot 1'
      endif

1115  format(2x,'The frozen coordinate for the third atom must be ',
     *    /5x,'the same as one of the frozen coordinates for ',
     *    /5x,'the second atom.')

      axis(3,1) = 6

      if (axis(1,1).eq.1 .or. axis(3,2).eq.1)  axis(3,1) = axis(3,1)-1
      if (axis(1,1).eq.2 .or. axis(3,2).eq.2)  axis(3,1) = axis(3,1)-2
      if (axis(1,1).eq.3 .or. axis(3,2).eq.3)  axis(3,1) = axis(3,1)-3

      return
      end
c
c******************************************************************************
c  ROTCOL
c******************************************************************************
c
      subroutine rotcol( col1, col2, n, atm1, atm2, a0 )
c
c     Subroutine rotcol
c
c     Created:  August 11, 1999 by J. M. Rodgers
c     Revised:
c     Purpose:  To rotate col1 and col2 about the remaining 3rd axis by an
c        angle a0.  atm1 and atm2 specify atoms which should remain
c        constant.
c
c     Called by:  rotmol
c
c     Variables defined here:
c
      implicit none

      integer n, atm1, atm2, i
      double precision  col1(n), col2(n), a0, a, r

      do 20 i=1, n
         if (i.eq.atm1 .or. i.eq.atm2)   goto 20
         r = sqrt(col1(i)**2 + col2(i)**2)
         a = datan2( col2(i), col1(i) )

         col1(i) = r*dcos(a+a0)
         col2(i) = r*dsin(a+a0)
  20  continue

      return
      end

