1 subroutine tce_jacobi_tr4(d_r4,d_t4,k_t4_offset,omega) 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#include "tce_diis.fh" 15 integer d_r4 16 integer d_t4 17 integer p1b 18 integer p2b 19 integer p3b 20 integer p4b 21 integer h5b 22 integer h6b 23 integer h7b 24 integer h8b 25 integer p1 26 integer p2 27 integer p3 28 integer p4 29 integer h5 30 integer h6 31 integer h7 32 integer h8 33 integer k_t4_offset 34 integer size 35 integer l_r4,k_r4 36 integer i 37 integer nprocs 38 integer count 39 integer next 40 integer nxtask 41 external nxtask 42 logical noloadbalance 43 logical nodezero ! True if node 0 44 double precision omega,shift 45c 46c ================ 47c Loop over blocks 48c ================ 49c 50 nodezero = (ga_nodeid().eq.0) 51 noloadbalance = ((ioalg.eq.4).or. 52 1 ((ioalg.eq.6).and.(.not.fileisga(d_r4)))) 53 nprocs = ga_nnodes() 54 count = 0 55 next = nxtask(nprocs,1) 56 do p1b = noab+1,noab+nvab 57 do p2b = p1b,noab+nvab 58 do p3b = p2b,noab+nvab 59 do p4b = p3b,noab+nvab 60 do h5b = 1,noab 61 do h6b = h5b,noab 62 do h7b = h6b,noab 63 do h8b = h7b,noab 64 if (noloadbalance.or.(next.eq.count)) then 65 if (int_mb(k_spin+p1b-1) 66 1 +int_mb(k_spin+p2b-1) 67 2 +int_mb(k_spin+p3b-1) 68 3 +int_mb(k_spin+p4b-1) 69 4 .eq.int_mb(k_spin+h5b-1) 70 5 +int_mb(k_spin+h6b-1) 71 6 +int_mb(k_spin+h7b-1) 72 7 +int_mb(k_spin+h8b-1)) then 73 if ((.not.restricted).or. 74 1 (int_mb(k_spin+p1b-1) 75 2 +int_mb(k_spin+p2b-1) 76 3 +int_mb(k_spin+p3b-1) 77 4 +int_mb(k_spin+p4b-1) 78 5 +int_mb(k_spin+h5b-1) 79 6 +int_mb(k_spin+h6b-1) 80 7 +int_mb(k_spin+h7b-1) 81 8 +int_mb(k_spin+h8b-1).ne.16)) then 82 if (ieor(int_mb(k_sym+p1b-1), 83 1 ieor(int_mb(k_sym+p2b-1), 84 2 ieor(int_mb(k_sym+p3b-1), 85 3 ieor(int_mb(k_sym+p4b-1), 86 4 ieor(int_mb(k_sym+h5b-1), 87 5 ieor(int_mb(k_sym+h6b-1), 88 6 ieor(int_mb(k_sym+h7b-1), 89 7 int_mb(k_sym+h8b-1)))))))) .eq. irrep_x) then 90 size = int_mb(k_range+p1b-1) 91 1 * int_mb(k_range+p2b-1) 92 2 * int_mb(k_range+p3b-1) 93 3 * int_mb(k_range+p4b-1) 94 4 * int_mb(k_range+h5b-1) 95 5 * int_mb(k_range+h6b-1) 96 6 * int_mb(k_range+h7b-1) 97 7 * int_mb(k_range+h8b-1) 98 if (.not.ma_push_get(mt_dbl,size,'rr4', 99 1 l_r4,k_r4)) 100 2 call errquit('tce_jacobi_tr4: MA problem',0, 101 3 MA_ERR) 102 call get_hash_block(d_r4,dbl_mb(k_r4),size, 103 1 int_mb(k_t4_offset),((((((((p1b-noab-1)*nvab 104 2 +p2b-noab-1)*nvab+p3b-noab-1)*nvab 105 3 +p4b-noab-1)*noab+h5b-1)*noab 106 4 +h6b-1)*noab+h7b-1)*noab+h8b-1)) 107 i = 0 108 do p1 = 1,int_mb(k_range+p1b-1) 109 do p2 = 1,int_mb(k_range+p2b-1) 110 do p3 = 1,int_mb(k_range+p3b-1) 111 do p4 = 1,int_mb(k_range+p4b-1) 112 do h5 = 1,int_mb(k_range+h5b-1) 113 do h6 = 1,int_mb(k_range+h6b-1) 114 do h7 = 1,int_mb(k_range+h7b-1) 115 do h8 = 1,int_mb(k_range+h8b-1) 116 i = i + 1 117 dbl_mb(k_r4+i-1) = dbl_mb(k_r4+i-1) 118 1 /((-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1) 119 2 -dbl_mb(k_evl_sorted+int_mb(k_offset+p2b-1)+p2-1) 120 3 -dbl_mb(k_evl_sorted+int_mb(k_offset+p3b-1)+p3-1) 121 4 -dbl_mb(k_evl_sorted+int_mb(k_offset+p4b-1)+p4-1) 122 5 +dbl_mb(k_evl_sorted+int_mb(k_offset+h5b-1)+h5-1) 123 6 +dbl_mb(k_evl_sorted+int_mb(k_offset+h6b-1)+h6-1) 124 7 +dbl_mb(k_evl_sorted+int_mb(k_offset+h7b-1)+h7-1) 125 8 +dbl_mb(k_evl_sorted+int_mb(k_offset+h8b-1)+h8-1)) 126 9 -omega) 127 enddo 128 enddo 129 enddo 130 enddo 131 enddo 132 enddo 133 enddo 134 enddo 135 call add_hash_block(d_t4,dbl_mb(k_r4),size, 136 1 int_mb(k_t4_offset),((((((((p1b-noab-1)*nvab 137 2 +p2b-noab-1)*nvab+p3b-noab-1)*nvab 138 3 +p4b-noab-1)*noab+h5b-1)*noab 139 4 +h6b-1)*noab+h7b-1)*noab+h8b-1)) 140 if (nodezero.and.util_print('tr4',print_debug)) 141 1 then 142 call get_hash_block(d_t4,dbl_mb(k_r4),size, 143 1 int_mb(k_t4_offset),((((((((p1b-noab-1)*nvab 144 2 +p2b-noab-1)*nvab+p3b-noab-1)*nvab 145 3 +p4b-noab-1)*noab+h5b-1)*noab 146 4 +h6b-1)*noab+h7b-1)*noab+h8b-1)) 147 call ma_print_compact 148 1 (dbl_mb(k_r4),size,1,'tr4') 149 endif 150 if (.not.ma_pop_stack(l_r4)) 151 1 call errquit('tce_jacobi_tr4: MA problem',1, 152 2 MA_ERR) 153 endif 154 endif 155 endif 156 next = nxtask(nprocs,1) 157 endif 158 count = count + 1 159 enddo 160 enddo 161 enddo 162 enddo 163 enddo 164 enddo 165 enddo 166 enddo 167 next = nxtask(-nprocs,1) 168 call ga_sync() 169 return 170 end 171