       subroutine mcscf_genfock(geom, basis, nclosed, nact, nbf,
     $                          tol2e, dm1, dm2,
     $                          g_ifock, g_afock,
     $                          g_coul, g_gfock)
       implicit none
#include "mafdecls.h"
#include "global.fh"
#include "rtdb.fh"
#include "bas.fh"
#include "geom.fh"
c
c
c NB. The definition for the *generalized* Fock
c     elements is defined as twice the normal Fock elements 
c     (see Siegbahn et al.) and therefore the gradient 
c     is twice the generalized Fock element. This routine
c     follows this convention, i.e.,
c
c                   gen    gen
c          g   = 2(F    - F   )  = 4F
c           pq      pq     qp        pq
c
c
c Note the asymmetry in the generalized Fock,
c
c
c          F   =  0      for p not closed-shell
c           pi
c
c
c          F   =  0      for p not open-shell
c           pt
c
c
c
       integer geom, basis
       integer nclosed, nact, nbf
       double precision tol2e
       double precision dm1(nact,nact)
       double precision dm2(nact,nact,nact,nact)
       integer g_ifock
       integer g_afock
       integer g_coul
       integer g_gfock
c
c
c
       integer g_tmp1
c
c
c
       integer ga_create_moblocked
       external ga_create_moblocked
c
c
c
       call ga_zero(g_gfock)
       g_tmp1 = ga_create_moblocked(nbf, 'Scratch 1')
c
c
c
       call ga_dadd_patch( 1.d0, g_ifock, 1, nclosed, 1, nbf,
     $                     1.d0, g_afock, 1, nclosed, 1, nbf,
     $                           g_gfock, 1, nclosed, 1, nbf )
c
c
c
       call ga_zero(g_tmp1)
       call mcscf_denfock_trace(nclosed,nact,nbf,dm1,
     $                          g_ifock,g_tmp1)
       call mcscf_3index_trace(nbf,nclosed,nact,dm2,
     $                         g_coul,g_tmp1)
       call ga_copy_patch('n',g_tmp1,nclosed+1,nclosed+nact,1,nbf,
     $                        g_gfock,nclosed+1,nclosed+nact,1,nbf)
       call ga_dscal(g_gfock,2.d0)
c
c
c
       if (.not.ga_destroy(g_tmp1))
     $      call errquit('mcscf_genfock: cannot destroy',0, GA_ERR)
       return
       end

       







       subroutine mcscf_denfock_trace(nclosed,nact,nbf,dm1,g_if,g_a)
       implicit none
#include "mafdecls.fh"
#include "global.fh"
       integer nclosed, nact, nbf
       double precision dm1(nact,nact)
       integer g_if, g_a
c
c
c
       integer l_ff, k_ff
       integer clo,chi,msize
       integer k_if,ld
       logical ga_check_moblocked 
       external ga_check_moblocked
c
c
c
       if (.not.ga_check_moblocked(g_if,nbf,clo,chi))
     $      call errquit('mcscf_denfock_trace: wrong distrib.',0)
       msize = (chi-clo+1)*nact
       if (.not.ma_push_get(MT_DBL,msize,'ff',l_ff,k_ff))
     $      call errquit('mcscf_denfock_trace: cannot allocate',0)
       call dfill(msize,0.d0,dbl_mb(k_ff),1)
       call ga_access(g_if,1,nbf,clo,chi,k_if,ld)
       call mcscf_trace_xyz(nbf,nclosed,nact,clo,chi,dbl_mb(k_if),
     $                      dm1,dbl_mb(k_ff))
       call ga_release(g_if,1,nbf,clo,chi)
C       call rect_matrix_pr(nact,(chi-clo+1),dbl_mb(k_ff))
       call ga_acc(g_a,nclosed+1,nclosed+nact,clo,chi,dbl_mb(k_ff),
     $             nact,1.d0)


c      
c
c
       if (.not.ma_pop_stack(l_ff))
     $      call errquit('mcscf_denfock_trace: cannot pop stack',0)
       return
       end










       subroutine mcscf_trace_xyz(nbf,nclosed,nact,clo,chi,inf,
     $                            dm1,ff)
       implicit none
       integer nbf,nclosed,nact
       integer clo,chi
       double precision inf(nbf,clo:chi)
       double precision dm1(nact,nact)
       double precision ff(nact,clo:chi)
       integer clen,offset
       
       clen = chi - clo + 1
       offset = nclosed + 1
       call dgemm('n','n',nact,clen,nact,1.d0,dm1,nact,inf(offset,clo),
     $            nbf,0.d0,ff,nact)
       return
       end









       subroutine mcscf_3index_trace(nbf,nclosed,nact,dm2,g_coul,g_a)
       implicit none
#include "mafdecls.fh"
#include "global.fh"
       integer nbf,nclosed,nact
       double precision dm2(nact,nact,nact,nact)
       integer g_coul,g_a

       integer nn,clo,chi,ld,k_c
       integer k_ff, l_ff, msize
       logical ga_check_JKblocked
       external ga_check_JKblocked
c
c
c
       msize = nbf*nact
       nn = nbf*nbf
       if (.not.ma_push_get(MT_DBL,msize,'ff',l_ff,k_ff))
     $      call errquit('mcscf_denfock_trace: cannot allocate',0)
       call dfill(msize,0.d0,dbl_mb(k_ff),1)
       if (.not.ga_check_JKblocked(g_coul,nact,nbf,clo,chi))
     $    call errquit('mcscf_denfock_trace: wrong distrib operator',0)
       call ga_access(g_coul,1,nn,clo,chi,k_c,ld)
       call mcscf_trace_pqr(nbf,nclosed,nact,clo,chi,dbl_mb(k_c),dm2,
     $                      dbl_mb(k_ff),g_a)
       call ga_release(g_coul,1,nn,clo,chi)
c
c
c
       if (.not.ma_pop_stack(l_ff))
     $      call errquit('mcscf_3index_trace: cannot pop stack',0)
       return
       end







       subroutine mcscf_trace_pqr(nbf,nclosed,nact,clo,chi,c,dm2,
     $                            ff,g_a)
       implicit none
