1 SUBROUTINE ccsdtq_o3(d_i0,d_o1,d_t1,d_t2,d_t3,d_t4,k_i0_offset,k_o 2 &1_offset,k_t1_offset,k_t2_offset,k_t3_offset,k_t4_offset) 3C $Id$ 4C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6C i0 ( p4 p5 p6 h1 h2 h3 )_to + = -1 * P( 3 ) * Sum ( h7 ) * o ( h7 h1 )_o * t ( p4 p5 p6 h2 h3 h7 )_t 7C i0 ( p4 p5 p6 h1 h2 h3 )_to + = 1 * P( 3 ) * Sum ( p7 ) * o ( p4 p7 )_o * t ( p5 p6 p7 h1 h2 h3 )_t 8C i0 ( p4 p5 p6 h1 h2 h3 )_to + = 1 * Sum ( p8 h7 ) * o ( h7 p8 )_o * t ( p4 p5 p6 p8 h1 h2 h3 h7 )_t 9C i0 ( p4 p5 p6 h1 h2 h3 )_ott + = -1 * P( 3 ) * Sum ( h7 ) * t ( p4 p5 p6 h1 h2 h7 )_t * i1 ( h7 h3 )_ot 10C i1 ( h7 h1 )_ot + = 1 * Sum ( p8 ) * o ( h7 p8 )_o * t ( p8 h1 )_t 11C i0 ( p4 p5 p6 h1 h2 h3 )_ott + = -1 * P( 3 ) * Sum ( h7 ) * t ( p4 h7 )_t * i1 ( h7 p5 p6 h1 h2 h3 )_ot 12C i1 ( h7 p4 p5 h1 h2 h3 )_ot + = 1 * Sum ( p8 ) * o ( h7 p8 )_o * t ( p4 p5 p8 h1 h2 h3 )_t 13C i0 ( p4 p5 p6 h1 h2 h3 )_ott + = -1 * P( 9 ) * Sum ( h8 ) * t ( p4 p5 h1 h8 )_t * i1 ( h8 p6 h2 h3 )_ot 14C i1 ( h8 p4 h1 h2 )_ot + = -1 * Sum ( p7 ) * o ( h8 p7 )_o * t ( p4 p7 h1 h2 )_t 15 IMPLICIT NONE 16#include "global.fh" 17#include "mafdecls.fh" 18#include "util.fh" 19#include "errquit.fh" 20#include "tce.fh" 21 INTEGER d_i0 22 INTEGER k_i0_offset 23 INTEGER d_o1 24 INTEGER k_o1_offset 25 INTEGER d_t3 26 INTEGER k_t3_offset 27 INTEGER d_t4 28 INTEGER k_t4_offset 29 INTEGER d_i1 30 INTEGER k_i1_offset 31 INTEGER d_t1 32 INTEGER k_t1_offset 33 INTEGER d_t2 34 INTEGER k_t2_offset 35 INTEGER l_i1_offset 36 INTEGER size_i1 37 CHARACTER*255 filename 38 CALL ccsdtq_o3_1(d_o1,k_o1_offset,d_t3,k_t3_offset,d_i0,k_i0_offse 39 &t) 40 CALL ccsdtq_o3_2(d_o1,k_o1_offset,d_t3,k_t3_offset,d_i0,k_i0_offse 41 &t) 42 CALL ccsdtq_o3_3(d_o1,k_o1_offset,d_t4,k_t4_offset,d_i0,k_i0_offse 43 &t) 44 CALL OFFSET_ccsdtq_o3_4_1(l_i1_offset,k_i1_offset,size_i1) 45 CALL TCE_FILENAME('ccsdtq_o3_4_1_i1',filename) 46 CALL CREATEFILE(filename,d_i1,size_i1) 47 CALL ccsdtq_o3_4_1(d_o1,k_o1_offset,d_t1,k_t1_offset,d_i1,k_i1_off 48 &set) 49 CALL RECONCILEFILE(d_i1,size_i1) 50 CALL ccsdtq_o3_4(d_t3,k_t3_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 51 &t) 52 CALL DELETEFILE(d_i1) 53 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdtq_o3',-1,MA 54 &_ERR) 55 CALL OFFSET_ccsdtq_o3_5_1(l_i1_offset,k_i1_offset,size_i1) 56 CALL TCE_FILENAME('ccsdtq_o3_5_1_i1',filename) 57 CALL CREATEFILE(filename,d_i1,size_i1) 58 CALL ccsdtq_o3_5_1(d_o1,k_o1_offset,d_t3,k_t3_offset,d_i1,k_i1_off 59 &set) 60 CALL RECONCILEFILE(d_i1,size_i1) 61 CALL ccsdtq_o3_5(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 62 &t) 63 CALL DELETEFILE(d_i1) 64 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdtq_o3',-1,MA 65 &_ERR) 66 CALL OFFSET_ccsdtq_o3_6_1(l_i1_offset,k_i1_offset,size_i1) 67 CALL TCE_FILENAME('ccsdtq_o3_6_1_i1',filename) 68 CALL CREATEFILE(filename,d_i1,size_i1) 69 CALL ccsdtq_o3_6_1(d_o1,k_o1_offset,d_t2,k_t2_offset,d_i1,k_i1_off 70 &set) 71 CALL RECONCILEFILE(d_i1,size_i1) 72 CALL ccsdtq_o3_6(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 73 &t) 74 CALL DELETEFILE(d_i1) 75 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdtq_o3',-1,MA 76 &_ERR) 77 RETURN 78 END 79 SUBROUTINE ccsdtq_o3_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 80 &t) 81C $Id$ 82C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 83C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 84C i0 ( p4 p5 p6 h1 h2 h3 )_to + = -1 * P( 3 ) * Sum ( h7 ) * o ( h7 h1 )_o * t ( p4 p5 p6 h2 h3 h7 )_t 85 IMPLICIT NONE 86#include "global.fh" 87#include "mafdecls.fh" 88#include "sym.fh" 89#include "errquit.fh" 90#include "tce.fh" 91 INTEGER d_a 92 INTEGER k_a_offset 93 INTEGER d_b 94 INTEGER k_b_offset 95 INTEGER d_c 96 INTEGER k_c_offset 97 INTEGER NXTASK 98 INTEGER next 99 INTEGER nprocs 100 INTEGER count 101 INTEGER p4b 102 INTEGER p5b 103 INTEGER p6b 104 INTEGER h1b 105 INTEGER h2b 106 INTEGER h3b 107 INTEGER dimc 108 INTEGER l_c_sort 109 INTEGER k_c_sort 110 INTEGER h7b 111 INTEGER h7b_1 112 INTEGER h1b_1 113 INTEGER p4b_2 114 INTEGER p5b_2 115 INTEGER p6b_2 116 INTEGER h2b_2 117 INTEGER h3b_2 118 INTEGER h7b_2 119 INTEGER dim_common 120 INTEGER dima_sort 121 INTEGER dima 122 INTEGER dimb_sort 123 INTEGER dimb 124 INTEGER l_a_sort 125 INTEGER k_a_sort 126 INTEGER l_a 127 INTEGER k_a 128 INTEGER l_b_sort 129 INTEGER k_b_sort 130 INTEGER l_b 131 INTEGER k_b 132 INTEGER l_c 133 INTEGER k_c 134 EXTERNAL NXTASK 135 nprocs = GA_NNODES() 136 count = 0 137 next = NXTASK(nprocs,1) 138 DO p4b = noab+1,noab+nvab 139 DO p5b = p4b,noab+nvab 140 DO p6b = p5b,noab+nvab 141 DO h1b = 1,noab 142 DO h2b = 1,noab 143 DO h3b = h2b,noab 144 IF (next.eq.count) THEN 145 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 146 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 147 &nt_mb(k_spin+h3b-1).ne.12)) THEN 148 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 149 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 150 &1)) THEN 151 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 152 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 153 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_t,irrep_o)) THEN 154 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 155 &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 156 &b(k_range+h3b-1) 157 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 158 & ERRQUIT('ccsdtq_o3_1',0,MA_ERR) 159 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 160 DO h7b = 1,noab 161 IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h1b-1)) THEN 162 IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_o) TH 163 &EN 164 CALL TCE_RESTRICTED_2(h7b,h1b,h7b_1,h1b_1) 165 CALL TCE_RESTRICTED_6(p4b,p5b,p6b,h2b,h3b,h7b,p4b_2,p5b_2,p6b_2,h2 166 &b_2,h3b_2,h7b_2) 167 dim_common = int_mb(k_range+h7b-1) 168 dima_sort = int_mb(k_range+h1b-1) 169 dima = dim_common * dima_sort 170 dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb 171 &(k_range+p6b-1) * int_mb(k_range+h2b-1) * int_mb(k_range+h3b-1) 172 dimb = dim_common * dimb_sort 173 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 174 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 175 & ERRQUIT('ccsdtq_o3_1',1,MA_ERR) 176 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 177 &ccsdtq_o3_1',2,MA_ERR) 178 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 179 & - 1 + (noab+nvab) * (h7b_1 - 1))) 180 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 181 &,int_mb(k_range+h1b-1),2,1,1.0d0) 182 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o3_1',3,MA_ERR) 183 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 184 & ERRQUIT('ccsdtq_o3_1',4,MA_ERR) 185 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 186 &ccsdtq_o3_1',5,MA_ERR) 187 IF ((h7b .lt. h2b)) THEN 188 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 189 & - 1 + noab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (p6b_2 - noa 190 &b - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))) 191 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 192 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h7b-1) 193 &,int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,3,2,1,4,1.0d0) 194 END IF 195 IF ((h2b .le. h7b) .and. (h7b .lt. h3b)) THEN 196 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 197 & - 1 + noab * (h7b_2 - 1 + noab * (h2b_2 - 1 + noab * (p6b_2 - noa 198 &b - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))) 199 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 200 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h2b-1) 201 &,int_mb(k_range+h7b-1),int_mb(k_range+h3b-1),6,4,3,2,1,5,-1.0d0) 202 END IF 203 IF ((h3b .le. h7b)) THEN 204 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h7b_2 205 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (p6b_2 - noa 206 &b - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))) 207 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 208 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h2b-1) 209 &,int_mb(k_range+h3b-1),int_mb(k_range+h7b-1),5,4,3,2,1,6,1.0d0) 210 END IF 211 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o3_1',6,MA_ERR) 212 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 213 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 214 &t),dima_sort) 215 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o3_1',7,MA_E 216 &RR) 217 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o3_1',8,MA_E 218 &RR) 219 END IF 220 END IF 221 END IF 222 END DO 223 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 224 &ccsdtq_o3_1',9,MA_ERR) 225 IF ((h1b .le. h2b)) THEN 226 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 227 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 228 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),5,4,3,6,2,1,-1.0d0) 229 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 230 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 + 231 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 232 END IF 233 IF ((h2b .le. h1b) .and. (h1b .le. h3b)) THEN 234 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 235 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 236 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),5,4,3,2,6,1,1.0d0) 237 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 238 & 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * (p6b - noab - 1 + 239 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 240 END IF 241 IF ((h3b .le. h1b)) THEN 242 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 243 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 244 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),5,4,3,2,1,6,-1.0d0) 245 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 246 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (p6b - noab - 1 + 247 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 248 END IF 249 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o3_1',10,MA_ERR) 250 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o3_1',11,MA_ 251 &ERR) 252 END IF 253 END IF 254 END IF 255 next = NXTASK(nprocs,1) 256 END IF 257 count = count + 1 258 END DO 259 END DO 260 END DO 261 END DO 262 END DO 263 END DO 264 next = NXTASK(-nprocs,1) 265 call GA_SYNC() 266 RETURN 267 END 268 SUBROUTINE ccsdtq_o3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 269 &t) 270C $Id$ 271C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 272C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 273C i0 ( p4 p5 p6 h1 h2 h3 )_to + = 1 * P( 3 ) * Sum ( p7 ) * o ( p4 p7 )_o * t ( p5 p6 p7 h1 h2 h3 )_t 274 IMPLICIT NONE 275#include "global.fh" 276#include "mafdecls.fh" 277#include "sym.fh" 278#include "errquit.fh" 279#include "tce.fh" 280 INTEGER d_a 281 INTEGER k_a_offset 282 INTEGER d_b 283 INTEGER k_b_offset 284 INTEGER d_c 285 INTEGER k_c_offset 286 INTEGER NXTASK 287 INTEGER next 288 INTEGER nprocs 289 INTEGER count 290 INTEGER p4b 291 INTEGER p5b 292 INTEGER p6b 293 INTEGER h1b 294 INTEGER h2b 295 INTEGER h3b 296 INTEGER dimc 297 INTEGER l_c_sort 298 INTEGER k_c_sort 299 INTEGER p7b 300 INTEGER p4b_1 301 INTEGER p7b_1 302 INTEGER p5b_2 303 INTEGER p6b_2 304 INTEGER p7b_2 305 INTEGER h1b_2 306 INTEGER h2b_2 307 INTEGER h3b_2 308 INTEGER dim_common 309 INTEGER dima_sort 310 INTEGER dima 311 INTEGER dimb_sort 312 INTEGER dimb 313 INTEGER l_a_sort 314 INTEGER k_a_sort 315 INTEGER l_a 316 INTEGER k_a 317 INTEGER l_b_sort 318 INTEGER k_b_sort 319 INTEGER l_b 320 INTEGER k_b 321 INTEGER l_c 322 INTEGER k_c 323 EXTERNAL NXTASK 324 nprocs = GA_NNODES() 325 count = 0 326 next = NXTASK(nprocs,1) 327 DO p4b = noab+1,noab+nvab 328 DO p5b = noab+1,noab+nvab 329 DO p6b = p5b,noab+nvab 330 DO h1b = 1,noab 331 DO h2b = h1b,noab 332 DO h3b = h2b,noab 333 IF (next.eq.count) THEN 334 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 335 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 336 &nt_mb(k_spin+h3b-1).ne.12)) THEN 337 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 338 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 339 &1)) THEN 340 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 341 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 342 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_t,irrep_o)) THEN 343 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 344 &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 345 &b(k_range+h3b-1) 346 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 347 & ERRQUIT('ccsdtq_o3_2',0,MA_ERR) 348 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 349 DO p7b = noab+1,noab+nvab 350 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+p7b-1)) THEN 351 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+p7b-1)) .eq. irrep_o) TH 352 &EN 353 CALL TCE_RESTRICTED_2(p4b,p7b,p4b_1,p7b_1) 354 CALL TCE_RESTRICTED_6(p5b,p6b,p7b,h1b,h2b,h3b,p5b_2,p6b_2,p7b_2,h1 355 &b_2,h2b_2,h3b_2) 356 dim_common = int_mb(k_range+p7b-1) 357 dima_sort = int_mb(k_range+p4b-1) 358 dima = dim_common * dima_sort 359 dimb_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb 360 &(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_mb(k_range+h3b-1) 361 dimb = dim_common * dimb_sort 362 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 363 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 364 & ERRQUIT('ccsdtq_o3_2',1,MA_ERR) 365 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 366 &ccsdtq_o3_2',2,MA_ERR) 367 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p7b_1 368 & - 1 + (noab+nvab) * (p4b_1 - 1))) 369 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 370 &,int_mb(k_range+p7b-1),1,2,1.0d0) 371 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o3_2',3,MA_ERR) 372 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 373 & ERRQUIT('ccsdtq_o3_2',4,MA_ERR) 374 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 375 &ccsdtq_o3_2',5,MA_ERR) 376 IF ((p7b .lt. p5b)) THEN 377 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 378 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (p6b_2 - noa 379 &b - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p7b_2 - noab - 1))))))) 380 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p7b-1) 381 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 382 &,int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,4,3,2,1,1.0d0) 383 END IF 384 IF ((p5b .le. p7b) .and. (p7b .lt. p6b)) THEN 385 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 386 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (p6b_2 - noa 387 &b - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p5b_2 - noab - 1))))))) 388 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 389 &,int_mb(k_range+p7b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 390 &,int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,4,3,1,2,-1.0d0) 391 END IF 392 IF ((p6b .le. p7b)) THEN 393 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 394 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (p7b_2 - noa 395 &b - 1 + nvab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1))))))) 396 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 397 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+h1b-1) 398 &,int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,4,2,1,3,1.0d0) 399 END IF 400 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o3_2',6,MA_ERR) 401 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 402 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 403 &t),dima_sort) 404 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o3_2',7,MA_E 405 &RR) 406 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o3_2',8,MA_E 407 &RR) 408 END IF 409 END IF 410 END IF 411 END DO 412 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 413 &ccsdtq_o3_2',9,MA_ERR) 414 IF ((p4b .le. p5b)) THEN 415 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 416 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 417 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,4,3,2,1,1.0d0) 418 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 419 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 + 420 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 421 END IF 422 IF ((p5b .le. p4b) .and. (p4b .le. p6b)) THEN 423 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 424 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 425 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),5,6,4,3,2,1,-1.0d0) 426 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 427 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 + 428 &nvab * (p4b - noab - 1 + nvab * (p5b - noab - 1))))))) 429 END IF 430 IF ((p6b .le. p4b)) THEN 431 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 432 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 433 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),5,4,6,3,2,1,1.0d0) 434 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 435 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + 436 &nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1))))))) 437 END IF 438 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o3_2',10,MA_ERR) 439 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o3_2',11,MA_ 440 &ERR) 441 END IF 442 END IF 443 END IF 444 next = NXTASK(nprocs,1) 445 END IF 446 count = count + 1 447 END DO 448 END DO 449 END DO 450 END DO 451 END DO 452 END DO 453 next = NXTASK(-nprocs,1) 454 call GA_SYNC() 455 RETURN 456 END 457 SUBROUTINE ccsdtq_o3_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 458 &t) 459C $Id$ 460C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 461C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 462C i0 ( p4 p5 p6 h1 h2 h3 )_to + = 1 * Sum ( p8 h7 ) * o ( h7 p8 )_o * t ( p4 p5 p6 p8 h1 h2 h3 h7 )_t 463 IMPLICIT NONE 464#include "global.fh" 465#include "mafdecls.fh" 466#include "sym.fh" 467#include "errquit.fh" 468#include "tce.fh" 469 INTEGER d_a 470 INTEGER k_a_offset 471 INTEGER d_b 472 INTEGER k_b_offset 473 INTEGER d_c 474 INTEGER k_c_offset 475 INTEGER NXTASK 476 INTEGER next 477 INTEGER nprocs 478 INTEGER count 479 INTEGER p4b 480 INTEGER p5b 481 INTEGER p6b 482 INTEGER h1b 483 INTEGER h2b 484 INTEGER h3b 485 INTEGER dimc 486 INTEGER l_c_sort 487 INTEGER k_c_sort 488 INTEGER h7b 489 INTEGER p8b 490 INTEGER h7b_1 491 INTEGER p8b_1 492 INTEGER p4b_2 493 INTEGER p5b_2 494 INTEGER p6b_2 495 INTEGER p8b_2 496 INTEGER h1b_2 497 INTEGER h2b_2 498 INTEGER h3b_2 499 INTEGER h7b_2 500 INTEGER dim_common 501 INTEGER dima_sort 502 INTEGER dima 503 INTEGER dimb_sort 504 INTEGER dimb 505 INTEGER l_a_sort 506 INTEGER k_a_sort 507 INTEGER l_a 508 INTEGER k_a 509 INTEGER l_b_sort 510 INTEGER k_b_sort 511 INTEGER l_b 512 INTEGER k_b 513 INTEGER l_c 514 INTEGER k_c 515 EXTERNAL NXTASK 516 nprocs = GA_NNODES() 517 count = 0 518 next = NXTASK(nprocs,1) 519 DO p4b = noab+1,noab+nvab 520 DO p5b = p4b,noab+nvab 521 DO p6b = p5b,noab+nvab 522 DO h1b = 1,noab 523 DO h2b = h1b,noab 524 DO h3b = h2b,noab 525 IF (next.eq.count) THEN 526 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 527 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 528 &nt_mb(k_spin+h3b-1).ne.12)) THEN 529 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 530 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 531 &1)) THEN 532 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 533 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 534 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_t,irrep_o)) THEN 535 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 536 &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 537 &b(k_range+h3b-1) 538 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 539 & ERRQUIT('ccsdtq_o3_3',0,MA_ERR) 540 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 541 DO h7b = 1,noab 542 DO p8b = noab+1,noab+nvab 543 IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+p8b-1)) THEN 544 IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+p8b-1)) .eq. irrep_o) TH 545 &EN 546 CALL TCE_RESTRICTED_2(h7b,p8b,h7b_1,p8b_1) 547 CALL TCE_RESTRICTED_8(p4b,p5b,p6b,p8b,h1b,h2b,h3b,h7b,p4b_2,p5b_2, 548 &p6b_2,p8b_2,h1b_2,h2b_2,h3b_2,h7b_2) 549 dim_common = int_mb(k_range+h7b-1) * int_mb(k_range+p8b-1) 550 dima_sort = 1 551 dima = dim_common * dima_sort 552 dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb 553 &(k_range+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * 554 &int_mb(k_range+h3b-1) 555 dimb = dim_common * dimb_sort 556 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 557 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 558 & ERRQUIT('ccsdtq_o3_3',1,MA_ERR) 559 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 560 &ccsdtq_o3_3',2,MA_ERR) 561 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1 562 & - 1 + (noab+nvab) * (h7b_1 - 1))) 563 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 564 &,int_mb(k_range+p8b-1),2,1,1.0d0) 565 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o3_3',3,MA_ERR) 566 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 567 & ERRQUIT('ccsdtq_o3_3',4,MA_ERR) 568 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 569 &ccsdtq_o3_3',5,MA_ERR) 570 IF ((p8b .lt. p4b) .and. (h7b .lt. h1b)) THEN 571 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 572 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (h7b_2 - 1 + 573 & noab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p4b 574 &_2 - noab - 1 + nvab * (p8b_2 - noab - 1))))))))) 575 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p8b-1) 576 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 577 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 578 &,int_mb(k_range+h3b-1),8,7,6,4,3,2,1,5,1.0d0) 579 END IF 580 IF ((p8b .lt. p4b) .and. (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 581 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 582 & - 1 + noab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (h1b_2 - 1 + 583 & noab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p4b 584 &_2 - noab - 1 + nvab * (p8b_2 - noab - 1))))))))) 585 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p8b-1) 586 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 587 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1) 588 &,int_mb(k_range+h3b-1),8,7,5,4,3,2,1,6,-1.0d0) 589 END IF 590 IF ((p8b .lt. p4b) .and. (h2b .le. h7b) .and. (h7b .lt. h3b)) THEN 591 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 592 & - 1 + noab * (h7b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 593 & noab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p4b 594 &_2 - noab - 1 + nvab * (p8b_2 - noab - 1))))))))) 595 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p8b-1) 596 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 597 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1) 598 &,int_mb(k_range+h3b-1),8,6,5,4,3,2,1,7,1.0d0) 599 END IF 600 IF ((p8b .lt. p4b) .and. (h3b .le. h7b)) THEN 601 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h7b_2 602 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 603 & noab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p4b 604 &_2 - noab - 1 + nvab * (p8b_2 - noab - 1))))))))) 605 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p8b-1) 606 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 607 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 608 &,int_mb(k_range+h7b-1),7,6,5,4,3,2,1,8,-1.0d0) 609 END IF 610 IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (h7b .lt. h1b)) THEN 611 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 612 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (h7b_2 - 1 + 613 & noab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p8b 614 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 615 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 616 &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 617 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 618 &,int_mb(k_range+h3b-1),8,7,6,4,3,1,2,5,-1.0d0) 619 END IF 620 IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (h1b .le. h7b) .and. 621 & (h7b .lt. h2b)) THEN 622 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 623 & - 1 + noab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (h1b_2 - 1 + 624 & noab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p8b 625 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 626 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 627 &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 628 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1) 629 &,int_mb(k_range+h3b-1),8,7,5,4,3,1,2,6,1.0d0) 630 END IF 631 IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (h2b .le. h7b) .and. 632 & (h7b .lt. h3b)) THEN 633 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 634 & - 1 + noab * (h7b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 635 & noab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p8b 636 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 637 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 638 &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 639 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1) 640 &,int_mb(k_range+h3b-1),8,6,5,4,3,1,2,7,-1.0d0) 641 END IF 642 IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (h3b .le. h7b)) THEN 643 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h7b_2 644 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 645 & noab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p8b 646 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 647 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 648 &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 649 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 650 &,int_mb(k_range+h7b-1),7,6,5,4,3,1,2,8,1.0d0) 651 END IF 652 IF ((p5b .le. p8b) .and. (p8b .lt. p6b) .and. (h7b .lt. h1b)) THEN 653 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 654 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (h7b_2 - 1 + 655 & noab * (p6b_2 - noab - 1 + nvab * (p8b_2 - noab - 1 + nvab * (p5b 656 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 657 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 658 &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1) 659 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 660 &,int_mb(k_range+h3b-1),8,7,6,4,2,1,3,5,1.0d0) 661 END IF 662 IF ((p5b .le. p8b) .and. (p8b .lt. p6b) .and. (h1b .le. h7b) .and. 663 & (h7b .lt. h2b)) THEN 664 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 665 & - 1 + noab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (h1b_2 - 1 + 666 & noab * (p6b_2 - noab - 1 + nvab * (p8b_2 - noab - 1 + nvab * (p5b 667 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 668 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 669 &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1) 670 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1) 671 &,int_mb(k_range+h3b-1),8,7,5,4,2,1,3,6,-1.0d0) 672 END IF 673 IF ((p5b .le. p8b) .and. (p8b .lt. p6b) .and. (h2b .le. h7b) .and. 674 & (h7b .lt. h3b)) THEN 675 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 676 & - 1 + noab * (h7b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 677 & noab * (p6b_2 - noab - 1 + nvab * (p8b_2 - noab - 1 + nvab * (p5b 678 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 679 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 680 &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1) 681 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1) 682 &,int_mb(k_range+h3b-1),8,6,5,4,2,1,3,7,1.0d0) 683 END IF 684 IF ((p5b .le. p8b) .and. (p8b .lt. p6b) .and. (h3b .le. h7b)) THEN 685 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h7b_2 686 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 687 & noab * (p6b_2 - noab - 1 + nvab * (p8b_2 - noab - 1 + nvab * (p5b 688 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 689 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 690 &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1) 691 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 692 &,int_mb(k_range+h7b-1),7,6,5,4,2,1,3,8,-1.0d0) 693 END IF 694 IF ((p6b .le. p8b) .and. (h7b .lt. h1b)) THEN 695 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 696 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (h7b_2 - 1 + 697 & noab * (p8b_2 - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (p5b 698 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 699 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 700 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1) 701 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 702 &,int_mb(k_range+h3b-1),8,7,6,3,2,1,4,5,-1.0d0) 703 END IF 704 IF ((p6b .le. p8b) .and. (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 705 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 706 & - 1 + noab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (h1b_2 - 1 + 707 & noab * (p8b_2 - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (p5b 708 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 709 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 710 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1) 711 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1) 712 &,int_mb(k_range+h3b-1),8,7,5,3,2,1,4,6,1.0d0) 713 END IF 714 IF ((p6b .le. p8b) .and. (h2b .le. h7b) .and. (h7b .lt. h3b)) THEN 715 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 716 & - 1 + noab * (h7b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 717 & noab * (p8b_2 - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (p5b 718 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 719 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 720 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1) 721 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1) 722 &,int_mb(k_range+h3b-1),8,6,5,3,2,1,4,7,-1.0d0) 723 END IF 724 IF ((p6b .le. p8b) .and. (h3b .le. h7b)) THEN 725 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h7b_2 726 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 727 & noab * (p8b_2 - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (p5b 728 &_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))))) 729 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 730 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1) 731 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 732 &,int_mb(k_range+h7b-1),7,6,5,3,2,1,4,8,1.0d0) 733 END IF 734 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o3_3',6,MA_ERR) 735 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 736 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 737 &t),dima_sort) 738 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o3_3',7,MA_E 739 &RR) 740 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o3_3',8,MA_E 741 &RR) 742 END IF 743 END IF 744 END IF 745 END DO 746 END DO 747 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 748 &ccsdtq_o3_3',9,MA_ERR) 749 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 750 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 751 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,4,3,2,1,1.0d0) 752 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 753 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 + 754 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 755 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o3_3',10,MA_ERR) 756 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o3_3',11,MA_ 757 &ERR) 758 END IF 759 END IF 760 END IF 761 next = NXTASK(nprocs,1) 762 END IF 763 count = count + 1 764 END DO 765 END DO 766 END DO 767 END DO 768 END DO 769 END DO 770 next = NXTASK(-nprocs,1) 771 call GA_SYNC() 772 RETURN 773 END 774 SUBROUTINE ccsdtq_o3_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 775 &t) 776C $Id$ 777C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 778C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 779C i0 ( p4 p5 p6 h1 h2 h3 )_ott + = -1 * P( 3 ) * Sum ( h7 ) * t ( p4 p5 p6 h1 h2 h7 )_t * i1 ( h7 h3 )_ot 780 IMPLICIT NONE 781#include "global.fh" 782#include "mafdecls.fh" 783#include "sym.fh" 784#include "errquit.fh" 785#include "tce.fh" 786 INTEGER d_a 787 INTEGER k_a_offset 788 INTEGER d_b 789 INTEGER k_b_offset 790 INTEGER d_c 791 INTEGER k_c_offset 792 INTEGER NXTASK 793 INTEGER next 794 INTEGER nprocs 795 INTEGER count 796 INTEGER p4b 797 INTEGER p5b 798 INTEGER p6b 799 INTEGER h1b 800 INTEGER h2b 801 INTEGER h3b 802 INTEGER dimc 803 INTEGER l_c_sort 804 INTEGER k_c_sort 805 INTEGER h7b 806 INTEGER p4b_1 807 INTEGER p5b_1 808 INTEGER p6b_1 809 INTEGER h1b_1 810 INTEGER h2b_1 811 INTEGER h7b_1 812 INTEGER h7b_2 813 INTEGER h3b_2 814 INTEGER dim_common 815 INTEGER dima_sort 816 INTEGER dima 817 INTEGER dimb_sort 818 INTEGER dimb 819 INTEGER l_a_sort 820 INTEGER k_a_sort 821 INTEGER l_a 822 INTEGER k_a 823 INTEGER l_b_sort 824 INTEGER k_b_sort 825 INTEGER l_b 826 INTEGER k_b 827 INTEGER l_c 828 INTEGER k_c 829 EXTERNAL NXTASK 830 nprocs = GA_NNODES() 831 count = 0 832 next = NXTASK(nprocs,1) 833 DO p4b = noab+1,noab+nvab 834 DO p5b = p4b,noab+nvab 835 DO p6b = p5b,noab+nvab 836 DO h1b = 1,noab 837 DO h2b = h1b,noab 838 DO h3b = 1,noab 839 IF (next.eq.count) THEN 840 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 841 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 842 &nt_mb(k_spin+h3b-1).ne.12)) THEN 843 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 844 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 845 &1)) THEN 846 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 847 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 848 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_o,ieor(irrep_t,irrep_t))) TH 849 &EN 850 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 851 &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 852 &b(k_range+h3b-1) 853 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 854 & ERRQUIT('ccsdtq_o3_4',0,MA_ERR) 855 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 856 DO h7b = 1,noab 857 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 858 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b- 859 &1)) THEN 860 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 861 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 862 &_mb(k_sym+h7b-1)))))) .eq. irrep_t) THEN 863 CALL TCE_RESTRICTED_6(p4b,p5b,p6b,h1b,h2b,h7b,p4b_1,p5b_1,p6b_1,h1 864 &b_1,h2b_1,h7b_1) 865 CALL TCE_RESTRICTED_2(h7b,h3b,h7b_2,h3b_2) 866 dim_common = int_mb(k_range+h7b-1) 867 dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb 868 &(k_range+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 869 dima = dim_common * dima_sort 870 dimb_sort = int_mb(k_range+h3b-1) 871 dimb = dim_common * dimb_sort 872 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 873 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 874 & ERRQUIT('ccsdtq_o3_4',1,MA_ERR) 875 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 876 &ccsdtq_o3_4',2,MA_ERR) 877 IF ((h7b .lt. h1b)) THEN 878 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 879 & - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + noab * (p6b_1 - noa 880 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))) 881 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 882 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h7b-1) 883 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,3,2,1,4,1.0d0) 884 END IF 885 IF ((h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 886 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 887 & - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noa 888 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))) 889 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 890 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 891 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),6,4,3,2,1,5,-1.0d0) 892 END IF 893 IF ((h2b .le. h7b)) THEN 894 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 895 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noa 896 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))) 897 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 898 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 899 &,int_mb(k_range+h2b-1),int_mb(k_range+h7b-1),5,4,3,2,1,6,1.0d0) 900 END IF 901 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o3_4',3,MA_ERR) 902 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 903 & ERRQUIT('ccsdtq_o3_4',4,MA_ERR) 904 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 905 &ccsdtq_o3_4',5,MA_ERR) 906 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 907 & - 1 + noab * (h7b_2 - 1))) 908 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 909 &,int_mb(k_range+h3b-1),2,1,1.0d0) 910 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o3_4',6,MA_ERR) 911 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 912 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 913 &t),dima_sort) 914 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o3_4',7,MA_E 915 &RR) 916 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o3_4',8,MA_E 917 &RR) 918 END IF 919 END IF 920 END IF 921 END DO 922 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 923 &ccsdtq_o3_4',9,MA_ERR) 924 IF ((h2b .le. h3b)) THEN 925 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 926 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 927 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,4,3,2,1,-1.0d0) 928 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 929 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 + 930 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 931 END IF 932 IF ((h3b .le. h1b)) THEN 933 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 934 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 935 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,4,1,3,2,-1.0d0) 936 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 937 & 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * (p6b - noab - 1 + 938 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 939 END IF 940 IF ((h1b .le. h3b) .and. (h3b .le. h2b)) THEN 941 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 942 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 943 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,4,3,1,2,1.0d0) 944 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 945 & 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 + 946 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 947 END IF 948 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o3_4',10,MA_ERR) 949 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o3_4',11,MA_ 950 &ERR) 951 END IF 952 END IF 953 END IF 954 next = NXTASK(nprocs,1) 955 END IF 956 count = count + 1 957 END DO 958 END DO 959 END DO 960 END DO 961 END DO 962 END DO 963 next = NXTASK(-nprocs,1) 964 call GA_SYNC() 965 RETURN 966 END 967 SUBROUTINE ccsdtq_o3_4_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 968 &set) 969C $Id$ 970C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 971C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 972C i1 ( h7 h1 )_ot + = 1 * Sum ( p8 ) * o ( h7 p8 )_o * t ( p8 h1 )_t 973 IMPLICIT NONE 974#include "global.fh" 975#include "mafdecls.fh" 976#include "sym.fh" 977#include "errquit.fh" 978#include "tce.fh" 979 INTEGER d_a 980 INTEGER k_a_offset 981 INTEGER d_b 982 INTEGER k_b_offset 983 INTEGER d_c 984 INTEGER k_c_offset 985 INTEGER NXTASK 986 INTEGER next 987 INTEGER nprocs 988 INTEGER count 989 INTEGER h7b 990 INTEGER h1b 991 INTEGER dimc 992 INTEGER l_c_sort 993 INTEGER k_c_sort 994 INTEGER p8b 995 INTEGER h7b_1 996 INTEGER p8b_1 997 INTEGER p8b_2 998 INTEGER h1b_2 999 INTEGER dim_common 1000 INTEGER dima_sort 1001 INTEGER dima 1002 INTEGER dimb_sort 1003 INTEGER dimb 1004 INTEGER l_a_sort 1005 INTEGER k_a_sort 1006 INTEGER l_a 1007 INTEGER k_a 1008 INTEGER l_b_sort 1009 INTEGER k_b_sort 1010 INTEGER l_b 1011 INTEGER k_b 1012 INTEGER l_c 1013 INTEGER k_c 1014 EXTERNAL NXTASK 1015 nprocs = GA_NNODES() 1016 count = 0 1017 next = NXTASK(nprocs,1) 1018 DO h7b = 1,noab 1019 DO h1b = 1,noab 1020 IF (next.eq.count) THEN 1021 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h1b-1 1022 &).ne.4)) THEN 1023 IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1024 IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1025 &o,irrep_t)) THEN 1026 dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h1b-1) 1027 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1028 & ERRQUIT('ccsdtq_o3_4_1',0,MA_ERR) 1029 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1030 DO p8b = noab+1,noab+nvab 1031 IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+p8b-1)) THEN 1032 IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+p8b-1)) .eq. irrep_o) TH 1033 &EN 1034 CALL TCE_RESTRICTED_2(h7b,p8b,h7b_1,p8b_1) 1035 CALL TCE_RESTRICTED_2(p8b,h1b,p8b_2,h1b_2) 1036 dim_common = int_mb(k_range+p8b-1) 1037 dima_sort = int_mb(k_range+h7b-1) 1038 dima = dim_common * dima_sort 1039 dimb_sort = int_mb(k_range+h1b-1) 1040 dimb = dim_common * dimb_sort 1041 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1042 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1043 & ERRQUIT('ccsdtq_o3_4_1',1,MA_ERR) 1044 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1045 &ccsdtq_o3_4_1',2,MA_ERR) 1046 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1 1047 & - 1 + (noab+nvab) * (h7b_1 - 1))) 1048 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 1049 &,int_mb(k_range+p8b-1),1,2,1.0d0) 1050 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o3_4_1',3,MA_ERR) 1051 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1052 & ERRQUIT('ccsdtq_o3_4_1',4,MA_ERR) 1053 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1054 &ccsdtq_o3_4_1',5,MA_ERR) 1055 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 1056 & - 1 + noab * (p8b_2 - noab - 1))) 1057 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p8b-1) 1058 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1059 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o3_4_1',6,MA_ERR) 1060 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1061 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1062 &t),dima_sort) 1063 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o3_4_1',7,MA 1064 &_ERR) 1065 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o3_4_1',8,MA 1066 &_ERR) 1067 END IF 1068 END IF 1069 END IF 1070 END DO 1071 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1072 &ccsdtq_o3_4_1',9,MA_ERR) 1073 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 1074 &,int_mb(k_range+h7b-1),2,1,1.0d0) 1075 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1076 & 1 + noab * (h7b - 1))) 1077 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o3_4_1',10,MA_ERR 1078 &) 1079 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o3_4_1',11,M 1080 &A_ERR) 1081 END IF 1082 END IF 1083 END IF 1084 next = NXTASK(nprocs,1) 1085 END IF 1086 count = count + 1 1087 END DO 1088 END DO 1089 next = NXTASK(-nprocs,1) 1090 call GA_SYNC() 1091 RETURN 1092 END 1093 SUBROUTINE OFFSET_ccsdtq_o3_4_1(l_a_offset,k_a_offset,size) 1094C $Id$ 1095C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1096C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1097C i1 ( h7 h1 )_ot 1098 IMPLICIT NONE 1099#include "global.fh" 1100#include "mafdecls.fh" 1101#include "sym.fh" 1102#include "errquit.fh" 1103#include "tce.fh" 1104 INTEGER l_a_offset 1105 INTEGER k_a_offset 1106 INTEGER size 1107 INTEGER length 1108 INTEGER addr 1109 INTEGER h7b 1110 INTEGER h1b 1111 length = 0 1112 DO h7b = 1,noab 1113 DO h1b = 1,noab 1114 IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1115 IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1116 &o,irrep_t)) THEN 1117 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h1b-1 1118 &).ne.4)) THEN 1119 length = length + 1 1120 END IF 1121 END IF 1122 END IF 1123 END DO 1124 END DO 1125 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1126 &set)) CALL ERRQUIT('ccsdtq_o3_4_1',0,MA_ERR) 1127 int_mb(k_a_offset) = length 1128 addr = 0 1129 size = 0 1130 DO h7b = 1,noab 1131 DO h1b = 1,noab 1132 IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1133 IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1134 &o,irrep_t)) THEN 1135 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h1b-1 1136 &).ne.4)) THEN 1137 addr = addr + 1 1138 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h7b - 1) 1139 int_mb(k_a_offset+length+addr) = size 1140 size = size + int_mb(k_range+h7b-1) * int_mb(k_range+h1b-1) 1141 END IF 1142 END IF 1143 END IF 1144 END DO 1145 END DO 1146 RETURN 1147 END 1148 SUBROUTINE ccsdtq_o3_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 1149 &t) 1150C $Id$ 1151C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1152C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1153C i0 ( p4 p5 p6 h1 h2 h3 )_ott + = -1 * P( 3 ) * Sum ( h7 ) * t ( p4 h7 )_t * i1 ( h7 p5 p6 h1 h2 h3 )_ot 1154 IMPLICIT NONE 1155#include "global.fh" 1156#include "mafdecls.fh" 1157#include "sym.fh" 1158#include "errquit.fh" 1159#include "tce.fh" 1160 INTEGER d_a 1161 INTEGER k_a_offset 1162 INTEGER d_b 1163 INTEGER k_b_offset 1164 INTEGER d_c 1165 INTEGER k_c_offset 1166 INTEGER NXTASK 1167 INTEGER next 1168 INTEGER nprocs 1169 INTEGER count 1170 INTEGER p4b 1171 INTEGER p5b 1172 INTEGER p6b 1173 INTEGER h1b 1174 INTEGER h2b 1175 INTEGER h3b 1176 INTEGER dimc 1177 INTEGER l_c_sort 1178 INTEGER k_c_sort 1179 INTEGER h7b 1180 INTEGER p4b_1 1181 INTEGER h7b_1 1182 INTEGER p5b_2 1183 INTEGER p6b_2 1184 INTEGER h7b_2 1185 INTEGER h1b_2 1186 INTEGER h2b_2 1187 INTEGER h3b_2 1188 INTEGER dim_common 1189 INTEGER dima_sort 1190 INTEGER dima 1191 INTEGER dimb_sort 1192 INTEGER dimb 1193 INTEGER l_a_sort 1194 INTEGER k_a_sort 1195 INTEGER l_a 1196 INTEGER k_a 1197 INTEGER l_b_sort 1198 INTEGER k_b_sort 1199 INTEGER l_b 1200 INTEGER k_b 1201 INTEGER l_c 1202 INTEGER k_c 1203 EXTERNAL NXTASK 1204 nprocs = GA_NNODES() 1205 count = 0 1206 next = NXTASK(nprocs,1) 1207 DO p4b = noab+1,noab+nvab 1208 DO p5b = noab+1,noab+nvab 1209 DO p6b = p5b,noab+nvab 1210 DO h1b = 1,noab 1211 DO h2b = h1b,noab 1212 DO h3b = h2b,noab 1213 IF (next.eq.count) THEN 1214 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 1215 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 1216 &nt_mb(k_spin+h3b-1).ne.12)) THEN 1217 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 1218 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 1219 &1)) THEN 1220 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 1221 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 1222 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_o,ieor(irrep_t,irrep_t))) TH 1223 &EN 1224 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 1225 &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 1226 &b(k_range+h3b-1) 1227 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1228 & ERRQUIT('ccsdtq_o3_5',0,MA_ERR) 1229 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1230 DO h7b = 1,noab 1231 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h7b-1)) THEN 1232 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 1233 &EN 1234 CALL TCE_RESTRICTED_2(p4b,h7b,p4b_1,h7b_1) 1235 CALL TCE_RESTRICTED_6(p5b,p6b,h7b,h1b,h2b,h3b,p5b_2,p6b_2,h7b_2,h1 1236 &b_2,h2b_2,h3b_2) 1237 dim_common = int_mb(k_range+h7b-1) 1238 dima_sort = int_mb(k_range+p4b-1) 1239 dima = dim_common * dima_sort 1240 dimb_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb 1241 &(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_mb(k_range+h3b-1) 1242 dimb = dim_common * dimb_sort 1243 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1244 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1245 & ERRQUIT('ccsdtq_o3_5',1,MA_ERR) 1246 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1247 &ccsdtq_o3_5',2,MA_ERR) 1248 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 1249 & - 1 + noab * (p4b_1 - noab - 1))) 1250 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 1251 &,int_mb(k_range+h7b-1),1,2,1.0d0) 1252 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o3_5',3,MA_ERR) 1253 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1254 & ERRQUIT('ccsdtq_o3_5',4,MA_ERR) 1255 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1256 &ccsdtq_o3_5',5,MA_ERR) 1257 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 1258 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (h7b_2 - 1 + 1259 & noab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1))))))) 1260 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 1261 &,int_mb(k_range+p6b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 1262 &,int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,4,2,1,3,1.0d0) 1263 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o3_5',6,MA_ERR) 1264 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1265 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1266 &t),dima_sort) 1267 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o3_5',7,MA_E 1268 &RR) 1269 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o3_5',8,MA_E 1270 &RR) 1271 END IF 1272 END IF 1273 END IF 1274 END DO 1275 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1276 &ccsdtq_o3_5',9,MA_ERR) 1277 IF ((p4b .le. p5b)) THEN 1278 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1279 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 1280 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,4,3,2,1,-1.0d0) 1281 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 1282 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 + 1283 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 1284 END IF 1285 IF ((p5b .le. p4b) .and. (p4b .le. p6b)) THEN 1286 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1287 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 1288 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),5,6,4,3,2,1,1.0d0) 1289 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 1290 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 + 1291 &nvab * (p4b - noab - 1 + nvab * (p5b - noab - 1))))))) 1292 END IF 1293 IF ((p6b .le. p4b)) THEN 1294 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1295 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 1296 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),5,4,6,3,2,1,-1.0d0) 1297 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 1298 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + 1299 &nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1))))))) 1300 END IF 1301 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o3_5',10,MA_ERR) 1302 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o3_5',11,MA_ 1303 &ERR) 1304 END IF 1305 END IF 1306 END IF 1307 next = NXTASK(nprocs,1) 1308 END IF 1309 count = count + 1 1310 END DO 1311 END DO 1312 END DO 1313 END DO 1314 END DO 1315 END DO 1316 next = NXTASK(-nprocs,1) 1317 call GA_SYNC() 1318 RETURN 1319 END 1320 SUBROUTINE ccsdtq_o3_5_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 1321 &set) 1322C $Id$ 1323C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1324C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1325C i1 ( h7 p4 p5 h1 h2 h3 )_ot + = 1 * Sum ( p8 ) * o ( h7 p8 )_o * t ( p4 p5 p8 h1 h2 h3 )_t 1326 IMPLICIT NONE 1327#include "global.fh" 1328#include "mafdecls.fh" 1329#include "sym.fh" 1330#include "errquit.fh" 1331#include "tce.fh" 1332 INTEGER d_a 1333 INTEGER k_a_offset 1334 INTEGER d_b 1335 INTEGER k_b_offset 1336 INTEGER d_c 1337 INTEGER k_c_offset 1338 INTEGER NXTASK 1339 INTEGER next 1340 INTEGER nprocs 1341 INTEGER count 1342 INTEGER p4b 1343 INTEGER p5b 1344 INTEGER h7b 1345 INTEGER h1b 1346 INTEGER h2b 1347 INTEGER h3b 1348 INTEGER dimc 1349 INTEGER l_c_sort 1350 INTEGER k_c_sort 1351 INTEGER p8b 1352 INTEGER h7b_1 1353 INTEGER p8b_1 1354 INTEGER p4b_2 1355 INTEGER p5b_2 1356 INTEGER p8b_2 1357 INTEGER h1b_2 1358 INTEGER h2b_2 1359 INTEGER h3b_2 1360 INTEGER dim_common 1361 INTEGER dima_sort 1362 INTEGER dima 1363 INTEGER dimb_sort 1364 INTEGER dimb 1365 INTEGER l_a_sort 1366 INTEGER k_a_sort 1367 INTEGER l_a 1368 INTEGER k_a 1369 INTEGER l_b_sort 1370 INTEGER k_b_sort 1371 INTEGER l_b 1372 INTEGER k_b 1373 INTEGER l_c 1374 INTEGER k_c 1375 EXTERNAL NXTASK 1376 nprocs = GA_NNODES() 1377 count = 0 1378 next = NXTASK(nprocs,1) 1379 DO p4b = noab+1,noab+nvab 1380 DO p5b = p4b,noab+nvab 1381 DO h7b = 1,noab 1382 DO h1b = 1,noab 1383 DO h2b = h1b,noab 1384 DO h3b = h2b,noab 1385 IF (next.eq.count) THEN 1386 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 1387 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 1388 &nt_mb(k_spin+h3b-1).ne.12)) THEN 1389 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+h7b-1) 1390 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 1391 &1)) THEN 1392 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 1393 &k_sym+h7b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 1394 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_o,irrep_t)) THEN 1395 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 1396 &nge+h7b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 1397 &b(k_range+h3b-1) 1398 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1399 & ERRQUIT('ccsdtq_o3_5_1',0,MA_ERR) 1400 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1401 DO p8b = noab+1,noab+nvab 1402 IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+p8b-1)) THEN 1403 IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+p8b-1)) .eq. irrep_o) TH 1404 &EN 1405 CALL TCE_RESTRICTED_2(h7b,p8b,h7b_1,p8b_1) 1406 CALL TCE_RESTRICTED_6(p4b,p5b,p8b,h1b,h2b,h3b,p4b_2,p5b_2,p8b_2,h1 1407 &b_2,h2b_2,h3b_2) 1408 dim_common = int_mb(k_range+p8b-1) 1409 dima_sort = int_mb(k_range+h7b-1) 1410 dima = dim_common * dima_sort 1411 dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb 1412 &(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_mb(k_range+h3b-1) 1413 dimb = dim_common * dimb_sort 1414 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1415 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1416 & ERRQUIT('ccsdtq_o3_5_1',1,MA_ERR) 1417 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1418 &ccsdtq_o3_5_1',2,MA_ERR) 1419 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1 1420 & - 1 + (noab+nvab) * (h7b_1 - 1))) 1421 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 1422 &,int_mb(k_range+p8b-1),1,2,1.0d0) 1423 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o3_5_1',3,MA_ERR) 1424 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1425 & ERRQUIT('ccsdtq_o3_5_1',4,MA_ERR) 1426 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1427 &ccsdtq_o3_5_1',5,MA_ERR) 1428 IF ((p8b .lt. p4b)) THEN 1429 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 1430 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (p5b_2 - noa 1431 &b - 1 + nvab * (p4b_2 - noab - 1 + nvab * (p8b_2 - noab - 1))))))) 1432 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p8b-1) 1433 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+h1b-1) 1434 &,int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,4,3,2,1,1.0d0) 1435 END IF 1436 IF ((p4b .le. p8b) .and. (p8b .lt. p5b)) THEN 1437 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 1438 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (p5b_2 - noa 1439 &b - 1 + nvab * (p8b_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))) 1440 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 1441 &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+h1b-1) 1442 &,int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,4,3,1,2,-1.0d0) 1443 END IF 1444 IF ((p5b .le. p8b)) THEN 1445 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 1446 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (p8b_2 - noa 1447 &b - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p4b_2 - noab - 1))))))) 1448 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 1449 &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+h1b-1) 1450 &,int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,4,2,1,3,1.0d0) 1451 END IF 1452 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o3_5_1',6,MA_ERR) 1453 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1454 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1455 &t),dima_sort) 1456 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o3_5_1',7,MA 1457 &_ERR) 1458 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o3_5_1',8,MA 1459 &_ERR) 1460 END IF 1461 END IF 1462 END IF 1463 END DO 1464 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1465 &ccsdtq_o3_5_1',9,MA_ERR) 1466 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1467 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1) 1468 &,int_mb(k_range+p4b-1),int_mb(k_range+h7b-1),5,4,6,3,2,1,1.0d0) 1469 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 1470 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (h7b - 1 + noab * 1471 &(p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 1472 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o3_5_1',10,MA_ERR 1473 &) 1474 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o3_5_1',11,M 1475 &A_ERR) 1476 END IF 1477 END IF 1478 END IF 1479 next = NXTASK(nprocs,1) 1480 END IF 1481 count = count + 1 1482 END DO 1483 END DO 1484 END DO 1485 END DO 1486 END DO 1487 END DO 1488 next = NXTASK(-nprocs,1) 1489 call GA_SYNC() 1490 RETURN 1491 END 1492 SUBROUTINE OFFSET_ccsdtq_o3_5_1(l_a_offset,k_a_offset,size) 1493C $Id$ 1494C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1495C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1496C i1 ( h7 p4 p5 h1 h2 h3 )_ot 1497 IMPLICIT NONE 1498#include "global.fh" 1499#include "mafdecls.fh" 1500#include "sym.fh" 1501#include "errquit.fh" 1502#include "tce.fh" 1503 INTEGER l_a_offset 1504 INTEGER k_a_offset 1505 INTEGER size 1506 INTEGER length 1507 INTEGER addr 1508 INTEGER p4b 1509 INTEGER p5b 1510 INTEGER h7b 1511 INTEGER h1b 1512 INTEGER h2b 1513 INTEGER h3b 1514 length = 0 1515 DO p4b = noab+1,noab+nvab 1516 DO p5b = p4b,noab+nvab 1517 DO h7b = 1,noab 1518 DO h1b = 1,noab 1519 DO h2b = h1b,noab 1520 DO h3b = h2b,noab 1521 IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) 1522 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 1523 &1)) THEN 1524 IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 1525 &k_sym+p5b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 1526 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_o,irrep_t)) THEN 1527 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+p4b-1 1528 &)+int_mb(k_spin+p5b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 1529 &nt_mb(k_spin+h3b-1).ne.12)) THEN 1530 length = length + 1 1531 END IF 1532 END IF 1533 END IF 1534 END DO 1535 END DO 1536 END DO 1537 END DO 1538 END DO 1539 END DO 1540 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1541 &set)) CALL ERRQUIT('ccsdtq_o3_5_1',0,MA_ERR) 1542 int_mb(k_a_offset) = length 1543 addr = 0 1544 size = 0 1545 DO p4b = noab+1,noab+nvab 1546 DO p5b = p4b,noab+nvab 1547 DO h7b = 1,noab 1548 DO h1b = 1,noab 1549 DO h2b = h1b,noab 1550 DO h3b = h2b,noab 1551 IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) 1552 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 1553 &1)) THEN 1554 IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 1555 &k_sym+p5b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 1556 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_o,irrep_t)) THEN 1557 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+p4b-1 1558 &)+int_mb(k_spin+p5b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 1559 &nt_mb(k_spin+h3b-1).ne.12)) THEN 1560 addr = addr + 1 1561 int_mb(k_a_offset+addr) = h3b - 1 + noab * (h2b - 1 + noab * (h1b 1562 &- 1 + noab * (h7b - 1 + noab * (p5b - noab - 1 + nvab * (p4b - noa 1563 &b - 1))))) 1564 int_mb(k_a_offset+length+addr) = size 1565 size = size + int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_ 1566 &mb(k_range+h7b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 1567 &* int_mb(k_range+h3b-1) 1568 END IF 1569 END IF 1570 END IF 1571 END DO 1572 END DO 1573 END DO 1574 END DO 1575 END DO 1576 END DO 1577 RETURN 1578 END 1579 SUBROUTINE ccsdtq_o3_6(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 1580 &t) 1581C $Id$ 1582C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1583C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1584C i0 ( p4 p5 p6 h1 h2 h3 )_ott + = -1 * P( 9 ) * Sum ( h8 ) * t ( p4 p5 h1 h8 )_t * i1 ( h8 p6 h2 h3 )_ot 1585 IMPLICIT NONE 1586#include "global.fh" 1587#include "mafdecls.fh" 1588#include "sym.fh" 1589#include "errquit.fh" 1590#include "tce.fh" 1591 INTEGER d_a 1592 INTEGER k_a_offset 1593 INTEGER d_b 1594 INTEGER k_b_offset 1595 INTEGER d_c 1596 INTEGER k_c_offset 1597 INTEGER NXTASK 1598 INTEGER next 1599 INTEGER nprocs 1600 INTEGER count 1601 INTEGER p4b 1602 INTEGER p5b 1603 INTEGER p6b 1604 INTEGER h1b 1605 INTEGER h2b 1606 INTEGER h3b 1607 INTEGER dimc 1608 INTEGER l_c_sort 1609 INTEGER k_c_sort 1610 INTEGER h8b 1611 INTEGER p4b_1 1612 INTEGER p5b_1 1613 INTEGER h1b_1 1614 INTEGER h8b_1 1615 INTEGER p6b_2 1616 INTEGER h8b_2 1617 INTEGER h2b_2 1618 INTEGER h3b_2 1619 INTEGER dim_common 1620 INTEGER dima_sort 1621 INTEGER dima 1622 INTEGER dimb_sort 1623 INTEGER dimb 1624 INTEGER l_a_sort 1625 INTEGER k_a_sort 1626 INTEGER l_a 1627 INTEGER k_a 1628 INTEGER l_b_sort 1629 INTEGER k_b_sort 1630 INTEGER l_b 1631 INTEGER k_b 1632 INTEGER l_c 1633 INTEGER k_c 1634 EXTERNAL NXTASK 1635 nprocs = GA_NNODES() 1636 count = 0 1637 next = NXTASK(nprocs,1) 1638 DO p4b = noab+1,noab+nvab 1639 DO p5b = p4b,noab+nvab 1640 DO p6b = noab+1,noab+nvab 1641 DO h1b = 1,noab 1642 DO h2b = 1,noab 1643 DO h3b = h2b,noab 1644 IF (next.eq.count) THEN 1645 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 1646 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 1647 &nt_mb(k_spin+h3b-1).ne.12)) THEN 1648 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 1649 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 1650 &1)) THEN 1651 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 1652 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 1653 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_o,ieor(irrep_t,irrep_t))) TH 1654 &EN 1655 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 1656 &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 1657 &b(k_range+h3b-1) 1658 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1659 & ERRQUIT('ccsdtq_o3_6',0,MA_ERR) 1660 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1661 DO h8b = 1,noab 1662 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 1663 &1b-1)+int_mb(k_spin+h8b-1)) THEN 1664 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 1665 &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_t) THEN 1666 CALL TCE_RESTRICTED_4(p4b,p5b,h1b,h8b,p4b_1,p5b_1,h1b_1,h8b_1) 1667 CALL TCE_RESTRICTED_4(p6b,h8b,h2b,h3b,p6b_2,h8b_2,h2b_2,h3b_2) 1668 dim_common = int_mb(k_range+h8b-1) 1669 dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb 1670 &(k_range+h1b-1) 1671 dima = dim_common * dima_sort 1672 dimb_sort = int_mb(k_range+p6b-1) * int_mb(k_range+h2b-1) * int_mb 1673 &(k_range+h3b-1) 1674 dimb = dim_common * dimb_sort 1675 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1676 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1677 & ERRQUIT('ccsdtq_o3_6',1,MA_ERR) 1678 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1679 &ccsdtq_o3_6',2,MA_ERR) 1680 IF ((h8b .lt. h1b)) THEN 1681 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1682 & - 1 + noab * (h8b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_ 1683 &1 - noab - 1))))) 1684 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 1685 &,int_mb(k_range+p5b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) 1686 &,4,2,1,3,-1.0d0) 1687 END IF 1688 IF ((h1b .le. h8b)) THEN 1689 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 1690 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_ 1691 &1 - noab - 1))))) 1692 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 1693 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) 1694 &,3,2,1,4,1.0d0) 1695 END IF 1696 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o3_6',3,MA_ERR) 1697 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1698 & ERRQUIT('ccsdtq_o3_6',4,MA_ERR) 1699 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1700 &ccsdtq_o3_6',5,MA_ERR) 1701 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 1702 & - 1 + noab * (h2b_2 - 1 + noab * (h8b_2 - 1 + noab * (p6b_2 - noa 1703 &b - 1))))) 1704 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p6b-1) 1705 &,int_mb(k_range+h8b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 1706 &,4,3,1,2,1.0d0) 1707 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o3_6',6,MA_ERR) 1708 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1709 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1710 &t),dima_sort) 1711 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o3_6',7,MA_E 1712 &RR) 1713 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o3_6',8,MA_E 1714 &RR) 1715 END IF 1716 END IF 1717 END IF 1718 END DO 1719 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1720 &ccsdtq_o3_6',9,MA_ERR) 1721 IF ((p5b .le. p6b) .and. (h1b .le. h2b)) THEN 1722 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1723 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 1724 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,3,4,2,1,-1.0d0) 1725 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 1726 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 + 1727 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 1728 END IF 1729 IF ((p5b .le. p6b) .and. (h2b .le. h1b) .and. (h1b .le. h3b)) THEN 1730 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1731 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 1732 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,3,2,4,1,1.0d0) 1733 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 1734 & 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * (p6b - noab - 1 + 1735 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 1736 END IF 1737 IF ((p5b .le. p6b) .and. (h3b .le. h1b)) THEN 1738 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1739 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 1740 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,3,2,1,4,-1.0d0) 1741 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1742 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (p6b - noab - 1 + 1743 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 1744 END IF 1745 IF ((p6b .le. p4b) .and. (h1b .le. h2b)) THEN 1746 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1747 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 1748 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),3,6,5,4,2,1,-1.0d0) 1749 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 1750 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p5b - noab - 1 + 1751 &nvab * (p4b - noab - 1 + nvab * (p6b - noab - 1))))))) 1752 END IF 1753 IF ((p6b .le. p4b) .and. (h2b .le. h1b) .and. (h1b .le. h3b)) THEN 1754 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1755 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 1756 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),3,6,5,2,4,1,1.0d0) 1757 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 1758 & 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * (p5b - noab - 1 + 1759 &nvab * (p4b - noab - 1 + nvab * (p6b - noab - 1))))))) 1760 END IF 1761 IF ((p6b .le. p4b) .and. (h3b .le. h1b)) THEN 1762 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1763 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 1764 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),3,6,5,2,1,4,-1.0d0) 1765 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1766 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (p5b - noab - 1 + 1767 &nvab * (p4b - noab - 1 + nvab * (p6b - noab - 1))))))) 1768 END IF 1769 IF ((p4b .le. p6b) .and. (p6b .le. p5b) .and. (h1b .le. h2b)) THEN 1770 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1771 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 1772 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,3,5,4,2,1,1.0d0) 1773 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 1774 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p5b - noab - 1 + 1775 &nvab * (p6b - noab - 1 + nvab * (p4b - noab - 1))))))) 1776 END IF 1777 IF ((p4b .le. p6b) .and. (p6b .le. p5b) .and. (h2b .le. h1b) .and. 1778 & (h1b .le. h3b)) THEN 1779 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1780 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 1781 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,3,5,2,4,1,-1.0d0) 1782 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 1783 & 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * (p5b - noab - 1 + 1784 &nvab * (p6b - noab - 1 + nvab * (p4b - noab - 1))))))) 1785 END IF 1786 IF ((p4b .le. p6b) .and. (p6b .le. p5b) .and. (h3b .le. h1b)) THEN 1787 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 1788 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 1789 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,3,5,2,1,4,1.0d0) 1790 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1791 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (p5b - noab - 1 + 1792 &nvab * (p6b - noab - 1 + nvab * (p4b - noab - 1))))))) 1793 END IF 1794 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o3_6',10,MA_ERR) 1795 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o3_6',11,MA_ 1796 &ERR) 1797 END IF 1798 END IF 1799 END IF 1800 next = NXTASK(nprocs,1) 1801 END IF 1802 count = count + 1 1803 END DO 1804 END DO 1805 END DO 1806 END DO 1807 END DO 1808 END DO 1809 next = NXTASK(-nprocs,1) 1810 call GA_SYNC() 1811 RETURN 1812 END 1813 SUBROUTINE ccsdtq_o3_6_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 1814 &set) 1815C $Id$ 1816C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1817C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1818C i1 ( h8 p4 h1 h2 )_ot + = -1 * Sum ( p7 ) * o ( h8 p7 )_o * t ( p4 p7 h1 h2 )_t 1819 IMPLICIT NONE 1820#include "global.fh" 1821#include "mafdecls.fh" 1822#include "sym.fh" 1823#include "errquit.fh" 1824#include "tce.fh" 1825 INTEGER d_a 1826 INTEGER k_a_offset 1827 INTEGER d_b 1828 INTEGER k_b_offset 1829 INTEGER d_c 1830 INTEGER k_c_offset 1831 INTEGER NXTASK 1832 INTEGER next 1833 INTEGER nprocs 1834 INTEGER count 1835 INTEGER p4b 1836 INTEGER h8b 1837 INTEGER h1b 1838 INTEGER h2b 1839 INTEGER dimc 1840 INTEGER l_c_sort 1841 INTEGER k_c_sort 1842 INTEGER p7b 1843 INTEGER h8b_1 1844 INTEGER p7b_1 1845 INTEGER p4b_2 1846 INTEGER p7b_2 1847 INTEGER h1b_2 1848 INTEGER h2b_2 1849 INTEGER dim_common 1850 INTEGER dima_sort 1851 INTEGER dima 1852 INTEGER dimb_sort 1853 INTEGER dimb 1854 INTEGER l_a_sort 1855 INTEGER k_a_sort 1856 INTEGER l_a 1857 INTEGER k_a 1858 INTEGER l_b_sort 1859 INTEGER k_b_sort 1860 INTEGER l_b 1861 INTEGER k_b 1862 INTEGER l_c 1863 INTEGER k_c 1864 EXTERNAL NXTASK 1865 nprocs = GA_NNODES() 1866 count = 0 1867 next = NXTASK(nprocs,1) 1868 DO p4b = noab+1,noab+nvab 1869 DO h8b = 1,noab 1870 DO h1b = 1,noab 1871 DO h2b = h1b,noab 1872 IF (next.eq.count) THEN 1873 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+h8b-1 1874 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1875 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h 1876 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1877 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb( 1878 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_o,irrep_t)) TH 1879 &EN 1880 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+h8b-1) * int_mb(k_ra 1881 &nge+h1b-1) * int_mb(k_range+h2b-1) 1882 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1883 & ERRQUIT('ccsdtq_o3_6_1',0,MA_ERR) 1884 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1885 DO p7b = noab+1,noab+nvab 1886 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p7b-1)) THEN 1887 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p7b-1)) .eq. irrep_o) TH 1888 &EN 1889 CALL TCE_RESTRICTED_2(h8b,p7b,h8b_1,p7b_1) 1890 CALL TCE_RESTRICTED_4(p4b,p7b,h1b,h2b,p4b_2,p7b_2,h1b_2,h2b_2) 1891 dim_common = int_mb(k_range+p7b-1) 1892 dima_sort = int_mb(k_range+h8b-1) 1893 dima = dim_common * dima_sort 1894 dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1) * int_mb 1895 &(k_range+h2b-1) 1896 dimb = dim_common * dimb_sort 1897 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1898 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1899 & ERRQUIT('ccsdtq_o3_6_1',1,MA_ERR) 1900 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1901 &ccsdtq_o3_6_1',2,MA_ERR) 1902 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p7b_1 1903 & - 1 + (noab+nvab) * (h8b_1 - 1))) 1904 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1) 1905 &,int_mb(k_range+p7b-1),1,2,1.0d0) 1906 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o3_6_1',3,MA_ERR) 1907 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1908 & ERRQUIT('ccsdtq_o3_6_1',4,MA_ERR) 1909 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1910 &ccsdtq_o3_6_1',5,MA_ERR) 1911 IF ((p7b .lt. p4b)) THEN 1912 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 1913 & - 1 + noab * (h1b_2 - 1 + noab * (p4b_2 - noab - 1 + nvab * (p7b_ 1914 &2 - noab - 1))))) 1915 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p7b-1) 1916 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 1917 &,4,3,2,1,-1.0d0) 1918 END IF 1919 IF ((p4b .le. p7b)) THEN 1920 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 1921 & - 1 + noab * (h1b_2 - 1 + noab * (p7b_2 - noab - 1 + nvab * (p4b_ 1922 &2 - noab - 1))))) 1923 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 1924 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 1925 &,4,3,1,2,1.0d0) 1926 END IF 1927 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o3_6_1',6,MA_ERR) 1928 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1929 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1930 &t),dima_sort) 1931 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o3_6_1',7,MA 1932 &_ERR) 1933 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o3_6_1',8,MA 1934 &_ERR) 1935 END IF 1936 END IF 1937 END IF 1938 END DO 1939 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1940 &ccsdtq_o3_6_1',9,MA_ERR) 1941 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 1942 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+h8b-1) 1943 &,3,4,2,1,-1.0d0) 1944 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1945 & 1 + noab * (h1b - 1 + noab * (h8b - 1 + noab * (p4b - noab - 1))) 1946 &)) 1947 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o3_6_1',10,MA_ERR 1948 &) 1949 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o3_6_1',11,M 1950 &A_ERR) 1951 END IF 1952 END IF 1953 END IF 1954 next = NXTASK(nprocs,1) 1955 END IF 1956 count = count + 1 1957 END DO 1958 END DO 1959 END DO 1960 END DO 1961 next = NXTASK(-nprocs,1) 1962 call GA_SYNC() 1963 RETURN 1964 END 1965 SUBROUTINE OFFSET_ccsdtq_o3_6_1(l_a_offset,k_a_offset,size) 1966C $Id$ 1967C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1968C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1969C i1 ( h8 p4 h1 h2 )_ot 1970 IMPLICIT NONE 1971#include "global.fh" 1972#include "mafdecls.fh" 1973#include "sym.fh" 1974#include "errquit.fh" 1975#include "tce.fh" 1976 INTEGER l_a_offset 1977 INTEGER k_a_offset 1978 INTEGER size 1979 INTEGER length 1980 INTEGER addr 1981 INTEGER p4b 1982 INTEGER h8b 1983 INTEGER h1b 1984 INTEGER h2b 1985 length = 0 1986 DO p4b = noab+1,noab+nvab 1987 DO h8b = 1,noab 1988 DO h1b = 1,noab 1989 DO h2b = h1b,noab 1990 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 1991 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1992 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 1993 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_o,irrep_t)) TH 1994 &EN 1995 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p4b-1 1996 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1997 length = length + 1 1998 END IF 1999 END IF 2000 END IF 2001 END DO 2002 END DO 2003 END DO 2004 END DO 2005 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2006 &set)) CALL ERRQUIT('ccsdtq_o3_6_1',0,MA_ERR) 2007 int_mb(k_a_offset) = length 2008 addr = 0 2009 size = 0 2010 DO p4b = noab+1,noab+nvab 2011 DO h8b = 1,noab 2012 DO h1b = 1,noab 2013 DO h2b = h1b,noab 2014 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 2015 &1b-1)+int_mb(k_spin+h2b-1)) THEN 2016 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 2017 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_o,irrep_t)) TH 2018 &EN 2019 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p4b-1 2020 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 2021 addr = addr + 1 2022 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h8b 2023 &- 1 + noab * (p4b - noab - 1))) 2024 int_mb(k_a_offset+length+addr) = size 2025 size = size + int_mb(k_range+p4b-1) * int_mb(k_range+h8b-1) * int_ 2026 &mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 2027 END IF 2028 END IF 2029 END IF 2030 END DO 2031 END DO 2032 END DO 2033 END DO 2034 RETURN 2035 END 2036