1      subroutine rohf_k2cf(basis, nbf, nmo, nclosed, nopen,
2     $                     g_kvec, g_vecs, g_result)
3C     $Id$
4      implicit none
5#include "errquit.fh"
6#include "mafdecls.fh"
7#include "global.fh"
8#include "cscfps.fh"
9c
10c     Transform mo-coeffs from k-vector using exp(K)
11c
12c     Arguments
13c
14      integer nbf, basis, nmo, nclosed, nopen
15      integer g_kvec, g_vecs, g_result
16c
17      integer g_temp
18      double precision one, zero
19      parameter (one=1.0d0, zero=0.0d0)
20c
21      if (oscfps) call pstat_on(ps_k2cf)
22c
23      if (.not. ga_create(MT_DBL, nmo, nmo, 'k2cf: temp',
24     $     32, 32, g_temp)) call errquit('rohf_k2cf: GA temp',0, GA_ERR)
25      call rohf_k2u( basis, nbf, nmo, nclosed, nopen,
26     $               g_kvec, g_temp )
27c
28c     Transform MO's
29c
30      call ga_dgemm('n', 'n', nbf, nmo, nmo, one, g_vecs,
31     $               g_temp, zero, g_result)
32c
33      if (.not.ga_destroy(g_temp))
34     $     call errquit('rohf_k2cf: cannot destroy temp',0, GA_ERR)
35c
36*      call ga_orthog_mos(basis, g_result)
37c
38      if (oscfps) call pstat_off(ps_k2cf)
39c
40      end
41      subroutine rohf_k2u( basis, nbf, nmo, nclosed, nopen,
42     $                     g_kvec, g_u )
43      implicit none
44#include "errquit.fh"
45#include "mafdecls.fh"
46#include "global.fh"
47c
48c
49c  Generate U = exp(K)
50c  K is the antisymmetric matrix form of k
51c
52c
53c     Arguments
54c
55      integer nbf, basis, nmo, nclosed, nopen
56      integer g_kvec, g_u
57c
58      integer nvir
59      integer i,l_tmp,k_tmp,iioff,ivoff,nnnodes
60      integer tmp_siz
61      double precision one, mone, zero
62      parameter (one=1.0d0, mone=-1.0d0, zero=0.0d0)
63      double precision kmax
64c
65      call ga_sync()
66      nnnodes = ga_nnodes()
67c
68c     Form K-matrix from vector
69c
70      nvir = nmo - nclosed - nopen
71      ivoff = nclosed + nopen + 1
72      tmp_siz =  max(nvir,nopen)
73c
74c
75      if (.not. ma_push_get(MT_DBL,tmp_siz,'temp k',l_tmp,k_tmp))
76     $     call errquit('k2cf: ma failed on tmp',tmp_siz, MA_ERR)
77c
78      call ga_zero(g_u)
79      if (nvir .gt. 0) then
80         do i=ga_nodeid()+1,nclosed+nopen,nnnodes
81            iioff = (i-1)*nvir
82            call ga_get(g_kvec,iioff+1,iioff+nvir,1,1,
83     $           dbl_mb(k_tmp),nvir)
84            call ga_put(g_u,ivoff,nmo,i,i,dbl_mb(k_tmp),nvir)
85            call dscal(nvir,mone,dbl_mb(k_tmp),1)
86            call ga_put(g_u,i,i,ivoff,nmo,dbl_mb(k_tmp),1)
87         enddo
88      endif
89      if (nopen .gt. 0) then
90         do i=ga_nodeid()+1,nclosed,nnnodes
91            iioff = (nclosed+nopen)*nvir + (i-1)*nopen
92            call ga_get(g_kvec,iioff+1,iioff+nopen,1,1,
93     $           dbl_mb(k_tmp),nopen)
94            call ga_put(g_u,(nclosed+1),(nclosed+nopen),i,i,
95     $           dbl_mb(k_tmp),nopen)
96            call dscal(nopen,mone,dbl_mb(k_tmp),1)
97            call ga_put(g_u,i,i,(nclosed+1),(nclosed+nopen),
98     $           dbl_mb(k_tmp),1)
99         enddo
100      endif
101      if (.not. ma_pop_stack(l_tmp))
102     $     call errquit('k2cf: pop failed', 0, MA_ERR)
103c
104c     Make near zeoes exactly zero so that sparsity tests in the
105c     matrix multiply work well ... we only need to maintain
106c     quadratic convergence.
107c     Cannot screen with a large number (greater than accuracy in integrals)
108c     since in a non-abelian group we could break symmetry ... either
109c     screen with a small threshold or screen with a large one and then
110c     enforce symmetry (which is expensive in high order groups).
111c     Also, screening must tend to zero for high convergence
112c
113      call ga_maxelt(g_u, kmax)
114      kmax = min(kmax*1d-2,kmax*kmax,1d-12)
115      call ga_screen(g_u, kmax)
116c
117c     Get a unitary 2nd order approximation to exp(K)
118c
119      call matrix_exp(g_u )
120      end
121