#include "global.fh"
       integer nbf,nclosed,nact,clo,chi
       integer g_a
       double precision c(nbf,nbf,clo:chi)
       double precision dm2(nact,nact,nact,nact)
       double precision ff(nact,nbf)

       integer offset
       integer v,x,vx
       double precision scale

       offset = nclosed + 1
       scale = 2.d0
       do v=1,nact
         do x=1,v
           vx = (v*(v-1))/2 + x
           if ((vx.ge.clo).and.(vx.le.chi)) then
             call dgemm('n','n',nact,nbf,nact,scale,dm2(1,1,x,v),nact,
     $                  c(offset,1,vx),nbf,0.d0,ff,nact)
             if (v.ne.x)
     $         call dgemm('n','n',nact,nbf,nact,scale,dm2(1,1,v,x),
     $                     nact,c(offset,1,vx),nbf,1.d0,ff,nact)
             call ga_acc(g_a,nclosed+1,nclosed+nact,1,nbf,ff,nact,1.d0)
           endif
         enddo
       enddo
       return
       end













        
       subroutine mcscf_act_fock(nact,nbf,d1,g_coul,g_exch,g_afock)
       implicit none
#include "mafdecls.fh"
#include "global.fh"
       integer nact,nbf
       double precision d1(nact,nact)
       integer g_coul, g_exch, g_afock
       integer l_f,k_f,t1,t2,ld_y,k_y
       integer t,u,tu,nn
       double precision s
c
c       
       logical ga_check_JKblocked
       external ga_check_JKblocked
c
c Check distribution
c
       if ((.not.ga_check_JKblocked(g_coul,nact,nbf,t1,t2)).or.
     $     (.not.ga_check_JKblocked(g_exch,nact,nbf,t1,t2)))
     $     call errquit('wrong distribution for operators',0)
c
c Allocate
c
       call ga_zero(g_afock)
       if (.not.ma_push_get(MT_DBL,(nbf*nbf),'f tmp',l_f,k_f))
     $      call errquit('mcscf_act_fock: cannot alloc',0)
c
c Take the trace:    Factive = tr(D1.J) - 0.5d0 * tr(D1.K)
c
       nn = nbf*nbf
       do t=1,nact
         do u=1,t
           tu = (t*(t-1))/2 + u
           s = d1(t,u)
           if (t.ne.u) s = s*2.d0
           if ((tu.ge.t1).and.(tu.le.t2)) then
             call dfill(nn,0.d0,dbl_mb(k_f),1)
             call ga_access(g_coul,1,nn,tu,tu,k_y,ld_y)
             call daxpy(nn,s,dbl_mb(k_y),1,dbl_mb(k_f),1)
             call ga_release(g_coul,1,nn,tu,tu)
             call ga_access(g_exch,1,nn,tu,tu,k_y,ld_y)
             call daxpy(nn,-0.5d0*s,dbl_mb(k_y),1,dbl_mb(k_f),1)
             call ga_release(g_exch,1,nn,tu,tu)
             call ga_acc(g_afock,1,nbf,1,nbf,dbl_mb(k_f),nbf,1.d0)
           endif
         enddo
       enddo
       call ga_sync()
c
c
c
       if (.not.ma_pop_stack(l_f))
     $      call errquit('mcscf_act_fock: cannot pop stack',0)
       return
       end











       subroutine mcscf_dens2mo(rtdb, geom, basis, nbf, occ, tol2e,
     $                          g_dens, g_mocf, oskel)
       implicit none
#include "mafdecls.fh"
#include "global.fh"
#include "bas.fh"
#include "tcgmsg.fh"
#include "geom.fh"
#include "rtdb.fh"
#include "util.fh"
       integer rtdb, geom, basis, nbf
       double precision occ(*)  ! [input] occupation vector
       double precision tol2e   ! [input] selection threshold for 2e integs
       integer g_dens           ! [input] AO density in GA
       integer g_mocf           ! [output] MO vectors in GA
c
c     Given a density in g_dens return an orthonormal set of
c     mo vectors in g_mocf by doing an approximate Fock build
c     and a diagonalization
c
       logical oprint, osplit, oskel
       integer g_fock, g_over, g_hcore
       integer nelec, nocc
       integer l_ev, k_ev
       integer i
       double precision escf, eone, etwo, enrep, dens_norm
       integer ga_create_atom_blocked
       external ga_create_atom_blocked
c
      oprint = util_print('mo guess', print_default)
      call mcscf_occ2elec( nbf, occ, nelec )
c
c     The guess density must be symmetrized if sym is used
c
      if (oskel)
     $     call sym_symmetrize(geom, basis, .true., g_dens)
c
       if (.not. geom_nuc_rep_energy(geom, enrep))
     $      call errquit('rhf_dens_to_mo: no enrep?', 0)
       if (.not. ma_push_get(MT_DBL, nbf, 'Evals', l_ev, k_ev))
     $      call errquit('rhf_dens_to_mo: push of evals failed', nbf)
c
       g_fock  = ga_create_atom_blocked(geom, basis,'Temp Fock')
       g_hcore = ga_create_atom_blocked(geom, basis,'Temp HCore')
       g_over  = ga_create_atom_blocked(geom, basis,'Temp Over')
c
c     If the norm of the density matrix is non-zero then adjust
c     it so that it specifies the correct no. of electrons
c
       call ga_zero(g_over)
       call int_1e_ga(basis, basis, g_over, 'overlap', .false.)
       if (util_print('ao overlap',print_debug))
     $      call ga_print(g_over)
       dens_norm = ga_ddot(g_over, g_dens)
       if (abs(dens_norm) .gt. 1.0d-2) then
          if (ga_nodeid() .eq. 0 .and. oprint) then
             write(6,17) dens_norm, nelec
 17          format(/' Renormalizing density from ',f8.2,' to ',i4)
             call util_flush(6)
          endif
          dens_norm = dble(nelec)/dens_norm
          call ga_dscal(g_dens, dens_norm)
       endif
c
c     Diagonalize the overlap to examine eigenvalues for linear dependence
c
       if (oprint) then
#ifdef PARALLEL_DIAG
          call ga_diag_std(g_over, g_mocf, dbl_mb(k_ev))
#else
          call ga_diag_std_seq(g_over, g_mocf, dbl_mb(k_ev))
#endif
          if (ga_nodeid() .eq. 0) then
             write(6,*) ' Eigenvalues of the overlap matrix '
             write(6,33) (dbl_mb(k_ev+i),i=0,nbf-1)
 33          format(1p,8d9.2)
             call util_flush(6)
          endif
       endif
c
c     Build the fock_matrix and overlap matrix
c
       call ga_zero(g_fock)
       call ga_zero(g_hcore)
       call ga_zero(g_over)
       call int_1e_ga(basis, basis, g_over, 'overlap', .false.)
       call int_1e_ga(basis, basis, g_hcore,'kinetic', oskel)
       call int_1e_ga(basis, basis, g_hcore,'potential', oskel)
