1 subroutine tce_jacobi_ir1(d_r1,d_t1,k_t1_offset,omega, 2 1 shift,damping) 3c 4c $Id$ 5c 6 implicit none 7#include "global.fh" 8#include "mafdecls.fh" 9#include "sym.fh" 10#include "util.fh" 11#include "stdio.fh" 12#include "errquit.fh" 13#include "tce.fh" 14#include "tce_main.fh" 15#include "tce_diis.fh" 16 integer d_r1 17 integer d_t1 18 integer p1b 19 integer h2b 20 integer p1 21 integer h2 22 integer k_t1_offset 23 integer size 24 integer l_r1,k_r1 25 integer i 26 integer nprocs 27 integer count 28 integer next 29 integer nxtask 30 external nxtask 31 logical noloadbalance 32 logical nodezero ! True if node 0 33 double precision shift,omega,damping 34 double precision denom 35c 36c ================ 37c Loop over blocks 38c ================ 39c 40 nodezero = (ga_nodeid().eq.0) 41 noloadbalance = ((ioalg.eq.4).or. 42 1 ((ioalg.eq.6).and.(.not.fileisga(d_r1)))) 43 nprocs = ga_nnodes() 44 count = 0 45 next = nxtask(nprocs,1) 46 do p1b = noab+1,noab+nvab 47 do h2b = 1,noab 48 if (noloadbalance.or.(next.eq.count)) then 49 if (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) then 50 if ((.not.restricted).or.(int_mb(k_spin+p1b-1) 51 1 +int_mb(k_spin+h2b-1).ne.4)) then 52 if (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)).eq. 53 & irrep_x) then 54 size = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1) 55 if (.not.ma_push_get(mt_dbl,size,'rr1',l_r1,k_r1)) 56 1 call errquit('tce_jacobi_ir1: MA problem',0,MA_ERR) 57 call get_hash_block(d_r1,dbl_mb(k_r1),size, 58 1 int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1)) 59 i = 0 60 do p1 = 1,int_mb(k_range+p1b-1) 61 do h2 = 1,int_mb(k_range+h2b-1) 62 i = i + 1 63 denom = ( 64 1 -dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1) 65 2 +dbl_mb(k_evl_sorted+int_mb(k_offset+h2b-1)+h2-1) 66 3 ) 67 dbl_mb(k_r1+i-1) = damping*dbl_mb(k_r1+i-1) 68 1 / ( shift + denom - omega ) 69 enddo 70 enddo 71 call add_hash_block(d_t1,dbl_mb(k_r1),size, 72 1 int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1)) 73 if (nodezero.and.util_print('tr1',print_debug)) then 74 call get_hash_block(d_t1,dbl_mb(k_r1),size, 75 1 int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1)) 76 call ma_print_compact(dbl_mb(k_r1),size,1,'tr1') 77 endif 78 if (.not.ma_pop_stack(l_r1)) 79 1 call errquit('tce_jacobi_ir1: MA problem',1,MA_ERR) 80 endif 81 endif 82 endif 83 next = nxtask(nprocs,1) 84 endif 85 count = count + 1 86 enddo 87 enddo 88 next = nxtask(-nprocs,1) 89 call ga_sync() 90 return 91 end 92