1 subroutine tce_jacobi_lr4(d_r4,d_l4,k_l4_offset,omega,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#include "tce_diis.fh" 15 integer d_r4 16 integer d_l4 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_l4_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 46 nodezero = (ga_nodeid().eq.0) 47 noloadbalance = ((ioalg.eq.4).or. 48 1 ((ioalg.eq.6).and.(.not.fileisga(d_l4)))) 49 nprocs = ga_nnodes() 50 count = 0 51 next = nxtask(nprocs,1) 52 do h5b = 1,noab 53 do h6b = h5b,noab 54 do h7b = h6b,noab 55 do h8b = h7b,noab 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 if (noloadbalance.or.(next.eq.count)) then 61 if (int_mb(k_spin+p1b-1) 62 1 +int_mb(k_spin+p2b-1) 63 2 +int_mb(k_spin+p3b-1) 64 3 +int_mb(k_spin+p4b-1) 65 4 .eq.int_mb(k_spin+h5b-1) 66 5 +int_mb(k_spin+h6b-1) 67 6 +int_mb(k_spin+h7b-1) 68 7 +int_mb(k_spin+h8b-1)) then 69 if ((.not.restricted).or. 70 1 (int_mb(k_spin+p1b-1) 71 2 +int_mb(k_spin+p2b-1) 72 3 +int_mb(k_spin+p3b-1) 73 4 +int_mb(k_spin+p4b-1) 74 5 +int_mb(k_spin+h5b-1) 75 6 +int_mb(k_spin+h6b-1) 76 7 +int_mb(k_spin+h7b-1) 77 8 +int_mb(k_spin+h8b-1).ne.16)) then 78 if (ieor(int_mb(k_sym+p1b-1), 79 1 ieor(int_mb(k_sym+p2b-1), 80 2 ieor(int_mb(k_sym+p3b-1), 81 3 ieor(int_mb(k_sym+p4b-1), 82 4 ieor(int_mb(k_sym+h5b-1), 83 5 ieor(int_mb(k_sym+h6b-1), 84 6 ieor(int_mb(k_sym+h7b-1), 85 7 int_mb(k_sym+h8b-1)))))))) .eq. irrep_y) then 86 size = int_mb(k_range+p1b-1) 87 1 * int_mb(k_range+p2b-1) 88 2 * int_mb(k_range+p3b-1) 89 3 * int_mb(k_range+p4b-1) 90 4 * int_mb(k_range+h5b-1) 91 5 * int_mb(k_range+h6b-1) 92 6 * int_mb(k_range+h7b-1) 93 7 * int_mb(k_range+h8b-1) 94 if (.not.ma_push_get(mt_dbl,size,'r4', 95 1 l_r4,k_r4)) 96 2 call errquit('tce_jacobi_lr4: MA problem',0, 97 3 MA_ERR) 98 call get_hash_block(d_r4,dbl_mb(k_r4),size, 99 1 int_mb(k_l4_offset),((((((((h5b-1)*noab 100 2 +h6b-1)*noab+h7b-1)*noab+h8b-1)*nvab 101 3 +p1b-noab-1)*nvab+p2b-noab-1)*nvab 102 4 +p3b-noab-1)*nvab+p4b-noab-1)) 103 i = 0 104 do h5 = 1,int_mb(k_range+h5b-1) 105 do h6 = 1,int_mb(k_range+h6b-1) 106 do h7 = 1,int_mb(k_range+h7b-1) 107 do h8 = 1,int_mb(k_range+h8b-1) 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 i = i + 1 113 dbl_mb(k_r4+i-1) = dbl_mb(k_r4+i-1) 114 1 /((-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1) 115 2 -dbl_mb(k_evl_sorted+int_mb(k_offset+p2b-1)+p2-1) 116 3 -dbl_mb(k_evl_sorted+int_mb(k_offset+p3b-1)+p3-1) 117 4 -dbl_mb(k_evl_sorted+int_mb(k_offset+p4b-1)+p4-1) 118 5 +dbl_mb(k_evl_sorted+int_mb(k_offset+h5b-1)+h5-1) 119 6 +dbl_mb(k_evl_sorted+int_mb(k_offset+h6b-1)+h6-1) 120 7 +dbl_mb(k_evl_sorted+int_mb(k_offset+h7b-1)+h7-1) 121 8 +dbl_mb(k_evl_sorted+int_mb(k_offset+h8b-1)+h8-1)) 122 3 -omega) 123 enddo 124 enddo 125 enddo 126 enddo 127 enddo 128 enddo 129 enddo 130 enddo 131 call add_hash_block(d_l4,dbl_mb(k_r4),size, 132 1 int_mb(k_l4_offset),((((((((h5b-1)*noab 133 2 +h6b-1)*noab+h7b-1)*noab+h8b-1)*nvab 134 3 +p1b-noab-1)*nvab+p2b-noab-1)*nvab 135 4 +p3b-noab-1)*nvab+p4b-noab-1)) 136 if (.not.ma_pop_stack(l_r4)) 137 1 call errquit('tce_jacobi_lr4: MA problem',1, 138 2 MA_ERR) 139 endif 140 endif 141 endif 142 next = nxtask(nprocs,1) 143 endif 144 count = count + 1 145 enddo 146 enddo 147 enddo 148 enddo 149 enddo 150 enddo 151 enddo 152 enddo 153 next = nxtask(-nprocs,1) 154 call ga_sync() 155 return 156 end 157