c
       if (abs(dens_norm) .gt. 1d-2)
     $      call rhf_fock_2e(geom, basis, g_dens, g_fock, tol2e,
     &        .true., .true., oskel)
c
c     Compute contributions to the energy and diagonalize ... note
c     that we can do this with the skelton matrices
c
       call ga_screen(g_hcore, 1.0d-13) ! Force zeroes due to symmetries
       call ga_screen(g_fock, 1.0d-13) ! Force zeroes due to symmetries
       eone = ga_ddot(g_hcore,g_dens)
       etwo = 0.5d0*ga_ddot(g_fock,g_dens)
       escf = eone + etwo + enrep
       call ga_dadd(1.d0,g_hcore,1.d0,g_fock,g_fock)
c
       if (oskel) then
          call sym_symmetrize(geom, basis, .false., g_fock)
       endif
c
c
c
#if defined(PARALLEL_DIAG)
       call ga_diag(g_fock,g_over,g_mocf,dbl_mb(k_ev))
#else
       call ga_diag_seq(g_fock,g_over,g_mocf,dbl_mb(k_ev))
#endif
       call ga_sync()
c
       nocc = nelec/2           !
**       osplit = abs(dbl_mb(k_ev+nocc-1)-dbl_mb(k_ev+nocc)).lt.1.0e-3
       osplit = .false.
       if (ga_nodeid().eq.0 .and. (oprint .or. osplit)) then
          write(6,*)
          call util_print_centered(6, 'Non-variational initial energy',
     $         20, .true.)
          write(6,901) escf, eone, etwo,
     $         dbl_mb(k_ev+nocc-1), dbl_mb(k_ev+nocc)
 901     format(/
     $         ' Total energy = ',f14.6/
     $         ' 1-e energy   = ',f14.6/
     $         ' 2-e energy   = ',f14.6/
     $         ' HOMO         = ',f14.6/
     $         ' LUMO         = ',f14.6/)
c
         if (osplit) then
            write(6,902)
 902        format(' !! WARNING: occupation is splitting degenerate',
     $           ' orbitals'/)
            if (oskel) write(6,903)
 903        format(' !! Cannot use symmetry with ',
     $           'non-symmetric occupation ... swap orbitals or '/
     $           ' !! must disable skeleton Fock build'/)
            write(6,*) ' Eigenvalues '
            write(6,*)
            call output(dbl_mb(k_ev), 1, nbf, 1, 1, nbf, 1, 1)
         endif
         call util_flush(6)
       endif
c
       if (.not. ga_destroy(g_fock)) call errquit
     $      ('rhf_dens_to_mo: destroy of fock?', 0)
       if (.not. ga_destroy(g_over)) call errquit
     $      ('rhf_dens_to_mo: destroy of over?', 0)
       if (.not. ga_destroy(g_hcore)) call errquit
     $      ('rhf_dens_to_mo: destroy of hcore?', 0)
       if (.not. ma_pop_stack(l_ev)) call errquit
     $      ('rhf_dens_to_mo: destroy of ev?', 0)
c
       end
c
c Convert the matrix representation of the MCSCF
c parameters to vector representation (complement of mcscf_vec2mat)
c Accumulates into the vector (does not copy!)
c
c
c

       subroutine mcscf_mat2vec( nbf, nclosed, nact, a, g_m, b, g_v )
       implicit none
#include "global.fh"
#include "mafdecls.fh"
c
c
       integer nbf                                  ! [input] Basis functions
       integer nclosed                              ! [input] Closed shells
       integer nact                                 ! [input] Active shells
       double precision b,a                         ! [input] Additive factors
       integer g_m                                  ! [input] Matrix representation
       integer g_v                                  ! [output] Vector representation
c
c
       integer nvir, vlen
       integer voff, aoff, aend, xoff, xend
c
c
c
       nvir = nbf - nclosed - nact
       vlen = (nclosed+nact)*nvir + nclosed*nact
       voff = nclosed + nact + 1
       aoff = nclosed + 1
       aend = nclosed + nact
c
c
c
       xend = nvir*nclosed
       call ga_dadd_patch( a, g_m, voff, nbf, 1, nclosed,
     $                     b, g_v, 1, xend, 1, 1,
     $                        g_v, 1, xend, 1, 1)
       xoff = xend + 1
       xend = xend + nact*nvir
       call ga_dadd_patch( a, g_m, voff, nbf, aoff, aend,
     $                     b, g_v, xoff, xend, 1, 1,
     $                        g_v, xoff, xend, 1, 1)
       xoff = xend + 1
       xend = vlen
       call ga_dadd_patch( a, g_m, aoff, aend, 1, nclosed,
     $                     b, g_v, xoff, xend, 1, 1,
     $                        g_v, xoff, xend, 1, 1)
       return
       end

       subroutine mcscf_occ2dens( nbf, nclosed, nact, dm1,
     $                            g_movecs, g_cdens, g_adens )
       implicit none
#include "mafdecls.fh"
#include "global.fh"
c
       integer nbf
       integer nclosed
       integer nact
       double precision dm1(nact,nact)
       integer g_movecs
       integer g_cdens
       integer g_adens
c
c
       integer aoff, aend
       integer g_dm1
c
c
c
       aoff = nclosed + 1
       aend = nclosed + nact
c
c
c
       if (.not.ga_create(MT_DBL,nact,nact,'1PDM',nact,1,g_dm1))
     $   call errquit('mcscf_occ2dens: cannot create 1PDM',0)
       if (ga_nodeid().eq.0)
     $   call ga_put(g_dm1,1,nact,1,nact,dm1,nact)
       call ga_sync()
c
c Active AO density (use closed shell dens for temp)
c
       call ga_matmul_patch( 'n', 't', 1.d0, 0.d0,
     $                       g_dm1, 1, nact, 1, nact,
     $                       g_movecs, aoff, aend, 1, nbf,
     $                       g_cdens, 1, nact, 1, nbf )
       call ga_matmul_patch( 'n', 'n', 1.d0, 0.d0,
     $                       g_movecs, 1, nbf, aoff, aend,
     $                       g_cdens, 1, nact, 1, nbf,
     $                       g_adens, 1, nbf, 1, nbf )
c
c
       if (.not.ga_destroy(g_dm1))
     $   call errquit('mcscf_occ2dens: cannot destroy',0)
