1 subroutine tce_jacobi_t1(d_r1,d_t1,k_t1_offset,shift) 2c 3c $Id$ 4c 5 implicit none 6#include "global.fh" 7#include "mafdecls.fh" 8#include "sym.fh" 9#include "util.fh" 10#include "stdio.fh" 11#include "errquit.fh" 12#include "tce.fh" 13#include "tce_main.fh" 14 integer d_r1 15 integer d_t1 16 integer p1b 17 integer h2b 18 integer p1 19 integer h2 20 integer k_t1_offset 21 integer size 22 integer l_r1,k_r1 23 integer i 24 integer nprocs 25 integer count 26 integer next 27 integer iter 28 INTEGER NXTASK 29 EXTERNAL NXTASK 30 logical nodezero 31 logical noloadbalance 32 double precision shift 33c 34c if(iter.le.100) then 35c shift=-zlshift 36c else 37c shift=0.0d0 38c end if 39c 40c ================ 41c Loop over blocks 42c ================ 43c 44 nodezero = (ga_nodeid().eq.0) 45 noloadbalance = ((ioalg.eq.4).or. 46 1 ((ioalg.eq.6).and.(.not.fileisga(d_r1)))) 47 nprocs = ga_nnodes() 48 count = 0 49cc next = nxtask(nprocs,1) 50 next = NXTASK(nprocs, 1) 51 do p1b = noab+1,noab+nvab 52 do h2b = 1,noab 53 if (noloadbalance.or.(next.eq.count)) then 54 if (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) then 55 if ((.not.restricted).or.(int_mb(k_spin+p1b-1) 56 1 +int_mb(k_spin+h2b-1).ne.4)) then 57 if (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)).eq.0) then 58 size = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1) 59 if (.not.ma_push_get(mt_dbl,size,'r1',l_r1,k_r1)) 60 1 call errquit('tce_jacobi_t1: MA problem',0,MA_ERR) 61 call get_hash_block(d_r1,dbl_mb(k_r1),size, 62 1 int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1)) 63 i = 0 64 do p1 = 1,int_mb(k_range+p1b-1) 65 do h2 = 1,int_mb(k_range+h2b-1) 66 i = i + 1 67 dbl_mb(k_r1+i-1) = dbl_mb(k_r1+i-1) 68 1 / (-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1) 69 2 +dbl_mb(k_evl_sorted+int_mb(k_offset+h2b-1)+h2-1) 70 3 +shift) 71 enddo 72 enddo 73 call add_hash_block(d_t1,dbl_mb(k_r1),size, 74 1 int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1)) 75c update of the res.-single vector to the form of increment used in DIIS proc. 76ccx call put_hash_block(d_r1,dbl_mb(k_r1),size, 77ccx 1 int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1)) 78cc 79 if (nodezero.and.util_print('t1',print_debug)) then 80 call get_hash_block(d_t1,dbl_mb(k_r1),size, 81 1 int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1)) 82 call ma_print_compact(dbl_mb(k_r1),size,1,'t1') 83 endif 84 if (.not.ma_pop_stack(l_r1)) 85 1 call errquit('tce_jacobi_t1: MA problem',1,MA_ERR) 86 endif 87 endif 88 endif 89cc next = nxtask(nprocs,1) 90 next = NXTASK(nprocs, 1) 91 endif 92 count = count + 1 93 enddo 94 enddo 95cc next = nxtask(-nprocs,1) 96 next = NXTASK(-nprocs, 1) 97 call ga_sync() 98 return 99 end 100c 101c 102c 103 subroutine tce_r1_divide(d_r1,k_t1_offset) 104c 105c $Id$ 106c 107 implicit none 108#include "global.fh" 109#include "mafdecls.fh" 110#include "sym.fh" 111#include "util.fh" 112#include "stdio.fh" 113#include "errquit.fh" 114#include "tce.fh" 115#include "tce_main.fh" 116 integer d_r1 117 integer p1b 118 integer h2b 119 integer p1 120 integer h2 121 integer k_t1_offset 122 integer size 123 integer l_r1,k_r1 124 integer i 125 integer nprocs 126 integer count 127 integer next 128cc integer nxtask 129cc external nxtask 130 INTEGER NXTASK 131 EXTERNAL NXTASK 132 logical nodezero 133 logical noloadbalance 134c 135c ================ 136c Loop over blocks 137c ================ 138c 139 nodezero = (ga_nodeid().eq.0) 140 noloadbalance = ((ioalg.eq.4).or. 141 1 ((ioalg.eq.6).and.(.not.fileisga(d_r1)))) 142 nprocs = ga_nnodes() 143 count = 0 144cc next = nxtask(nprocs,1) 145 next = NXTASK(nprocs, 1) 146 do p1b = noab+1,noab+nvab 147 do h2b = 1,noab 148 if (noloadbalance.or.(next.eq.count)) then 149 if (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) then 150 if ((.not.restricted).or.(int_mb(k_spin+p1b-1) 151 1 +int_mb(k_spin+h2b-1).ne.4)) then 152 if (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)).eq.0) then 153 size = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1) 154 if (.not.ma_push_get(mt_dbl,size,'r1',l_r1,k_r1)) 155 1 call errquit('tce_r1_divide: MA problem',0,MA_ERR) 156 call get_hash_block(d_r1,dbl_mb(k_r1),size, 157 1 int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1)) 158 i = 0 159 do p1 = 1,int_mb(k_range+p1b-1) 160 do h2 = 1,int_mb(k_range+h2b-1) 161 i = i + 1 162 dbl_mb(k_r1+i-1) = dbl_mb(k_r1+i-1) 163 1 / (-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1) 164 2 +dbl_mb(k_evl_sorted+int_mb(k_offset+h2b-1)+h2-1)) 165 enddo 166 enddo 167c update of the res.-single vector to the form of increment used in DIIS proc. 168 call put_hash_block(d_r1,dbl_mb(k_r1),size, 169 1 int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1)) 170cc 171 if (.not.ma_pop_stack(l_r1)) 172 1 call errquit('tce_r1_divide: MA problem',1,MA_ERR) 173 endif 174 endif 175 endif 176cc next = nxtask(nprocs,1) 177 next = NXTASK(nprocs, 1) 178 endif 179 count = count + 1 180 enddo 181 enddo 182cc next = nxtask(-nprocs,1) 183 next = NXTASK(-nprocs, 1) 184 call ga_sync() 185 return 186 end 187 188