1 SUBROUTINE q3rexpt2_act(a_i0,d_i1_2,d_t1,d_t2, 2 &d_x1,d_x2,k_i1_offset_2, 3 &k_t1_offset,k_t2_offset,k_x1_offset,k_x2_offset,l_i1_offset_2,t_h1 4 &b,t_h2b,t_h3b,t_p4b,t_p5b,t_p6b,toggle) 5C $Id$ 6C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8C i0 ( p4 p5 p6 h1 h2 h3 )_xt + = 1 * P( 9 ) * t ( p4 p5 h1 h2 )_t * x ( p6 h3 )_x 9C i0 ( p4 p5 p6 h1 h2 h3 )_xtt + = -2 * P( 9 ) * t ( p4 h1 )_t * i1 ( p5 p6 h2 h3 )_xt 10C i1 ( p4 p5 h1 h2 )_xt + = -1/4 * P( 4 ) * t ( p4 h1 )_t * x ( p5 h2 )_x 11C i1 ( p4 p5 h1 h2 )_x + = -1/2 * x ( p4 p5 h1 h2 )_x 12 IMPLICIT NONE 13#include "global.fh" 14#include "mafdecls.fh" 15#include "util.fh" 16#include "errquit.fh" 17#include "tce.fh" 18 INTEGER t_p4b 19 INTEGER t_p5b 20 INTEGER t_p6b 21 INTEGER t_h1b 22 INTEGER t_h2b 23 INTEGER t_h3b 24 INTEGER toggle 25 INTEGER d_t2 26 INTEGER k_t2_offset 27 INTEGER d_x1 28 INTEGER k_x1_offset 29 INTEGER d_t1 30 INTEGER k_t1_offset 31 INTEGER d_i1_2 32 INTEGER k_i1_offset_2 33 INTEGER l_i1_offset_2 34 INTEGER size_i1_2 35 INTEGER d_x2 36 INTEGER k_x2_offset 37 DOUBLE PRECISION a_i0(*) 38 CHARACTER*255 filename 39 IF (toggle .eq. 3) THEN 40 CALL DELETEFILE(d_i1_2) 41 IF (.not.MA_POP_STACK(l_i1_offset_2)) 42 &CALL ERRQUIT('q3rexpt2_act',-1,M 43 &A_ERR) 44 END IF 45 IF (toggle .eq. 2) CALL q3rexpt2_act_1(d_t2,k_t2_offset,d_x1, 46 &k_x1_offset,a_i0,t_p4b,t_p5b,t_p6b,t_h1b,t_h2b,t_h3b) 47 IF (toggle .eq. 1) CALL OFFSET_q3rexpt2_act_2_1(l_i1_offset_2, 48 &k_i1_offset_2,size_i1_2) 49 IF (toggle .eq. 1) CALL TCE_FILENAME('q3rexpt2_act_2_1_i1', 50 & filename) 51 IF (toggle .eq. 1) CALL CREATEFILE(filename,d_i1_2,size_i1_2) 52 IF (toggle .eq. 1) CALL q3rexpt2_act_2_1(d_t1,k_t1_offset,d_x1, 53 &k_x1_offset,d_i1_2,k_i1_offset_2) 54 IF (toggle .eq. 1) CALL q3rexpt2_act_2_2(d_x2,k_x2_offset,d_i1_2, 55 &k_i1_offset_2) 56 IF (toggle .eq. 1) CALL RECONCILEFILE(d_i1_2,size_i1_2) 57 IF (toggle .eq. 2) CALL q3rexpt2_act_2(d_t1,k_t1_offset,d_i1_2, 58 &k_i1_offset_2,a_i0,t_p4b,t_p5b,t_p6b,t_h1b,t_h2b,t_h3b) 59 RETURN 60 END 61 SUBROUTINE q3rexpt2_act_1(d_a,k_a_offset,d_b,k_b_offset,a_c,t_p4b, 62 &t_p5b,t_p6b,t_h1b,t_h2b,t_h3b) 63C $Id$ 64C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 65C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 66C i0 ( p4 p5 p6 h1 h2 h3 )_xt + = 1 * P( 9 ) * t ( p4 p5 h1 h2 )_t * x ( p6 h3 )_x 67 IMPLICIT NONE 68#include "global.fh" 69#include "mafdecls.fh" 70#include "sym.fh" 71#include "errquit.fh" 72#include "tce.fh" 73 INTEGER d_a 74 INTEGER k_a_offset 75 INTEGER d_b 76 INTEGER k_b_offset 77 INTEGER t_p4b 78 INTEGER t_p5b 79 INTEGER t_p6b 80 INTEGER t_h1b 81 INTEGER t_h2b 82 INTEGER t_h3b 83 INTEGER p4b 84 INTEGER p5b 85 INTEGER p6b 86 INTEGER h1b 87 INTEGER h2b 88 INTEGER h3b 89 INTEGER dimc 90 INTEGER l_c_sort 91 INTEGER k_c_sort 92 INTEGER p4b_1 93 INTEGER p5b_1 94 INTEGER h1b_1 95 INTEGER h2b_1 96 INTEGER p6b_2 97 INTEGER h3b_2 98 INTEGER dim_common 99 INTEGER dima_sort 100 INTEGER dima 101 INTEGER dimb_sort 102 INTEGER dimb 103 INTEGER l_a_sort 104 INTEGER k_a_sort 105 INTEGER l_a 106 INTEGER k_a 107 INTEGER l_b_sort 108 INTEGER k_b_sort 109 INTEGER l_b 110 INTEGER k_b 111c -- peta-exa -- 112 INTEGER a3(9,6) 113 INTEGER ia6,ja6 114c -------------- 115 LOGICAL is_active_1,is_active_2,is_active_3,is_active_4 116 DOUBLE PRECISION a_c(*) 117 LOGICAL skipped 118c 119cc DO p4b = noab+1,noab+nvab 120cc DO p5b = p4b,noab+nvab 121cc DO p6b = noab+1,noab+nvab 122cc DO h1b = 1,noab 123cc DO h2b = h1b,noab 124cc DO h3b = 1,noab 125c 126 a3(1,1)=t_p4b 127 a3(1,2)=t_p5b 128 a3(1,3)=t_p6b 129 a3(1,4)=t_h1b 130 a3(1,5)=t_h2b 131 a3(1,6)=t_h3b 132c 133 a3(2,1)=t_p4b 134 a3(2,2)=t_p5b 135 a3(2,3)=t_p6b 136 a3(2,4)=t_h2b 137 a3(2,5)=t_h3b 138 a3(2,6)=t_h1b 139c 140 a3(3,1)=t_p4b 141 a3(3,2)=t_p5b 142 a3(3,3)=t_p6b 143 a3(3,4)=t_h1b 144 a3(3,5)=t_h3b 145 a3(3,6)=t_h2b 146c 147 a3(4,1)=t_p5b 148 a3(4,2)=t_p6b 149 a3(4,3)=t_p4b 150 a3(4,4)=t_h1b 151 a3(4,5)=t_h2b 152 a3(4,6)=t_h3b 153c 154 a3(5,1)=t_p5b 155 a3(5,2)=t_p6b 156 a3(5,3)=t_p4b 157 a3(5,4)=t_h2b 158 a3(5,5)=t_h3b 159 a3(5,6)=t_h1b 160c 161 a3(6,1)=t_p5b 162 a3(6,2)=t_p6b 163 a3(6,3)=t_p4b 164 a3(6,4)=t_h1b 165 a3(6,5)=t_h3b 166 a3(6,6)=t_h2b 167c 168 a3(7,1)=t_p4b 169 a3(7,2)=t_p6b 170 a3(7,3)=t_p5b 171 a3(7,4)=t_h1b 172 a3(7,5)=t_h2b 173 a3(7,6)=t_h3b 174c 175 a3(8,1)=t_p4b 176 a3(8,2)=t_p6b 177 a3(8,3)=t_p5b 178 a3(8,4)=t_h2b 179 a3(8,5)=t_h3b 180 a3(8,6)=t_h1b 181c 182 a3(9,1)=t_p4b 183 a3(9,2)=t_p6b 184 a3(9,3)=t_p5b 185 a3(9,4)=t_h1b 186 a3(9,5)=t_h3b 187 a3(9,6)=t_h2b 188c 189 do ia6=1,8 190 if(a3(ia6,1).ne.0) then 191 do ja6=ia6+1,9 192 if((a3(ia6,1).eq.a3(ja6,1)).and.(a3(ia6,2).eq.a3(ja6,2)) 193 & .and.(a3(ia6,3).eq.a3(ja6,3)).and.(a3(ia6,4).eq.a3(ja6,4)) 194 & .and.(a3(ia6,5).eq.a3(ja6,5)).and.(a3(ia6,6).eq.a3(ja6,6))) 195 & then 196 a3(ja6,1)=0 197 a3(ja6,2)=0 198 a3(ja6,3)=0 199 a3(ja6,4)=0 200 a3(ja6,5)=0 201 a3(ja6,6)=0 202 end if 203 enddo 204 end if 205 enddo 206c 207 do ia6=1,9 208 p4b=a3(ia6,1) 209 p5b=a3(ia6,2) 210 p6b=a3(ia6,3) 211 h1b=a3(ia6,4) 212 h2b=a3(ia6,5) 213 h3b=a3(ia6,6) 214 if((p4b.le.p5b).and.(h1b.le.h2b).and.(p4b.ne.0)) then 215 skipped = .false. 216 IF(is_active_4(h1b,h2b,p4b,p5b)) THEN 217 IF (.not.skipped) THEN 218 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 219 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 220 &nt_mb(k_spin+h3b-1).ne.12)) THEN 221 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 222 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 223 &1)) THEN 224 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 225 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 226 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_x,irrep_t)) THEN 227 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 228 &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 229 &b(k_range+h3b-1) 230ccx IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 231ccx & ERRQUIT('q3rexpt2_1',0,MA_ERR) 232ccx CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 233 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 234 &1b-1)+int_mb(k_spin+h2b-1)) THEN 235 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 236 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 237 CALL TCE_RESTRICTED_4(p4b,p5b,h1b,h2b,p4b_1,p5b_1,h1b_1,h2b_1) 238 CALL TCE_RESTRICTED_2(p6b,h3b,p6b_2,h3b_2) 239 dim_common = 1 240 dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb 241 &(k_range+h1b-1) * int_mb(k_range+h2b-1) 242 dima = dim_common * dima_sort 243 dimb_sort = int_mb(k_range+p6b-1) * int_mb(k_range+h3b-1) 244 dimb = dim_common * dimb_sort 245 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 246 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 247 & ERRQUIT('q3rexpt2_1',1,MA_ERR) 248 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 249 &q3rexpt2_1',2,MA_ERR) 250 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 251 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_ 252 &1 - noab - 1))))) 253 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 254 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 255 &,4,3,2,1,1.0d0) 256 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('q3rexpt2_1',3,MA_ERR) 257 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 258 & ERRQUIT('q3rexpt2_1',4,MA_ERR) 259 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 260 &q3rexpt2_1',5,MA_ERR) 261 CALL GET_HASH_BLOCK_MA(dbl_mb(d_b),dbl_mb(k_b),dimb, 262 & int_mb(k_b_offset),(h3b_2 263 & - 1 + noab * (p6b_2 - noab - 1))) 264 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p6b-1) 265 &,int_mb(k_range+h3b-1),2,1,1.0d0) 266 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('q3rexpt2_1',6,MA_ERR) 267ccx CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 268ccx &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 269ccx &t),dima_sort) 270ccx IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('q3rexpt2_1',7,MA_ER 271ccx &R) 272ccx IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('q3rexpt2_1',8,MA_ER 273ccx &R) 274ccx END IF 275ccx END IF 276ccx END IF 277 IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b) 278 & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h 279 &3b)) THEN 280ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 281ccx &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_ 282ccx &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,2,4,3,1,1.0d0) 283 call sd_E_1(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 284 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 285 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 286 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort)) 287 END IF 288 IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b) 289 & .and. (t_h1b .eq. h3b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h 290 &2b)) THEN 291ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 292ccx &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_ 293ccx &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,2,1,4,3,1.0d0) 294 call sd_E_2(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 295 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 296 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 297 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort)) 298 END IF 299 IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b) 300 & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h 301 &2b)) THEN 302ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 303ccx &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_ 304ccx &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,2,4,1,3,-1.0d0) 305 call sd_E_3(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 306 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 307 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 308 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort)) 309 END IF 310 IF ((t_p4b .eq. p6b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p5b) 311 & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h 312 &3b)) THEN 313ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 314ccx &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_ 315ccx &mb(k_range+p5b-1),int_mb(k_range+p4b-1),2,6,5,4,3,1,1.0d0) 316 call sd_E_4(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 317 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 318 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 319 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort)) 320 END IF 321 IF ((t_p4b .eq. p6b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p5b) 322 & .and. (t_h1b .eq. h3b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h 323 &2b)) THEN 324ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 325ccx &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_ 326ccx &mb(k_range+p5b-1),int_mb(k_range+p4b-1),2,6,5,1,4,3,1.0d0) 327 call sd_E_5(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 328 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 329 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 330 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort)) 331 END IF 332 IF ((t_p4b .eq. p6b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p5b) 333 & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h 334 &2b)) THEN 335ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 336ccx &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_ 337ccx &mb(k_range+p5b-1),int_mb(k_range+p4b-1),2,6,5,4,1,3,-1.0d0) 338 call sd_E_6(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 339 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 340 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 341 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort)) 342 END IF 343 IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p5b) 344 & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h 345 &3b)) THEN 346ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 347ccx &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_ 348ccx &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,2,5,4,3,1,-1.0d0) 349 call sd_E_7(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 350 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 351 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 352 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort)) 353 END IF 354 IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p5b) 355 & .and. (t_h1b .eq. h3b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h 356 &2b)) THEN 357ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 358ccx &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_ 359ccx &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,2,5,1,4,3,-1.0d0) 360 call sd_E_8(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 361 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 362 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 363 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort)) 364 END IF 365 IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p5b) 366 & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h 367 &2b)) THEN 368ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 369ccx &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_ 370ccx &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,2,5,4,1,3,1.0d0) 371 call sd_E_9(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 372 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 373 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 374 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort)) 375 END IF 376ccx IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('q3rexpt2_1',9,MA_ER 377ccx &R) 378c 379 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_t_singles_1',7 380 &,MA_ERR) 381 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_t_singles_1',8 382 &,MA_ERR) 383c 384 END IF 385 END IF 386 END IF 387c 388 END IF 389 END IF 390 END IF 391 END IF 392 END IF 393c 394 END IF 395 END DO 396 RETURN 397 END 398 SUBROUTINE q3rexpt2_act_2(d_a,k_a_offset,d_b,k_b_offset,a_c,t_p4b, 399 &t_p5b,t_p6b,t_h1b,t_h2b,t_h3b) 400C $Id$ 401C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 402C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 403C i0 ( p4 p5 p6 h1 h2 h3 )_xtt + = -2 * P( 9 ) * t ( p4 h1 )_t * i1 ( p5 p6 h2 h3 )_xt 404 IMPLICIT NONE 405#include "global.fh" 406#include "mafdecls.fh" 407#include "sym.fh" 408#include "errquit.fh" 409#include "tce.fh" 410 INTEGER d_a 411 INTEGER k_a_offset 412 INTEGER d_b 413 INTEGER k_b_offset 414 INTEGER t_p4b 415 INTEGER t_p5b 416 INTEGER t_p6b 417 INTEGER t_h1b 418 INTEGER t_h2b 419 INTEGER t_h3b 420 INTEGER p4b 421 INTEGER p5b 422 INTEGER p6b 423 INTEGER h1b 424 INTEGER h2b 425 INTEGER h3b 426 INTEGER dimc 427 INTEGER l_c_sort 428 INTEGER k_c_sort 429 INTEGER p4b_1 430 INTEGER h1b_1 431 INTEGER p5b_2 432 INTEGER p6b_2 433 INTEGER h2b_2 434 INTEGER h3b_2 435 INTEGER dim_common 436 INTEGER dima_sort 437 INTEGER dima 438 INTEGER dimb_sort 439 INTEGER dimb 440 INTEGER l_a_sort 441 INTEGER k_a_sort 442 INTEGER l_a 443 INTEGER k_a 444 INTEGER l_b_sort 445 INTEGER k_b_sort 446 INTEGER l_b 447 INTEGER k_b 448c -- peta-exa -- 449 INTEGER a3(9,6) 450 INTEGER ia6,ja6 451c -------------- 452 LOGICAL one_of_two_act 453 DOUBLE PRECISION a_c(*) 454 LOGICAL skipped 455c 456cc DO p4b = noab+1,noab+nvab 457cc DO p5b = noab+1,noab+nvab 458cc DO p6b = p5b,noab+nvab 459cc DO h1b = 1,noab 460cc DO h2b = 1,noab 461cc DO h3b = h2b,noab 462c 463 a3(1,1)=t_p4b 464 a3(1,2)=t_p5b 465 a3(1,3)=t_p6b 466 a3(1,4)=t_h1b 467 a3(1,5)=t_h2b 468 a3(1,6)=t_h3b 469c 470 a3(2,1)=t_p4b 471 a3(2,2)=t_p5b 472 a3(2,3)=t_p6b 473 a3(2,4)=t_h2b 474 a3(2,5)=t_h1b 475 a3(2,6)=t_h3b 476c 477 a3(3,1)=t_p4b 478 a3(3,2)=t_p5b 479 a3(3,3)=t_p6b 480 a3(3,4)=t_h3b 481 a3(3,5)=t_h1b 482 a3(3,6)=t_h2b 483c 484 a3(4,1)=t_p5b 485 a3(4,2)=t_p4b 486 a3(4,3)=t_p6b 487 a3(4,4)=t_h1b 488 a3(4,5)=t_h2b 489 a3(4,6)=t_h3b 490c 491 a3(5,1)=t_p5b 492 a3(5,2)=t_p4b 493 a3(5,3)=t_p6b 494 a3(5,4)=t_h2b 495 a3(5,5)=t_h1b 496 a3(5,6)=t_h3b 497c 498 a3(6,1)=t_p5b 499 a3(6,2)=t_p4b 500 a3(6,3)=t_p6b 501 a3(6,4)=t_h3b 502 a3(6,5)=t_h1b 503 a3(6,6)=t_h2b 504c 505 a3(7,1)=t_p6b 506 a3(7,2)=t_p4b 507 a3(7,3)=t_p5b 508 a3(7,4)=t_h1b 509 a3(7,5)=t_h2b 510 a3(7,6)=t_h3b 511c 512 a3(8,1)=t_p6b 513 a3(8,2)=t_p4b 514 a3(8,3)=t_p5b 515 a3(8,4)=t_h2b 516 a3(8,5)=t_h1b 517 a3(8,6)=t_h3b 518c 519 a3(9,1)=t_p6b 520 a3(9,2)=t_p4b 521 a3(9,3)=t_p5b 522 a3(9,4)=t_h3b 523 a3(9,5)=t_h1b 524 a3(9,6)=t_h2b 525c 526 do ia6=1,8 527 if(a3(ia6,1).ne.0) then 528 do ja6=ia6+1,9 529 if((a3(ia6,1).eq.a3(ja6,1)).and.(a3(ia6,2).eq.a3(ja6,2)) 530 & .and.(a3(ia6,3).eq.a3(ja6,3)).and.(a3(ia6,4).eq.a3(ja6,4)) 531 & .and.(a3(ia6,5).eq.a3(ja6,5)).and.(a3(ia6,6).eq.a3(ja6,6))) 532 & then 533 a3(ja6,1)=0 534 a3(ja6,2)=0 535 a3(ja6,3)=0 536 a3(ja6,4)=0 537 a3(ja6,5)=0 538 a3(ja6,6)=0 539 end if 540 enddo 541 end if 542 enddo 543c 544 do ia6=1,9 545 p4b=a3(ia6,1) 546 p5b=a3(ia6,2) 547 p6b=a3(ia6,3) 548 h1b=a3(ia6,4) 549 h2b=a3(ia6,5) 550 h3b=a3(ia6,6) 551 if((p5b.le.p6b).and.(h2b.le.h3b).and.(p4b.ne.0)) then 552 skipped = .false. 553 IF(one_of_two_act(p5b,p6b).and.one_of_two_act(h2b,h3b)) THEN 554 IF (.not.skipped) THEN 555 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 556 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 557 &nt_mb(k_spin+h3b-1).ne.12)) THEN 558 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 559 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 560 &1)) THEN 561 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 562 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 563 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_x,ieor(irrep_t,irrep_t))) TH 564 &EN 565 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 566 &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 567 &b(k_range+h3b-1) 568ccx IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 569ccx & ERRQUIT('q3rexpt2_2',0,MA_ERR) 570ccx CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 571 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h1b-1)) THEN 572 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 573 &EN 574 CALL TCE_RESTRICTED_2(p4b,h1b,p4b_1,h1b_1) 575 CALL TCE_RESTRICTED_4(p5b,p6b,h2b,h3b,p5b_2,p6b_2,h2b_2,h3b_2) 576 dim_common = 1 577 dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1) 578 dima = dim_common * dima_sort 579 dimb_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb 580 &(k_range+h2b-1) * int_mb(k_range+h3b-1) 581 dimb = dim_common * dimb_sort 582 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 583 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 584 & ERRQUIT('q3rexpt2_2',1,MA_ERR) 585 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 586 &q3rexpt2_2',2,MA_ERR) 587 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 588 & int_mb(k_a_offset),(h1b_1 589 & - 1 + noab * (p4b_1 - noab - 1))) 590 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 591 &,int_mb(k_range+h1b-1),2,1,1.0d0) 592 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('q3rexpt2_2',3,MA_ERR) 593 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 594 & ERRQUIT('q3rexpt2_2',4,MA_ERR) 595ccx IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 596ccx &q3rexpt2_2',5,MA_ERR) 597 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b_sort),dimb,int_mb(k_b_offset), 598 &(h3b_2 599 & - 1 + noab * (h2b_2 - 1 + noab * (p6b_2 - noab - 1 + nvab * (p5b_ 600 &2 - noab - 1))))) 601ccx CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 602ccx &,int_mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 603ccx &,4,3,2,1,1.0d0) 604ccx IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('q3rexpt2_2',6,MA_ERR) 605ccx CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 606ccx &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 607ccx &t),dima_sort) 608ccx IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('q3rexpt2_2',7,MA_ER 609ccx &R) 610ccx IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('q3rexpt2_2',8,MA_ER 611ccx &R) 612ccx END IF 613ccx END IF 614ccx END IF 615 IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b) 616 & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h 617 &3b)) THEN 618ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 619ccx &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_ 620ccx &mb(k_range+h1b-1),int_mb(k_range+p4b-1),6,4,3,5,2,1,-2.0d0/1.0d0) 621 call sd_E2_1(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 622 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 623 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 624 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),-2.0d0/1.0d0) 625 END IF 626 IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b) 627 & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h 628 &3b)) THEN 629ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 630ccx &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_ 631ccx &mb(k_range+h1b-1),int_mb(k_range+p4b-1),6,4,3,2,5,1,2.0d0/1.0d0) 632 call sd_E2_2(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 633 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 634 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 635 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),2.0d0/1.0d0) 636 END IF 637 IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b) 638 & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h 639 &1b)) THEN 640ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 641ccx &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_ 642ccx &mb(k_range+h1b-1),int_mb(k_range+p4b-1),6,4,3,2,1,5,-2.0d0/1.0d0) 643 call sd_E2_3(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 644 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 645 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 646 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),-2.0d0/1.0d0) 647 END IF 648 IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p6b) 649 & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h 650 &3b)) THEN 651ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 652ccx &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_ 653ccx &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,6,3,5,2,1,2.0d0/1.0d0) 654 call sd_E2_4(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 655 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 656 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 657 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),2.0d0/1.0d0) 658 END IF 659 IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p6b) 660 & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h 661 &3b)) THEN 662ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 663ccx &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_ 664ccx &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,6,3,2,5,1,-2.0d0/1.0d0) 665 call sd_E2_5(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 666 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 667 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 668 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),-2.0d0/1.0d0) 669 END IF 670 IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p6b) 671 & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h 672 &1b)) THEN 673ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 674ccx &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_ 675ccx &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,6,3,2,1,5,2.0d0/1.0d0) 676 call sd_E2_6(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 677 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 678 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 679 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),2.0d0/1.0d0) 680 END IF 681 IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p4b) 682 & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h 683 &3b)) THEN 684ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 685ccx &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_ 686ccx &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,3,6,5,2,1,-2.0d0/1.0d0) 687 call sd_E2_7(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 688 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 689 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 690 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),-2.0d0/1.0d0) 691 END IF 692 IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p4b) 693 & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h 694 &3b)) THEN 695ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 696ccx &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_ 697ccx &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,3,6,2,5,1,2.0d0/1.0d0) 698 call sd_E2_8(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 699 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 700 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 701 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),2.0d0/1.0d0) 702 END IF 703 IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p4b) 704 & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h 705 &1b)) THEN 706ccx CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_ 707ccx &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_ 708ccx &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,3,6,2,1,5,-2.0d0/1.0d0) 709 call sd_E2_9(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1), 710 1 int_mb(k_range+h1b-1),int_mb(k_range+p6b-1), 711 2 int_mb(k_range+p5b-1),int_mb(k_range+p4b-1), 712 4 a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),-2.0d0/1.0d0) 713 END IF 714ccx IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('q3rexpt2_2',9,MA_ER 715ccx &R) 716c 717 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_t_singles_1',7 718 &,MA_ERR) 719 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_t_singles_1',8 720 &,MA_ERR) 721c 722 END IF 723 END IF 724 END IF 725c 726 END IF 727 END IF 728 END IF 729 END IF 730 END IF 731c 732 END IF 733 END DO 734 RETURN 735 END 736 SUBROUTINE q3rexpt2_act_2_1(d_a,k_a_offset,d_b,k_b_offset, 737 &d_c,k_c_offset) 738C $Id$ 739C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 740C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 741C i1 ( p4 p5 h1 h2 )_xt + = -1/4 * P( 4 ) * t ( p4 h1 )_t * x ( p5 h2 )_x 742 IMPLICIT NONE 743#include "global.fh" 744#include "mafdecls.fh" 745#include "sym.fh" 746#include "errquit.fh" 747#include "tce.fh" 748 INTEGER d_a 749 INTEGER k_a_offset 750 INTEGER d_b 751 INTEGER k_b_offset 752 INTEGER d_c 753 INTEGER k_c_offset 754 INTEGER nxtask 755 INTEGER next 756 INTEGER nprocs 757 INTEGER count 758 INTEGER p4b 759 INTEGER p5b 760 INTEGER h1b 761 INTEGER h2b 762 INTEGER dimc 763 INTEGER l_c_sort 764 INTEGER k_c_sort 765 INTEGER p4b_1 766 INTEGER h1b_1 767 INTEGER p5b_2 768 INTEGER h2b_2 769 INTEGER dim_common 770 INTEGER dima_sort 771 INTEGER dima 772 INTEGER dimb_sort 773 INTEGER dimb 774 INTEGER l_a_sort 775 INTEGER k_a_sort 776 INTEGER l_a 777 INTEGER k_a 778 INTEGER l_b_sort 779 INTEGER k_b_sort 780 INTEGER l_b 781 INTEGER k_b 782 INTEGER l_c 783 INTEGER k_c 784 LOGICAL one_of_two_act 785 EXTERNAL nxtask 786 nprocs = GA_NNODES() 787 count = 0 788 next = nxtask(nprocs,1) 789 DO p4b = noab+1,noab+nvab 790 DO p5b = noab+1,noab+nvab 791 DO h1b = 1,noab 792 DO h2b = 1,noab 793 IF (next.eq.count) THEN 794 IF(one_of_two_act(h1b,h2b).and.one_of_two_act(p4b,p5b)) THEN 795 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 796 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 797 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 798 &1b-1)+int_mb(k_spin+h2b-1)) THEN 799 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 800 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_t)) TH 801 &EN 802 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 803 &nge+h1b-1) * int_mb(k_range+h2b-1) 804 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 805 & ERRQUIT('q3rexpt2_act_2_1',0,MA_ERR) 806 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 807 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h1b-1)) THEN 808 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 809 &EN 810 CALL TCE_RESTRICTED_2(p4b,h1b,p4b_1,h1b_1) 811 CALL TCE_RESTRICTED_2(p5b,h2b,p5b_2,h2b_2) 812 dim_common = 1 813 dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1) 814 dima = dim_common * dima_sort 815 dimb_sort = int_mb(k_range+p5b-1) * int_mb(k_range+h2b-1) 816 dimb = dim_common * dimb_sort 817 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 818 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 819 & ERRQUIT('q3rexpt2_act_2_1',1,MA_ERR) 820 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 821 &q3rexpt2_act_2_1',2,MA_ERR) 822 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 823 & int_mb(k_a_offset),(h1b_1 824 & - 1 + noab * (p4b_1 - noab - 1))) 825 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 826 &,int_mb(k_range+h1b-1),2,1,1.0d0) 827 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('q3rexpt2_act_2_1',3, 828 &MA_ERR) 829 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 830 & ERRQUIT('q3rexpt2_act_2_1',4,MA_ERR) 831 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 832 &q3rexpt2_act_2_1',5,MA_ERR) 833 CALL GET_HASH_BLOCK_MA(dbl_mb(d_b),dbl_mb(k_b),dimb, 834 & int_mb(k_b_offset),(h2b_2 835 & - 1 + noab * (p5b_2 - noab - 1))) 836 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 837 &,int_mb(k_range+h2b-1),2,1,1.0d0) 838 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('q3rexpt2_act_2_1',6, 839 &MA_ERR) 840 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 841 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 842 &t),dima_sort) 843 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('q3rexpt2_act_2_1', 844 &7,MA_ERR) 845 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('q3rexpt2_act_2_1',8 846 &,MA_ERR) 847 END IF 848 END IF 849 END IF 850 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 851 &q3rexpt2_act_2_1',9,MA_ERR) 852 IF ((p4b .le. p5b) .and. (h1b .le. h2b)) THEN 853 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 854 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1) 855 &,4,2,3,1,-1.0d0/4.0d0) 856 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 857 & 1 + noab * (h1b - 1 + noab * (p5b - noab - 1 + nvab * (p4b - noab 858 & - 1))))) 859 END IF 860 IF ((p4b .le. p5b) .and. (h2b .le. h1b)) THEN 861 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 862 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1) 863 &,4,2,1,3,1.0d0/4.0d0) 864 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 865 & 1 + noab * (h2b - 1 + noab * (p5b - noab - 1 + nvab * (p4b - noab 866 & - 1))))) 867 END IF 868 IF ((p5b .le. p4b) .and. (h1b .le. h2b)) THEN 869 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 870 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1) 871 &,2,4,3,1,1.0d0/4.0d0) 872 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 873 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p5b - noab 874 & - 1))))) 875 END IF 876 IF ((p5b .le. p4b) .and. (h2b .le. h1b)) THEN 877 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 878 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1) 879 &,2,4,1,3,-1.0d0/4.0d0) 880 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 881 & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p5b - noab 882 & - 1))))) 883 END IF 884 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('q3rexpt2_act_2_1',10, 885 &MA_ERR) 886 IF (.not.MA_POP_STACK(l_c_sort)) 887 & CALL ERRQUIT('q3rexpt2_act_2_1',11,MA_ERR) 888 END IF 889 END IF 890 END IF 891 END IF 892 next = nxtask(nprocs,1) 893 END IF 894 count = count + 1 895 END DO 896 END DO 897 END DO 898 END DO 899 next = nxtask(-nprocs,1) 900 call GA_SYNC() 901 RETURN 902 END 903 SUBROUTINE OFFSET_q3rexpt2_act_2_1(l_a_offset,k_a_offset,size) 904C $Id$ 905C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 906C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 907C i1 ( p4 p5 h1 h2 )_xt 908 IMPLICIT NONE 909#include "global.fh" 910#include "mafdecls.fh" 911#include "sym.fh" 912#include "errquit.fh" 913#include "tce.fh" 914 INTEGER l_a_offset 915 INTEGER k_a_offset 916 INTEGER size 917 INTEGER length 918 INTEGER addr 919 INTEGER p4b 920 INTEGER p5b 921 INTEGER h1b 922 INTEGER h2b 923 LOGICAL one_of_two_act 924 length = 0 925 DO p4b = noab+1,noab+nvab 926 DO p5b = p4b,noab+nvab 927 DO h1b = 1,noab 928 DO h2b = h1b,noab 929 IF(one_of_two_act(p4b,p5b).and.one_of_two_act(h1b,h2b)) THEN 930 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 931 &1b-1)+int_mb(k_spin+h2b-1)) THEN 932 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 933 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_t)) TH 934 &EN 935 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 936 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 937 length = length + 1 938 END IF 939 END IF 940 END IF 941 END IF 942 END DO 943 END DO 944 END DO 945 END DO 946 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 947 &set)) CALL ERRQUIT('q3rexpt2_act_2_1',0,MA_ERR) 948 int_mb(k_a_offset) = length 949 addr = 0 950 size = 0 951 DO p4b = noab+1,noab+nvab 952 DO p5b = p4b,noab+nvab 953 DO h1b = 1,noab 954 DO h2b = h1b,noab 955 IF(one_of_two_act(p4b,p5b).and.one_of_two_act(h1b,h2b)) THEN 956 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 957 &1b-1)+int_mb(k_spin+h2b-1)) THEN 958 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 959 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_t)) TH 960 &EN 961 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 962 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 963 addr = addr + 1 964 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (p5b 965 &- noab - 1 + nvab * (p4b - noab - 1))) 966 int_mb(k_a_offset+length+addr) = size 967 size = size + int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_ 968 &mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 969 END IF 970 END IF 971 END IF 972 END IF 973 END DO 974 END DO 975 END DO 976 END DO 977 RETURN 978 END 979 SUBROUTINE q3rexpt2_act_2_2(d_a,k_a_offset,d_c,k_c_offset) 980C $Id$ 981C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 982C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 983C i1 ( p4 p5 h1 h2 )_x + = -1/2 * x ( p4 p5 h1 h2 )_x 984 IMPLICIT NONE 985#include "global.fh" 986#include "mafdecls.fh" 987#include "sym.fh" 988#include "errquit.fh" 989#include "tce.fh" 990 INTEGER d_a 991 INTEGER k_a_offset 992 INTEGER d_c 993 INTEGER k_c_offset 994 INTEGER nxtask 995 INTEGER next 996 INTEGER nprocs 997 INTEGER count 998 INTEGER p4b 999 INTEGER p5b 1000 INTEGER h1b 1001 INTEGER h2b 1002 INTEGER dimc 1003 INTEGER p4b_1 1004 INTEGER p5b_1 1005 INTEGER h1b_1 1006 INTEGER h2b_1 1007 INTEGER dim_common 1008 INTEGER dima_sort 1009 INTEGER dima 1010 INTEGER l_a_sort 1011 INTEGER k_a_sort 1012 INTEGER l_a 1013 INTEGER k_a 1014 INTEGER l_c 1015 INTEGER k_c 1016 LOGICAL is_active_1,is_active_2,is_active_3,is_active_4 1017 EXTERNAL nxtask 1018 nprocs = GA_NNODES() 1019 count = 0 1020 next = nxtask(nprocs,1) 1021 DO p4b = noab+1,noab+nvab 1022 DO p5b = p4b,noab+nvab 1023 DO h1b = 1,noab 1024 DO h2b = h1b,noab 1025 IF (next.eq.count) THEN 1026 IF(is_active_4(p4b,p5b,h1b,h2b)) THEN !!stronger than 2*one_of_two_act 1027 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 1028 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1029 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 1030 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1031 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 1032 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN 1033 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 1034 &nge+h1b-1) * int_mb(k_range+h2b-1) 1035 CALL TCE_RESTRICTED_4(p4b,p5b,h1b,h2b,p4b_1,p5b_1,h1b_1,h2b_1) 1036 dim_common = 1 1037 dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb 1038 &(k_range+h1b-1) * int_mb(k_range+h2b-1) 1039 dima = dim_common * dima_sort 1040 IF (dima .gt. 0) THEN 1041 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1042 & ERRQUIT('q3rexpt2_act_2_2',0,MA_ERR) 1043 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1044 &q3rexpt2_act_2_2',1,MA_ERR) 1045 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 1046 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_ 1047 &1 - noab - 1))))) 1048 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 1049 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 1050 &,4,3,2,1,1.0d0) 1051 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('q3rexpt2_act_2_2',2, 1052 &MA_ERR) 1053 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1054 &q3rexpt2_act_2_2',3,MA_ERR) 1055 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 1056 &,int_mb(k_range+h1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p4b-1) 1057 &,4,3,2,1,-1.0d0/2.0d0) 1058 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1059 & 1 + noab * (h1b - 1 + noab * (p5b - noab - 1 + nvab * (p4b - noab 1060 & - 1))))) 1061 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('q3rexpt2_act_2_2',4, 1062 &MA_ERR) 1063 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('q3rexpt2_act_2_2', 1064 &5,MA_ERR) 1065 END IF 1066 END IF 1067 END IF 1068 END IF 1069 END IF 1070 next = nxtask(nprocs,1) 1071 END IF 1072 count = count + 1 1073 END DO 1074 END DO 1075 END DO 1076 END DO 1077 next = nxtask(-nprocs,1) 1078 call GA_SYNC() 1079 RETURN 1080 END 1081