c
c Closed AO density
c
       call ga_dgemm( 'n', 't', nbf, nbf, nclosed, 2.d0,
     $                g_movecs, g_movecs, 0.d0, g_cdens )
       return
       end
c
c Convert the vector representation of the MCSCF
c parameters to a (nbf x nbf) matrix representation
c Accumulates into the matrix (does not copy!)
c
c
c

       subroutine mcscf_vec2mat( nbf, nclosed, nact, a, g_v, b, g_m )
       implicit none
#include "global.fh"
#include "mafdecls.fh"
c
c
       integer nbf                                  ! [input] Basis functions
       integer nclosed                              ! [input] Closed shells
       integer nact                                 ! [input] Active shells
       double precision b,a                         ! [input] Additive factors
       integer g_v                                  ! [input] Vector representation
       integer g_m                                  ! [output] Matrix representation
c
c
       integer nvir, vlen
       integer voff, aoff, aend, xoff, xend
c
c
       nvir = nbf - nclosed - nact
       vlen = (nclosed+nact)*nvir + nclosed*nact
       voff = nclosed + nact + 1
       aoff = nclosed + 1
       aend = nclosed + nact
c
c
c
       call ga_dadd_patch( a, g_v, 1, (nvir*nclosed), 1, 1,
     $                     b, g_m, voff, nbf, 1, nclosed,
     $                        g_m, voff, nbf, 1, nclosed )
       xoff = nclosed*nvir + 1
       xend = nclosed*nvir + nact*nvir
       call ga_dadd_patch( a, g_v, xoff, xend, 1, 1,
     $                     b, g_m, voff, nbf, aoff, aend,
     $                        g_m, voff, nbf, aoff, aend )
       xoff = xend + 1
       xend = xend + nclosed*nact
       call ga_dadd_patch( a, g_v, xoff, xend, 1, 1,
     $                     b, g_m, aoff, aend, 1, nclosed,
     $                        g_m, aoff, aend, 1, nclosed )
c
c
c
       return
       end

       
       subroutine mcscf_dens2mo(rtdb, geom, basis, nbf, occ, tol2e,
     $                          g_dens, g_mocf, oskel)
       implicit none
#include "mafdecls.fh"
#include "global.fh"
#include "bas.fh"
#include "tcgmsg.fh"
#include "geom.fh"
#include "rtdb.fh"
#include "util.fh"
       integer rtdb, geom, basis, nbf
       double precision occ(*)  ! [input] occupation vector
       double precision tol2e   ! [input] selection threshold for 2e integs
       integer g_dens           ! [input] AO density in GA
       integer g_mocf           ! [output] MO vectors in GA
c
c     Given a density in g_dens return an orthonormal set of
c     mo vectors in g_mocf by doing an approximate Fock build
c     and a diagonalization
c
       logical oprint, osplit, oskel
       integer g_fock, g_over, g_hcore
       integer nelec, nocc
       integer l_ev, k_ev
       integer i
       double precision escf, eone, etwo, enrep, dens_norm
       integer ga_create_atom_blocked
       external ga_create_atom_blocked
c
      oprint = util_print('mo guess', print_default)
      call mcscf_occ2elec( nbf, occ, nelec )
c
c     The guess density must be symmetrized if sym is used
c
      if (oskel)
     $     call sym_symmetrize(geom, basis, .true., g_dens)
c
       if (.not. geom_nuc_rep_energy(geom, enrep))
     $      call errquit('rhf_dens_to_mo: no enrep?', 0)
       if (.not. ma_push_get(MT_DBL, nbf, 'Evals', l_ev, k_ev))
     $      call errquit('rhf_dens_to_mo: push of evals failed', nbf)
c
       g_fock  = ga_create_atom_blocked(geom, basis,'Temp Fock')
       g_hcore = ga_create_atom_blocked(geom, basis,'Temp HCore')
       g_over  = ga_create_atom_blocked(geom, basis,'Temp Over')
c
c     If the norm of the density matrix is non-zero then adjust
c     it so that it specifies the correct no. of electrons
c
       call ga_zero(g_over)
       call int_1e_ga(basis, basis, g_over, 'overlap', .false.)
       if (util_print('ao overlap',print_debug))
     $      call ga_print(g_over)
       dens_norm = ga_ddot(g_over, g_dens)
       if (abs(dens_norm) .gt. 1.0d-2) then
          if (ga_nodeid() .eq. 0 .and. oprint) then
             write(6,17) dens_norm, nelec
 17          format(/' Renormalizing density from ',f8.2,' to ',i4)
             call util_flush(6)
          endif
          dens_norm = dble(nelec)/dens_norm
          call ga_dscal(g_dens, dens_norm)
       endif
c
c     Diagonalize the overlap to examine eigenvalues for linear dependence
c
       if (oprint) then
#ifdef PARALLEL_DIAG
          call ga_diag_std(g_over, g_mocf, dbl_mb(k_ev))
#else
          call ga_diag_std_seq(g_over, g_mocf, dbl_mb(k_ev))
#endif
          if (ga_nodeid() .eq. 0) then
             write(6,*) ' Eigenvalues of the overlap matrix '
             write(6,33) (dbl_mb(k_ev+i),i=0,nbf-1)
 33          format(1p,8d9.2)
             call util_flush(6)
          endif
       endif
c
c     Build the fock_matrix and overlap matrix
c
       call ga_zero(g_fock)
       call ga_zero(g_hcore)
       call ga_zero(g_over)
       call int_1e_ga(basis, basis, g_over, 'overlap', .false.)
       call int_1e_ga(basis, basis, g_hcore,'kinetic', oskel)
       call int_1e_ga(basis, basis, g_hcore,'potential', oskel)
c
       if (abs(dens_norm) .gt. 1d-2)
     $      call rhf_fock_2e(geom, basis, g_dens, g_fock, tol2e,
     &        .true., .true., oskel)
c
c     Compute contributions to the energy and diagonalize ... note
c     that we can do this with the skelton matrices
c
       call ga_screen(g_hcore, 1.0d-13) ! Force zeroes due to symmetries
       call ga_screen(g_fock, 1.0d-13) ! Force zeroes due to symmetries
       eone = ga_ddot(g_hcore,g_dens)
       etwo = 0.5d0*ga_ddot(g_fock,g_dens)
       escf = eone + etwo + enrep
       call ga_dadd(1.d0,g_hcore,1.d0,g_fock,g_fock)
c
       if (oskel) then
          call sym_symmetrize(geom, basis, .false., g_fock)
       endif
