1 subroutine tce_mo1e(g_ao1e,d_mo1e,k_f1_offset) 2c 3c $Id$ 4c 5c Spin-spatial-symmetry blocked Fock matrix transformations. 6c 7 implicit none 8#include "rtdb.fh" 9#include "global.fh" 10#include "mafdecls.fh" 11#include "stdio.fh" 12#include "util.fh" 13#include "sym.fh" 14#include "sf.fh" 15#include "errquit.fh" 16#include "tce.fh" 17#include "tce_main.fh" 18 integer g_ao1e(2) ! AO Fock matrices 19 integer l_ao1e,k_ao1e ! AO Fock matrices 20 integer l_mo1e,k_mo1e ! MO Fock matrices 21 integer l_work,k_work ! Work space 22 integer sf_size,sf_offset ! SF size and offset 23 integer d_mo1e ! File handle 24 integer spin ! Spin 25 integer g1b,g2b ! Block indexes 26 integer range_g1,range_g2 ! Block ranges 27 integer offset_g1,offset_g2 ! Block offsets 28 integer size_g1g2 29 integer k_f1_offset 30 integer key_g1g2 31 logical nodezero 32 INTEGER NXTASK 33 INTEGER next 34 INTEGER nprocs 35 INTEGER count 36 EXTERNAL NXTASK 37c 38c ===================================== 39c Determine the size of SF and allocate 40c ===================================== 41c 42 nodezero = (ga_nodeid().eq.0) 43ccx sf_size=0 44ccx do g1b = 1,noa+nob+nva+nvb 45ccx do g2b = 1,noa+nob+nva+nvb 46ccx if (int_mb(k_spin+g1b-1) .eq. int_mb(k_spin+g2b-1)) then 47ccx if ((.not.restricted).or.(int_mb(k_spin+g1b-1) 48ccx 1 +int_mb(k_spin+g2b-1).ne.4)) then 49ccx if (ieor(int_mb(k_sym+g1b-1),int_mb(k_sym+g2b-1)) 50ccx 1 .eq. 0) then 51ccx sf_size = sf_size + int_mb(k_range+g1b-1) 52ccx 1 * int_mb(k_range+g2b-1) 53ccx endif 54ccx endif 55ccx endif 56ccx enddo 57ccx enddo 58ccx if (.not.ma_push_get(mt_dbl,sf_size,'MO Fock', 59ccx 1 l_mo1e,k_mo1e)) call errquit('tce_mo1e: MA problem',3,MA_ERR) 60c 61c ============== 62c Transformation 63c ============== 64c 65 nprocs = GA_NNODES() 66 count = 0 67 next = NXTASK(nprocs, 1) 68c 69 sf_offset=0 70 do g2b = 1,noa+nob+nva+nvb 71 do g1b = 1,noa+nob+nva+nvb 72 IF (next.eq.count) THEN 73 if (int_mb(k_spin+g1b-1) .eq. int_mb(k_spin+g2b-1)) then 74 if ((.not.restricted).or.(int_mb(k_spin+g1b-1) 75 1 +int_mb(k_spin+g2b-1).ne.4)) then 76 if (ieor(int_mb(k_sym+g1b-1),int_mb(k_sym+g2b-1)) 77 1 .eq. 0) then 78 spin = int_mb(k_spin+g1b-1) 79 range_g1 = int_mb(k_range+g1b-1) 80 range_g2 = int_mb(k_range+g2b-1) 81 offset_g1 = int_mb(k_offset+g1b-1)*nbf 82 offset_g2 = int_mb(k_offset+g2b-1)*nbf 83 if (.not.ma_push_get(mt_dbl,range_g1*nbf,'Work', 84 1 l_work,k_work)) call errquit('tce_mo1e: MA problem', 85 2 0,MA_ERR) 86 if (.not.ma_push_get(mt_dbl,nbf*nbf,'AO Fock', 87 1 l_ao1e,k_ao1e)) call errquit('tce_mo1e: MA problem', 88 2 1,MA_ERR) 89 call ga_get(g_ao1e(spin),1,nbf,1,nbf,dbl_mb(k_ao1e), 90 1 nbf) 91 call dgemm('T','N',range_g1,nbf,nbf,1.0d0, 92 1 dbl_mb(k_movecs_sorted+offset_g1),nbf, 93 2 dbl_mb(k_ao1e),nbf,0.0d0,dbl_mb(k_work),range_g1) 94 if (.not.ma_pop_stack(l_ao1e)) 95 1 call errquit('tce_mo1e: MA problem',2,MA_ERR) 96c open local file 97 size_g1g2=range_g1*range_g2 98 if (.not.ma_push_get(mt_dbl,size_g1g2,'MO Fock', 99 1 l_mo1e,k_mo1e)) 100 2 call errquit('tce_mo1e: MA problem',3,MA_ERR) 101c zeroing --- 102 call dfill(size_g1g2, 0.0d0, dbl_mb(k_mo1e), 1) 103c 104 call dgemm('N','N',range_g1,range_g2,nbf,1.0d0, 105 1 dbl_mb(k_work),range_g1, 106 2 dbl_mb(k_movecs_sorted+offset_g2),nbf, 107 3 0.0d0,dbl_mb(k_mo1e),range_g1) 108c finding offset 109 key_g1g2=g1b - 1 + (noab+nvab) * (g2b - 1) 110 call put_hash_block(d_mo1e,dbl_mb(k_mo1e),size_g1g2, 111 1 int_mb(k_f1_offset),key_g1g2) 112c close local file 113 if (.not.ma_pop_stack(l_mo1e)) 114 1 call errquit('tce_mo1e: MA problem',6,MA_ERR) 115c 116ccx if (nodezero.and.util_print('mo1e',print_debug)) 117ccx 1 call ma_print(dbl_mb(k_mo1e+sf_offset), 118ccx 2 range_g1,range_g2,'Spin symmetry block of Fock') 119 if (.not.ma_pop_stack(l_work)) 120 1 call errquit('tce_mo1e: MA problem',5,MA_ERR) 121ccx sf_offset = sf_offset + range_g1 * range_g2 122 endif 123 endif 124 endif 125 next = NXTASK(nprocs, 1) 126 END IF 127 count = count + 1 128 enddo 129 enddo 130 next = NXTASK(-nprocs, 1) 131 call GA_SYNC() 132c 133c =========== 134c Write to SF 135c =========== 136c 137ccx call put_block(d_mo1e,dbl_mb(k_mo1e),sf_size,0) 138c 139c =================== 140c Close SF and return 141c =================== 142c 143ccx if (nodezero.and.util_print('mo1e',print_debug)) then 144ccx call sf_print(d_mo1e,sf_size) 145ccx endif 146ccx if (.not.ma_pop_stack(l_mo1e)) 147ccx 1 call errquit('tce_mo1e: MA problem',6,MA_ERR) 148 if (.not.ga_destroy(g_ao1e(1))) 149 1 call errquit('tce_mo1e: GA problem',2,GA_ERR) 150 if (.not.ga_destroy(g_ao1e(2))) 151 1 call errquit('tce_mo1e: GA problem',3,GA_ERR) 152 return 153 end 154 155 156 157 subroutine tce_mo1e_epsilon(d_mo1e) 158c 159c Spin-spatial-symmetry blocked Fock matrix formation from epsilons. 160c 161 implicit none 162#include "rtdb.fh" 163#include "global.fh" 164#include "mafdecls.fh" 165#include "stdio.fh" 166#include "util.fh" 167#include "sym.fh" 168#include "sf.fh" 169#include "errquit.fh" 170#include "tce.fh" 171#include "tce_main.fh" 172 integer l_mo1e,k_mo1e ! MO Fock matrices 173 integer sf_size,sf_offset ! SF size and offset 174 integer d_mo1e ! File handle 175 integer spin ! Spin 176 integer g1b,g2b ! Block indexes 177 integer range_g1,range_g2 ! Block ranges 178 integer g1,g2 179 logical nodezero 180c 181c ===================================== 182c Determine the size of SF and allocate 183c ===================================== 184c 185 nodezero = (ga_nodeid().eq.0) 186 sf_size=0 187 do g1b = 1,noa+nob+nva+nvb 188 do g2b = 1,noa+nob+nva+nvb 189 if (int_mb(k_spin+g1b-1) .eq. int_mb(k_spin+g2b-1)) then 190 if ((.not.restricted).or.(int_mb(k_spin+g1b-1) 191 1 +int_mb(k_spin+g2b-1).ne.4)) then 192 if (ieor(int_mb(k_sym+g1b-1),int_mb(k_sym+g2b-1)) 193 1 .eq. 0) then 194 sf_size = sf_size + int_mb(k_range+g1b-1) 195 1 * int_mb(k_range+g2b-1) 196 endif 197 endif 198 endif 199 enddo 200 enddo 201 if (.not.ma_push_get(mt_dbl,sf_size,'MO Fock', 202 1 l_mo1e,k_mo1e)) call errquit('tce_mo1e: MA problem',3,MA_ERR) 203c 204c ============== 205c Transformation 206c ============== 207c 208 sf_offset=0 209 do g2b = 1,noa+nob+nva+nvb 210 do g1b = 1,noa+nob+nva+nvb 211 if (int_mb(k_spin+g1b-1) .eq. int_mb(k_spin+g2b-1)) then 212 if ((.not.restricted).or.(int_mb(k_spin+g1b-1) 213 1 +int_mb(k_spin+g2b-1).ne.4)) then 214 if (ieor(int_mb(k_sym+g1b-1),int_mb(k_sym+g2b-1)) 215 1 .eq. 0) then 216 spin = int_mb(k_spin+g1b-1) 217 range_g1 = int_mb(k_range+g1b-1) 218 range_g2 = int_mb(k_range+g2b-1) 219 do g2 = 1, range_g2 220 do g1 = 1, range_g1 221 if ((g1b.eq.g2b).and.(g1.eq.g2)) then 222 dbl_mb(k_mo1e+sf_offset+(g2-1)*range_g1+g1-1)= 223 1 dbl_mb(k_evl_sorted+int_mb(k_offset+g1b-1)+g1-1) 224 else 225 dbl_mb(k_mo1e+sf_offset+(g2-1)*range_g1+g1-1)=0.0d0 226 endif 227 enddo 228 enddo 229 if (nodezero.and.util_print('mo1e',print_debug)) 230 1 call ma_print(dbl_mb(k_mo1e+sf_offset), 231 2 range_g1,range_g2,'Spin symmetry block of Fock') 232 sf_offset = sf_offset + range_g1 * range_g2 233 endif 234 endif 235 endif 236 enddo 237 enddo 238c 239c =========== 240c Write to SF 241c =========== 242c 243 call put_block(d_mo1e,dbl_mb(k_mo1e),sf_size,0) 244c 245c =================== 246c Close SF and return 247c =================== 248c 249 if (nodezero.and.util_print('mo1e',print_debug)) then 250 call sf_print(d_mo1e,sf_size) 251 endif 252 if (.not.ma_pop_stack(l_mo1e)) 253 1 call errquit('tce_mo1e: MA problem',6,MA_ERR) 254 return 255 end 256