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