c
c
c
#if defined(PARALLEL_DIAG)
       call ga_diag(g_fock,g_over,g_mocf,dbl_mb(k_ev))
#else
       call ga_diag_seq(g_fock,g_over,g_mocf,dbl_mb(k_ev))
#endif
       call ga_sync()
c
       nocc = nelec/2           !
**       osplit = abs(dbl_mb(k_ev+nocc-1)-dbl_mb(k_ev+nocc)).lt.1.0e-3
       osplit = .false.
       if (ga_nodeid().eq.0 .and. (oprint .or. osplit)) then
          write(6,*)
          call util_print_centered(6, 'Non-variational initial energy',
     $         20, .true.)
          write(6,901) escf, eone, etwo,
     $         dbl_mb(k_ev+nocc-1), dbl_mb(k_ev+nocc)
 901     format(/
     $         ' Total energy = ',f14.6/
     $         ' 1-e energy   = ',f14.6/
     $         ' 2-e energy   = ',f14.6/
     $         ' HOMO         = ',f14.6/
     $         ' LUMO         = ',f14.6/)
c
         if (osplit) then
            write(6,902)
 902        format(' !! WARNING: occupation is splitting degenerate',
     $           ' orbitals'/)
            if (oskel) write(6,903)
 903        format(' !! Cannot use symmetry with ',
     $           'non-symmetric occupation ... swap orbitals or '/
     $           ' !! must disable skeleton Fock build'/)
            write(6,*) ' Eigenvalues '
            write(6,*)
            call output(dbl_mb(k_ev), 1, nbf, 1, 1, nbf, 1, 1)
         endif
         call util_flush(6)
       endif
c
       if (.not. ga_destroy(g_fock)) call errquit
     $      ('rhf_dens_to_mo: destroy of fock?', 0)
       if (.not. ga_destroy(g_over)) call errquit
     $      ('rhf_dens_to_mo: destroy of over?', 0)
       if (.not. ga_destroy(g_hcore)) call errquit
     $      ('rhf_dens_to_mo: destroy of hcore?', 0)
       if (.not. ma_pop_stack(l_ev)) call errquit
     $      ('rhf_dens_to_mo: destroy of ev?', 0)
c
       end
       subroutine moints_print_opermatrix(noper,nbf,g_a)
       implicit none
#include "global.fh"
#include "mafdecls.fh"       
       integer noper,nbf
       integer g_a
       integer j,k,jk
       integer my_id, ilo, ihi, jlo, jhi
       integer k_local, ld_local

       my_id = ga_nodeid()
       call ga_distribution(g_a,my_id,ilo,ihi,jlo,jhi)
       do j=1,noper
         do k=1,j
           jk = (j*(j-1))/2 + k
           if ((jk.ge.jlo).and.(jk.le.jhi)) then
             write(6,901) j,k
 901         format(//,'Operator: [',i2,',',i2,']',/)
             print*,my_id,'  ',ilo,ihi,'  ',jk
             call ga_access(g_a,ilo,ihi,jk,jk,k_local,ld_local)
             call square_matrix_pr(nbf,dbl_mb(k_local))
           endif
           call ga_sync()
         enddo
       enddo

       return
       end
       

c
c This is a crappy hack to get the ROHF and MCSCF to agree
c on the 1e Hessian
c
c

       subroutine mcscf_hack1( nbf, nclosed, nact, g_coul, g_exch,
     $                             g_x, g_ax )
       implicit none
#include "global.fh"
#include "mafdecls.fh"
c
c
       integer nbf
       integer nclosed
       integer nact
       integer g_coul
       integer g_exch
       integer g_x
       integer g_ax
c
c
c

       integer nvir, vlen
       integer l_v, k_v, l_av, k_av, k_j, k_k, ld1, ld2
       integer jlo, jhi, xoff, voff
       integer v, vv, nn
       logical ga_check_JKblocked
       external ga_check_JKblocked
c
c
       nn = nbf*nbf
       nvir = nbf - nclosed - nact
       vlen = (nclosed+nact)*nvir + nclosed*nact
       voff = nclosed + nact + 1
c
c
c
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_v,k_v))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_av,k_av))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
c
c
c
       xoff = nclosed*nvir + 1
       call ga_get(g_x,1,vlen,1,1,dbl_mb(k_v),vlen)
       call dfill(vlen,0.d0,dbl_mb(k_av),1)
c
c
c
       if (.not.ga_check_JKblocked(g_coul,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_coul,1,nn,vv,vv,k_j,ld1)
           call mcscf_hack01( nbf, nvir, nact, voff, 2.d0,
     $                        dbl_mb(k_v+xoff-1), dbl_mb(k_j),
     $                        dbl_mb(k_av+xoff-1))
           call ga_release(g_coul,1,nn,vv,vv)
         endif
       enddo
c
c
c
       if (.not.ga_check_JKblocked(g_exch,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_exch,1,nn,vv,vv,k_k,ld2)
           call mcscf_hack01( nbf, nvir, nact, voff, -2.d0,
     $                        dbl_mb(k_v+xoff-1), dbl_mb(k_k),
     $                        dbl_mb(k_av+xoff-1))
           call ga_release(g_exch,1,nn,vv,vv)
         endif
       enddo
c
c
c
       call ga_acc(g_ax,1,vlen,1,1,dbl_mb(k_av),vlen,1.d0)
       if (.not.ma_pop_stack(l_av))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
       if (.not.ma_pop_stack(l_v))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
c
c
       return
       end








       subroutine mcscf_hack01( nbf, nvir, nact, voff, scale, x,
     $                          eri, ax )
       implicit none
       integer nbf, nvir, nact, voff
       double precision scale
       double precision x(nvir,nact), eri(nbf,nbf), ax(nvir,nact)

       call dgemm( 'n', 'n', nvir, nact, nvir, scale, eri(voff,voff),
     $             nbf, x, nvir, 1.d0, ax, nvir )
       
       return
       end
















       subroutine mcscf_hack2( nbf, nclosed, nact, g_coul, g_exch,
     $                             g_x, g_ax )
       implicit none
#include "global.fh"
#include "mafdecls.fh"
c
c
       integer nbf
       integer nclosed
       integer nact
       integer g_coul
       integer g_exch
       integer g_x
       integer g_ax
c
c
c

       integer nvir, vlen
       integer l_v, k_v, l_av, k_av, k_j, k_k, ld1, ld2
       integer jlo, jhi, xoff, yoff, voff
       integer v, vv, nn
       logical ga_check_JKblocked
       external ga_check_JKblocked
c
c
       nn = nbf*nbf
       nvir = nbf - nclosed - nact
       vlen = (nclosed+nact)*nvir + nclosed*nact
       voff = nclosed + nact + 1
c
c
c
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_v,k_v))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_av,k_av))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
c
c
c
       xoff = (nclosed+nact)*nvir + 1
       yoff = nclosed*nvir + 1
       call ga_get(g_x,1,vlen,1,1,dbl_mb(k_v),vlen)
       call dfill(vlen,0.d0,dbl_mb(k_av),1)
