1 SUBROUTINE cr_ccsd_t(d_t1,k_t1_offset,d_t2,k_t2_offset, 2 1 d_f1,k_f1_offset,d_v2,k_v2_offset, 3 2 d_e,k_e_offset,energy1,energy2,size_t1) 4C 5C $Id$ 6C 7 IMPLICIT NONE 8#include "global.fh" 9#include "mafdecls.fh" 10#include "util.fh" 11#include "errquit.fh" 12#include "tce.fh" 13#include "tce_main.fh" 14 integer d_t1 15 integer k_t1_offset 16 integer d_t2 17 integer k_t2_offset 18 integer d_f1 19 integer k_f1_offset 20 integer d_v2 21 integer k_v2_offset 22 integer d_e 23 integer k_e_offset 24 integer t_h1b, t_h1 25 integer t_h2b, t_h2 26 integer t_h3b, t_h3 27 integer t_p4b, t_p4 28 integer t_p5b, t_p5 29 integer t_p6b, t_p6 30 integer k_singles,l_singles 31 integer k_doubles,l_doubles 32 integer k_den,l_den 33 integer k_right,l_right 34 integer size,i 35 integer g_energy 36 integer nxtask 37 integer next 38 integer nprocs 39 integer count 40 integer d_i1_1,d_i1_2,d_i1_3 41 integer k_i1_offset_1,l_i1_offset_1 42 integer k_i1_offset_2,l_i1_offset_2 43 integer k_i1_offset_3,l_i1_offset_3 44c - T1/X1 LOCALIZATION ------------------- 45 integer l_t1_local,k_t1_local 46 integer size_t1 47c --------------------------------------- 48 double precision energy1,energy2 49 double precision factor 50 double precision den0,den1,den2,num1,num2 51 external nxtask 52c 53c - T1/X1 LOCALIZATION ---------- 54c opening l_t1_local and l_x1_local 55 if (.not.MA_PUSH_GET(mt_dbl,size_t1,'t1_local', 56 1 l_t1_local,k_t1_local)) 57 1 call errquit('t1_local',1,MA_ERR) 58 call ma_zero(dbl_mb(k_t1_local),size_t1) 59c copy d_t1 ==> l_t1_local 60cc call ga_get(d_t1,1,size_t1,1,1,dbl_mb(k_t1_local),1) 61 call get_block(d_t1,dbl_mb(k_t1_local),size_t1,0) 62c ------------------------------- 63c 64c Get singles & doubles part of the denominator 65c (here t1 - on GA !) 66 call cr_ccsd_t_D(d_t1,d_t2,d_e,d_t1,d_t2,k_t1_offset, 67 1 k_t2_offset,k_e_offset,k_t1_offset,k_t2_offset) 68 call reconcilefile(d_e,1) 69 call get_block(d_e,den0,1,0) 70 den1 = 0.0d0 71 den2 = 0.0d0 72c 73c Caution! k_right & k_den are not even allocated yet 74c but they won't be used. 75c 76 call cr_ccsd_t_N(dbl_mb(k_right),d_f1,d_i1_1,d_i1_2, 77 1 k_t1_local,d_t2,d_v2,k_f1_offset,k_i1_offset_1,k_i1_offset_2, 78 2 k_t1_offset,k_t2_offset,k_v2_offset,l_i1_offset_1, 79 3 l_i1_offset_2,t_h1b,t_h2b,t_h3b,t_p4b,t_p5b,t_p6b,1) 80 call cr_ccsd_t_E(dbl_mb(k_den),d_i1_3, 81 1 k_t1_local,d_t2,k_i1_offset_3,k_t1_offset,k_t2_offset, 82 2 l_i1_offset_3,t_h1b,t_h2b,t_h3b,t_p4b,t_p5b,t_p6b,1) 83c 84c Get the numerator 85c 86 if (.not.ga_create(mt_dbl,1,1,'perturbative',1,1,g_energy)) 87 1 call errquit('ccsd_t: GA problem',0,GA_ERR) 88 nprocs = GA_NNODES() 89 count = 0 90 next = nxtask(nprocs,1) 91 num1=0.0d0 92 num2=0.0d0 93 do t_p4b = noab+1,noab+nvab 94 do t_p5b = t_p4b,noab+nvab 95 do t_p6b = t_p5b,noab+nvab 96 do t_h1b = 1,noab 97 do t_h2b = t_h1b,noab 98 do t_h3b = t_h2b,noab 99 if (next.eq.count) then 100 if (int_mb(k_spin+t_p4b-1) 101 1 +int_mb(k_spin+t_p5b-1) 102 2 +int_mb(k_spin+t_p6b-1) 103 3 .eq.int_mb(k_spin+t_h1b-1) 104 4 +int_mb(k_spin+t_h2b-1) 105 5 +int_mb(k_spin+t_h3b-1)) then 106 if ((.not.restricted).or. 107 1 (int_mb(k_spin+t_p4b-1) 108 1 +int_mb(k_spin+t_p5b-1) 109 2 +int_mb(k_spin+t_p6b-1) 110 3 +int_mb(k_spin+t_h1b-1) 111 4 +int_mb(k_spin+t_h2b-1) 112 5 +int_mb(k_spin+t_h3b-1).le.8)) then 113 if (ieor(int_mb(k_sym+t_p4b-1), 114 1 ieor(int_mb(k_sym+t_p5b-1), 115 2 ieor(int_mb(k_sym+t_p6b-1), 116 3 ieor(int_mb(k_sym+t_h1b-1), 117 4 ieor(int_mb(k_sym+t_h2b-1), 118 5 int_mb(k_sym+t_h3b-1)))))).eq.0) then 119 size = int_mb(k_range+t_p4b-1) 120 1 * int_mb(k_range+t_p5b-1) 121 2 * int_mb(k_range+t_p6b-1) 122 3 * int_mb(k_range+t_h1b-1) 123 4 * int_mb(k_range+t_h2b-1) 124 5 * int_mb(k_range+t_h3b-1) 125 if (.not.MA_PUSH_GET(mt_dbl,size,'(T) singles', 126 1 l_singles,k_singles)) call errquit('ccsd_t',1,MA_ERR) 127 if (.not.MA_PUSH_GET(mt_dbl,size,'(T) doubles', 128 1 l_doubles,k_doubles)) call errquit('ccsd_t',2,MA_ERR) 129 if (.not.MA_PUSH_GET(mt_dbl,size,'moment 2,3', 130 1 l_right,k_right)) call errquit('ccsd_t',3,MA_ERR) 131 if (.not.MA_PUSH_GET(mt_dbl,size,'denominator', 132 1 l_den,k_den)) call errquit('ccsd_t',3,MA_ERR) 133 do i = 1, size 134 dbl_mb(k_singles+i-1) = 0.0d0 135 dbl_mb(k_doubles+i-1) = 0.0d0 136 dbl_mb(k_right+i-1) = 0.0d0 137 dbl_mb(k_den+i-1) = 0.0d0 138 enddo 139 call ccsd_t_singles_l(dbl_mb(k_singles),k_t1_local, 140 1 d_v2,k_t1_offset, 141 1 k_v2_offset,t_h1b,t_h2b,t_h3b,t_p4b,t_p5b,t_p6b,2) 142 call ccsd_t_doubles_l(dbl_mb(k_doubles), 143 1 d_t2,d_v2,k_t2_offset, 144 1 k_v2_offset,t_h1b,t_h2b,t_h3b,t_p4b,t_p5b,t_p6b,2) 145 call cr_ccsd_t_N(dbl_mb(k_right),d_f1,d_i1_1,d_i1_2, 146 1 k_t1_local,d_t2,d_v2,k_f1_offset, 147 1 k_i1_offset_1,k_i1_offset_2, 148 2 k_t1_offset,k_t2_offset,k_v2_offset,l_i1_offset_1, 149 3 l_i1_offset_2,t_h1b,t_h2b,t_h3b,t_p4b,t_p5b,t_p6b,2) 150 call cr_ccsd_t_E(dbl_mb(k_den),d_i1_3, 151 1 k_t1_local,d_t2,k_i1_offset_3,k_t1_offset,k_t2_offset, 152 2 l_i1_offset_3,t_h1b,t_h2b,t_h3b,t_p4b,t_p5b,t_p6b,2) 153 if (restricted) then 154 factor = 2.0d0 155 else 156 factor = 1.0d0 157 endif 158 if ((t_p4b.eq.t_p5b).and.(t_p5b.eq.t_p6b)) then 159 factor = factor / 6.0d0 160 else if ((t_p4b.eq.t_p5b).or.(t_p5b.eq.t_p6b)) then 161 factor = factor / 2.0d0 162 endif 163 if ((t_h1b.eq.t_h2b).and.(t_h2b.eq.t_h3b)) then 164 factor = factor / 6.0d0 165 else if ((t_h1b.eq.t_h2b).or.(t_h2b.eq.t_h3b)) then 166 factor = factor / 2.0d0 167 endif 168 i = 0 169 do t_p4 = 1, int_mb(k_range+t_p4b-1) 170 do t_p5 = 1, int_mb(k_range+t_p5b-1) 171 do t_p6 = 1, int_mb(k_range+t_p6b-1) 172 do t_h1 = 1, int_mb(k_range+t_h1b-1) 173 do t_h2 = 1, int_mb(k_range+t_h2b-1) 174 do t_h3 = 1, int_mb(k_range+t_h3b-1) 175 i = i + 1 176 num1 = num1 + factor * dbl_mb(k_right+i-1) 177 1 * dbl_mb(k_doubles+i-1) 178 2 / (-dbl_mb(k_evl_sorted+int_mb(k_offset+t_p4b-1)+t_p4-1) 179 3 -dbl_mb(k_evl_sorted+int_mb(k_offset+t_p5b-1)+t_p5-1) 180 4 -dbl_mb(k_evl_sorted+int_mb(k_offset+t_p6b-1)+t_p6-1) 181 5 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h1b-1)+t_h1-1) 182 6 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h2b-1)+t_h2-1) 183 7 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h3b-1)+t_h3-1)) 184 num2 = num2 + factor * dbl_mb(k_right+i-1) 185 1 * (dbl_mb(k_singles+i-1) + dbl_mb(k_doubles+i-1)) 186 2 / (-dbl_mb(k_evl_sorted+int_mb(k_offset+t_p4b-1)+t_p4-1) 187 3 -dbl_mb(k_evl_sorted+int_mb(k_offset+t_p5b-1)+t_p5-1) 188 4 -dbl_mb(k_evl_sorted+int_mb(k_offset+t_p6b-1)+t_p6-1) 189 5 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h1b-1)+t_h1-1) 190 6 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h2b-1)+t_h2-1) 191 7 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h3b-1)+t_h3-1)) 192 den1 = den1 + factor * dbl_mb(k_den+i-1) 193 1 * dbl_mb(k_doubles+i-1) 194 2 / (-dbl_mb(k_evl_sorted+int_mb(k_offset+t_p4b-1)+t_p4-1) 195 3 -dbl_mb(k_evl_sorted+int_mb(k_offset+t_p5b-1)+t_p5-1) 196 4 -dbl_mb(k_evl_sorted+int_mb(k_offset+t_p6b-1)+t_p6-1) 197 5 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h1b-1)+t_h1-1) 198 6 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h2b-1)+t_h2-1) 199 7 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h3b-1)+t_h3-1)) 200 den2 = den2 + factor * dbl_mb(k_den+i-1) 201 1 * (dbl_mb(k_singles+i-1) + dbl_mb(k_doubles+i-1)) 202 2 / (-dbl_mb(k_evl_sorted+int_mb(k_offset+t_p4b-1)+t_p4-1) 203 3 -dbl_mb(k_evl_sorted+int_mb(k_offset+t_p5b-1)+t_p5-1) 204 4 -dbl_mb(k_evl_sorted+int_mb(k_offset+t_p6b-1)+t_p6-1) 205 5 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h1b-1)+t_h1-1) 206 6 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h2b-1)+t_h2-1) 207 7 +dbl_mb(k_evl_sorted+int_mb(k_offset+t_h3b-1)+t_h3-1)) 208 enddo 209 enddo 210 enddo 211 enddo 212 enddo 213 enddo 214 if (.not.MA_POP_STACK(l_den)) 215 1 call errquit('ccsd_t',6,MA_ERR) 216 if (.not.MA_POP_STACK(l_right)) 217 1 call errquit('ccsd_t',6,MA_ERR) 218 if (.not.MA_POP_STACK(l_doubles)) 219 1 call errquit('ccsd_t',7,MA_ERR) 220 if (.not.MA_POP_STACK(l_singles)) 221 1 call errquit('ccsd_t',8,MA_ERR) 222 endif 223 endif 224 endif 225 next = nxtask(nprocs,1) 226 endif 227 count = count + 1 228 enddo 229 enddo 230 enddo 231 enddo 232 enddo 233 enddo 234 next = nxtask(-nprocs,1) 235 call cr_ccsd_t_E(dbl_mb(k_den),d_i1_3, 236 1 k_t1_local,d_t2,k_i1_offset_3,k_t1_offset,k_t2_offset, 237 2 l_i1_offset_3,t_h1b,t_h2b,t_h3b,t_p4b,t_p5b,t_p6b,3) 238 call cr_ccsd_t_N(dbl_mb(k_right),d_f1,d_i1_1,d_i1_2, 239 1 k_t1_local,d_t2,d_v2,k_f1_offset,k_i1_offset_1,k_i1_offset_2, 240 2 k_t1_offset,k_t2_offset,k_v2_offset,l_i1_offset_1, 241 3 l_i1_offset_2,t_h1b,t_h2b,t_h3b,t_p4b,t_p5b,t_p6b,3) 242 call ga_zero(g_energy) 243 call ga_acc(g_energy,1,1,1,1,num1,1,1.0d0) 244 call ga_sync() 245 call ga_get(g_energy,1,1,1,1,num1,1) 246 call ga_zero(g_energy) 247 call ga_acc(g_energy,1,1,1,1,num2,1,1.0d0) 248 call ga_sync() 249 call ga_get(g_energy,1,1,1,1,num2,1) 250 call ga_zero(g_energy) 251 call ga_acc(g_energy,1,1,1,1,den1,1,1.0d0) 252 call ga_sync() 253 call ga_get(g_energy,1,1,1,1,den1,1) 254 call ga_zero(g_energy) 255 call ga_acc(g_energy,1,1,1,1,den2,1,1.0d0) 256 call ga_sync() 257 call ga_get(g_energy,1,1,1,1,den2,1) 258 if (.not.ga_destroy(g_energy)) 259 1 call errquit('ccsd_t: GA problem',1,GA_ERR) 260 den1 = den1 + den0 261 den2 = den2 + den0 262 energy1 = num1/(1.0d0+den1) 263 energy2 = num2/(1.0d0+den2) 264c - T1/X1 LOCALIZATION ------ 265 if(.not.MA_POP_STACK(l_t1_local)) 266 & call errquit('l_t1_local',4,MA_ERR) 267c --------------------------- 268 return 269 end 270