c
c
c
       if (.not.ga_check_JKblocked(g_coul,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_coul,1,nn,vv,vv,k_j,ld1)
           call mcscf_hack02( nbf, nclosed, nvir, nact, -2.d0,
     $                        dbl_mb(k_v+xoff-1),
     $                        voff, 1, dbl_mb(k_j),
     $                        dbl_mb(k_av+yoff-1))
           call ga_release(g_coul,1,nn,vv,vv)
         endif
       enddo
c
c
c
       if (.not.ga_check_JKblocked(g_exch,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_exch,1,nn,vv,vv,k_k,ld2)
           call mcscf_hack02( nbf, nclosed, nvir, nact, 2.d0,
     $                        dbl_mb(k_v+xoff-1),
     $                        voff, 1, dbl_mb(k_k),
     $                        dbl_mb(k_av+yoff-1))
           call ga_release(g_exch,1,nn,vv,vv)
         endif
       enddo
c
c
c
       call ga_acc(g_ax,1,vlen,1,1,dbl_mb(k_av),vlen,1.d0)
       if (.not.ma_pop_stack(l_av))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
       if (.not.ma_pop_stack(l_v))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
c
c
       return
       end







       subroutine mcscf_hack02( nbf, nclosed, nvir, nact, scale, x,
     $                          roff, coff, eri, ax )
       implicit none
       integer nbf, nclosed, nvir, nact, roff, coff
       double precision scale
       double precision x(nact,nclosed), eri(nbf,nbf), ax(nvir,nact)

       call dgemm( 'n', 't', nvir, nact, nclosed, scale, eri(roff,coff),
     $             nbf, x, nact, 1.d0, ax, nvir )
       
       return
       end










       subroutine mcscf_hack3( nbf, nclosed, nact, g_coul, g_exch,
     $                             g_x, g_ax )
       implicit none
#include "global.fh"
#include "mafdecls.fh"
c
c
       integer nbf
       integer nclosed
       integer nact
       integer g_coul
       integer g_exch
       integer g_x
       integer g_ax
c
c
c

       integer nvir, vlen
       integer l_v, k_v, l_av, k_av, k_j, k_k, ld1, ld2
       integer jlo, jhi, xoff, voff, yoff
       integer v, vv, nn
       logical ga_check_JKblocked
       external ga_check_JKblocked
c
c
       nn = nbf*nbf
       nvir = nbf - nclosed - nact
       vlen = (nclosed+nact)*nvir + nclosed*nact
       voff = nclosed + nact + 1
c
c
c
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_v,k_v))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_av,k_av))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
c
c
c
       xoff = nclosed*nvir + 1
       yoff = (nclosed+nact)*nvir + 1
       call ga_get(g_x,1,vlen,1,1,dbl_mb(k_v),vlen)
       call dfill(vlen,0.d0,dbl_mb(k_av),1)
c
c
c
       if (.not.ga_check_JKblocked(g_coul,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_coul,1,nn,vv,vv,k_j,ld1)
           call mcscf_hack03( nbf, nclosed, nvir, nact, -2.d0,
     $                        dbl_mb(k_v+xoff-1),
     $                        voff, 1, dbl_mb(k_j),
     $                        dbl_mb(k_av+yoff-1))
           call ga_release(g_coul,1,nn,vv,vv)
         endif
       enddo
c
c
c
       if (.not.ga_check_JKblocked(g_exch,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_exch,1,nn,vv,vv,k_k,ld2)
           call mcscf_hack03( nbf, nclosed, nvir, nact, 2.d0,
     $                        dbl_mb(k_v+xoff-1),
     $                        voff, 1, dbl_mb(k_k),
     $                        dbl_mb(k_av+yoff-1))
           call ga_release(g_exch,1,nn,vv,vv)
         endif
       enddo
c
c
c
       call ga_acc(g_ax,1,vlen,1,1,dbl_mb(k_av),vlen,1.d0)
       if (.not.ma_pop_stack(l_av))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
       if (.not.ma_pop_stack(l_v))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
c
c
       return
       end





       subroutine mcscf_hack03( nbf, nclosed, nvir, nact, scale, x,
     $                          roff, coff, eri, ax )
       implicit none
       integer nbf, nclosed, nvir, nact, roff, coff
       double precision scale
       double precision x(nvir,nact), eri(nbf,nbf), ax(nact,nclosed)

       call dgemm( 't', 'n', nact, nclosed, nvir, scale, x, nvir,
     $             eri(roff,coff), nbf, 1.d0, ax, nact )
       
       return
       end







       subroutine mcscf_hack4( nbf, nclosed, nact, g_coul, g_exch,
     $                         g_x, g_ax )
       implicit none
#include "global.fh"
#include "mafdecls.fh"
c
c
       integer nbf
       integer nclosed
       integer nact
       integer g_coul
       integer g_exch
       integer g_x
       integer g_ax
c
c
c

       integer nvir, vlen
       integer l_v, k_v, l_av, k_av, k_j, k_k, ld1, ld2
       integer jlo, jhi, xoff, voff, yoff
       integer v, vv, nn
       logical ga_check_JKblocked
       external ga_check_JKblocked
c
c
       nn = nbf*nbf
       nvir = nbf - nclosed - nact
       vlen = (nclosed+nact)*nvir + nclosed*nact
       voff = nclosed + nact + 1
c
c
c
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_v,k_v))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_av,k_av))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
c
c
c
       xoff = (nclosed+nact)*nvir + 1
       yoff = (nclosed+nact)*nvir + 1
       call ga_get(g_x,1,vlen,1,1,dbl_mb(k_v),vlen)
       call dfill(vlen,0.d0,dbl_mb(k_av),1)
c
c
c
       if (.not.ga_check_JKblocked(g_coul,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_coul,1,nn,vv,vv,k_j,ld1)
           call mcscf_hack04( nbf, nclosed, nvir, nact, 2.d0,
     $                        dbl_mb(k_v+xoff-1),
     $                        1, 1, dbl_mb(k_j),
     $                        dbl_mb(k_av+xoff-1))
           call ga_release(g_coul,1,nn,vv,vv)
         endif
       enddo
c
c
c
       if (.not.ga_check_JKblocked(g_exch,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_exch,1,nn,vv,vv,k_k,ld2)
           call mcscf_hack04( nbf, nclosed, nvir, nact, -2.d0,
     $                        dbl_mb(k_v+xoff-1),
     $                        1, 1, dbl_mb(k_k),
     $                        dbl_mb(k_av+xoff-1))
           call ga_release(g_exch,1,nn,vv,vv)
         endif
       enddo
c
c
c
       call ga_acc(g_ax,1,vlen,1,1,dbl_mb(k_av),vlen,1.d0)
       if (.not.ma_pop_stack(l_av))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
       if (.not.ma_pop_stack(l_v))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
c
c
       return
       end






       subroutine mcscf_hack04( nbf, nclosed, nvir, nact, scale, x,
     $                          roff, coff, eri, ax )
       implicit none
       integer nbf, nclosed, nvir, nact, roff, coff
       double precision scale
       double precision x(nact,nclosed), eri(nbf,nbf), ax(nact,nclosed)

       call dgemm( 'n', 'n', nact, nclosed, nclosed, scale, x, nact,
     $             eri(roff,coff), nbf, 1.d0, ax, nact )
       
       return
       end







       subroutine mcscf_hack22( nbf, nclosed, nact, g_coul, g_exch,
     $                          g_x, g_ax )
       implicit none
#include "global.fh"
#include "mafdecls.fh"
c
c
       integer nbf
       integer nclosed
       integer nact
       integer g_coul
       integer g_exch
       integer g_x
       integer g_ax
c
c
c

       integer nvir, vlen
       integer l_v, k_v, l_av, k_av, k_j, k_k, ld1, ld2
       integer jlo, jhi, xoff, yoff, voff, aend, aoff
       integer v, vv, nn
       logical ga_check_JKblocked
       external ga_check_JKblocked
c
c
       nn = nbf*nbf
       nvir = nbf - nclosed - nact
       vlen = (nclosed+nact)*nvir + nclosed*nact
       voff = nclosed + nact + 1
       aoff = nclosed + 1
       aend = nclosed + nact
c
c
c
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_v,k_v))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_av,k_av))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
c
c
c
       xoff = (nclosed+nact)*nvir + 1
       yoff = nclosed*nvir + 1
       call dfill(vlen,0.d0,dbl_mb(k_v),1)
       call ga_get(g_x,aoff,aend,1,nclosed,dbl_mb(k_v+xoff-1),nact)
       call dfill(vlen,0.d0,dbl_mb(k_av),1)
c
c
c
       if (.not.ga_check_JKblocked(g_coul,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_coul,1,nn,vv,vv,k_j,ld1)
           call mcscf_hack02( nbf, nclosed, nvir, nact, -2.d0,
     $                        dbl_mb(k_v+xoff-1),
     $                        voff, 1, dbl_mb(k_j),
     $                        dbl_mb(k_av+yoff-1))
           call ga_release(g_coul,1,nn,vv,vv)
         endif
       enddo
c
c
c
       if (.not.ga_check_JKblocked(g_exch,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_exch,1,nn,vv,vv,k_k,ld2)
           call mcscf_hack02( nbf, nclosed, nvir, nact, 2.d0,
     $                        dbl_mb(k_v+xoff-1),
     $                        voff, 1, dbl_mb(k_k),
     $                        dbl_mb(k_av+yoff-1))
           call ga_release(g_exch,1,nn,vv,vv)
         endif
       enddo
c
c
c
       call ga_acc(g_ax,voff,nbf,aoff,aend,dbl_mb(k_av+yoff-1),
     $             nvir,1.d0)
       if (.not.ma_pop_stack(l_av))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
       if (.not.ma_pop_stack(l_v))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
c
c
       return
       end






       subroutine mcscf_hack33( nbf, nclosed, nact, g_coul, g_exch,
     $                          g_x, g_ax )
       implicit none
#include "global.fh"
#include "mafdecls.fh"
c
c
       integer nbf
       integer nclosed
       integer nact
       integer g_coul
       integer g_exch
       integer g_x
       integer g_ax
c
c
c

       integer nvir, vlen
       integer l_v, k_v, l_av, k_av, k_j, k_k, ld1, ld2
       integer jlo, jhi, xoff, voff, yoff, aoff, aend
       integer v, vv, nn
       logical ga_check_JKblocked
       external ga_check_JKblocked
c
c
       nn = nbf*nbf
       nvir = nbf - nclosed - nact
       vlen = (nclosed+nact)*nvir + nclosed*nact
       voff = nclosed + nact + 1
       aoff = nclosed + 1
       aend = nclosed + nact
c
c
c
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_v,k_v))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
       if (.not.ma_push_get(MT_DBL,vlen,'xyz',l_av,k_av))
     $      call errquit('mcscf_dbg_hack1: push stack failed',0)
c
c
c
       xoff = nclosed*nvir + 1
       yoff = (nclosed+nact)*nvir + 1
       call dfill(vlen,0.d0,dbl_mb(k_v),1)
       call ga_get(g_x,voff,nbf,aoff,aend,dbl_mb(k_v+xoff-1),nvir)
       call dfill(vlen,0.d0,dbl_mb(k_av),1)
c
c
c
       if (.not.ga_check_JKblocked(g_coul,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_coul,1,nn,vv,vv,k_j,ld1)
           call mcscf_hack03( nbf, nclosed, nvir, nact, -2.d0,
     $                        dbl_mb(k_v+xoff-1),
     $                        voff, 1, dbl_mb(k_j),
     $                        dbl_mb(k_av+yoff-1))
           call ga_release(g_coul,1,nn,vv,vv)
         endif
       enddo
c
c
c
       if (.not.ga_check_JKblocked(g_exch,nact,nbf,jlo,jhi))
     $      call errquit('mcscf_dbg_hack1: wrong distrib.',0)
       do v=1,nact
         vv = (v*(v+1))/2
         if ((vv.ge.jlo).and.(vv.le.jhi)) then
           call ga_access(g_exch,1,nn,vv,vv,k_k,ld2)
           call mcscf_hack03( nbf, nclosed, nvir, nact, 2.d0,
     $                        dbl_mb(k_v+xoff-1),
     $                        voff, 1, dbl_mb(k_k),
     $                        dbl_mb(k_av+yoff-1))
           call ga_release(g_exch,1,nn,vv,vv)
         endif
       enddo
c
c
c
       call ga_acc(g_ax,aoff,aend,1,nclosed,dbl_mb(k_av+yoff-1),
     $             nact,1.d0)
       if (.not.ma_pop_stack(l_av))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
       if (.not.ma_pop_stack(l_v))
     $      call errquit('mcscf_dbg_hack1: cannot pop?',0)
c
c
       return
       end

c
c  This only for debugging MCSCF!
c
c
      subroutine rohf_hxxx( nbf, nclosed, nopen, lshift,
     $                      g_fcv, g_fpv, g_fcp, g_x )
C     $Id$
      implicit none
c
#include "global.fh"
#include "mafdecls.fh"
c     
      integer nbf, nclosed, nopen
      double precision lshift
      integer g_fcv, g_fpv, g_fcp
      integer g_x
c     
c     
c     Scale the vector x by the ROHF 1e-Hessian diagonal
c     
c               x                    x
c                pq                   ia
c     x   =  --------           = ---------    [ closed-virtual ]
c      pq      (1e)                 cv    cv
c             H                   4F  - 4F
c              pq,pq                aa    ii
c     
c               x
c                pa
c         = ---------    [ partial-virtual ]
c             pv    pv
c           2F  - 2F
c             aa   pp
c     
c               x
c                ip
c         = ---------    [ closed-partial ]
c             cp    cp
c           2F  - 2F
c             pp    ii
c     
      integer nvir
      integer i, j, ioff, cbase, obase, vbase
      integer l_fcv, k_fcv
      integer l_fcp, k_fcp
      integer l_fpv, k_fpv
      integer l_x, k_x
      integer vlen
      double precision fcv, fcp, fpv, denominator
      fcv(i) = dbl_mb(k_fcv + i - 1)
      fpv(i) = dbl_mb(k_fpv + i - 1)
      fcp(i) = dbl_mb(k_fcp + i - 1)
c     
      nvir = nbf - nclosed - nopen
      cbase = 0                 ! Offsets into diagonals
      obase = nclosed
      vbase = nclosed + nopen
c     
c     Get diagonals of each matrix
c
      if (.not.ma_push_get(MT_DBL,nbf,'rohf: tmp',l_fcv,k_fcv))
     $     call errquit('rohf_hdiag_scale: cannot allocate',0)
      if (.not.ma_push_get(MT_DBL,nbf,'rohf: tmp',l_x,k_x))
     $     call errquit('rohf_hdiag_scale: cannot allocate',0)
      if (nopen .gt. 0) then
         if (.not.ma_push_get(MT_DBL,nbf,'rohf: tmp',l_fcp,k_fcp))
     $        call errquit('rohf_hdiag_scale: cannot allocate',0)
         if (.not.ma_push_get(MT_DBL,nbf,'rohf: tmp',l_fpv,k_fpv))
     $        call errquit('rohf_hdiag_scale: cannot allocate',0)
      endif
c     
      call ga_get_diagonal(g_fcv, dbl_mb(k_fcv))
      if (nopen .gt. 0) then
         call ga_get_diagonal(g_fcp, dbl_mb(k_fcp))
         call ga_get_diagonal(g_fpv, dbl_mb(k_fpv))
      endif
c
c     Scale closed-virtual piece
c
      do i = ga_nodeid()+1, nclosed, ga_nnodes()
         ioff = (i-1)*nvir + 1
         do j=1,nvir
            denominator = 4.d0*(fcv(j+vbase) - fcv(i+cbase)) + lshift
            dbl_mb(k_x+j-1) = denominator
         enddo
         call ga_put(g_x, ioff, ioff+nvir-1, 1, 1, dbl_mb(k_x),1)
      enddo
c
      if (nopen .gt. 0) then
c     
c     Scale open-virtual piece
c     
         do i = ga_nodeid()+1, nopen, ga_nnodes()
            ioff = (nclosed+i-1)*nvir + 1
            do j=1,nvir
              denominator = 2.d0*(fpv(j+vbase) - fpv(i+obase)) + lshift 
              dbl_mb(k_x+j-1) = denominator
            enddo
            call ga_put(g_x, ioff, ioff+nvir-1, 1, 1, dbl_mb(k_x),1)
         enddo
c     
c     Scale closed-open piece
c     
         do i = ga_nodeid()+1, nclosed, ga_nnodes()
            ioff = (nclosed+nopen)*nvir + (i-1)*nopen + 1
            do j=1,nopen
               denominator = 2.d0*(fcp(j+obase) - fcp(i+cbase)) + lshift
               dbl_mb(k_x+j-1) = denominator
            enddo
            call ga_put(g_x, ioff, ioff+nopen-1, 1, 1, dbl_mb(k_x),1)
         enddo
      endif
c     
      if (nopen .gt. 0) then
         if (.not.ma_pop_stack(l_fpv))
     $        call errquit('rohf_hdiag_scale: cannot pop stack',0)
         if (.not.ma_pop_stack(l_fcp))
     $        call errquit('rohf_hdiag_scale: cannot pop stack',0)
      endif
      if (.not.ma_pop_stack(l_x))
     $     call errquit('rohf_hdiag_scale: cannot pop stack',0)
      if (.not.ma_pop_stack(l_fcv))
     $     call errquit('rohf_hdiag_scale: cannot pop stack',0)
c

c$$$      VLEN = (NCLOSED+NOPEN)*NVIR + NCLOSED*NOPEN
c$$$      IF (.NOT.MA_PUSH_GET(MT_DBL,VLEN,'ROHF: TMP',L_X,K_X))
c$$$     $     CALL ERRQUIT('ROHF_HDIAG_SCALE: CANNOT ALLOCATE',0)
c$$$      DO I=1,VLEN
c$$$        CALL GA_GET(G_X,I,I,1,1,DBL_MB(K_X+I-1),1)
c$$$      ENDDO
c$$$      WRITE(6,900) 
c$$$ 900  FORMAT(/,'--------- ROHF HESSIAN DIAGONAL -----------')
c$$$      WRITE(6,901) (DBL_MB(K_X+I-1),I=1,VLEN)
c$$$ 901  FORMAT(10F12.6)
c$$$      IF (.NOT.MA_POP_STACK(L_X))
c$$$     $     CALL ERRQUIT('ROHF_HDIAG_SCALE: CANNOT POP STACK',0)
c
c
      end

