1 SUBROUTINE ccsdtq_o4(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 ( p5 p6 p7 p8 h1 h2 h3 h4 )_to + = 1 * P( 4 ) * Sum ( h9 ) * o ( h9 h1 )_o * t ( p5 p6 p7 p8 h2 h3 h4 h9 )_t 7C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_to + = -1 * P( 4 ) * Sum ( p9 ) * o ( p5 p9 )_o * t ( p6 p7 p8 p9 h1 h2 h3 h4 )_t 8C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_ott + = -1 * P( 4 ) * Sum ( h9 ) * t ( p5 p6 p7 p8 h1 h2 h3 h9 )_t * i1 ( h9 h4 )_ot 9C i1 ( h9 h1 )_ot + = 1 * Sum ( p10 ) * o ( h9 p10 )_o * t ( p10 h1 )_t 10C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_ott + = -1 * P( 4 ) * Sum ( h9 ) * t ( p5 h9 )_t * i1 ( h9 p6 p7 p8 h1 h2 h3 h4 )_ot 11C i1 ( h9 p5 p6 p7 h1 h2 h3 h4 )_ot + = -1 * Sum ( p10 ) * o ( h9 p10 )_o * t ( p5 p6 p7 p10 h1 h2 h3 h4 )_t 12C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_ott + = -1 * P( 24 ) * Sum ( h9 ) * t ( p5 p6 p7 h1 h2 h9 )_t * i1 ( h9 p8 h3 h4 )_ot 13C i1 ( h9 p5 h1 h2 )_ot + = -1 * Sum ( p10 ) * o ( h9 p10 )_o * t ( p5 p10 h1 h2 )_t 14C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_ott + = -1 * P( 24 ) * Sum ( h9 ) * t ( p5 p6 h1 h9 )_t * i1 ( h9 p7 p8 h2 h3 h4 )_ot 15C i1 ( h9 p5 p6 h1 h2 h3 )_ot + = 1 * Sum ( p10 ) * o ( h9 p10 )_o * t ( p5 p6 p10 h1 h2 h3 )_t 16 IMPLICIT NONE 17#include "global.fh" 18#include "mafdecls.fh" 19#include "util.fh" 20#include "errquit.fh" 21#include "tce.fh" 22 INTEGER d_i0 23 INTEGER k_i0_offset 24 INTEGER d_o1 25 INTEGER k_o1_offset 26 INTEGER d_t4 27 INTEGER k_t4_offset 28 INTEGER d_i1 29 INTEGER k_i1_offset 30 INTEGER d_t1 31 INTEGER k_t1_offset 32 INTEGER d_t3 33 INTEGER k_t3_offset 34 INTEGER d_t2 35 INTEGER k_t2_offset 36 INTEGER l_i1_offset 37 INTEGER size_i1 38 CHARACTER*255 filename 39 CALL ccsdtq_o4_1(d_o1,k_o1_offset,d_t4,k_t4_offset,d_i0,k_i0_offse 40 &t) 41 CALL ccsdtq_o4_2(d_o1,k_o1_offset,d_t4,k_t4_offset,d_i0,k_i0_offse 42 &t) 43 CALL OFFSET_ccsdtq_o4_3_1(l_i1_offset,k_i1_offset,size_i1) 44 CALL TCE_FILENAME('ccsdtq_o4_3_1_i1',filename) 45 CALL CREATEFILE(filename,d_i1,size_i1) 46 CALL ccsdtq_o4_3_1(d_o1,k_o1_offset,d_t1,k_t1_offset,d_i1,k_i1_off 47 &set) 48 CALL RECONCILEFILE(d_i1,size_i1) 49 CALL ccsdtq_o4_3(d_t4,k_t4_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 50 &t) 51 CALL DELETEFILE(d_i1) 52 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdtq_o4',-1,MA 53 &_ERR) 54 CALL OFFSET_ccsdtq_o4_4_1(l_i1_offset,k_i1_offset,size_i1) 55 CALL TCE_FILENAME('ccsdtq_o4_4_1_i1',filename) 56 CALL CREATEFILE(filename,d_i1,size_i1) 57 CALL ccsdtq_o4_4_1(d_o1,k_o1_offset,d_t4,k_t4_offset,d_i1,k_i1_off 58 &set) 59 CALL RECONCILEFILE(d_i1,size_i1) 60 CALL ccsdtq_o4_4(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 61 &t) 62 CALL DELETEFILE(d_i1) 63 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdtq_o4',-1,MA 64 &_ERR) 65 CALL OFFSET_ccsdtq_o4_5_1(l_i1_offset,k_i1_offset,size_i1) 66 CALL TCE_FILENAME('ccsdtq_o4_5_1_i1',filename) 67 CALL CREATEFILE(filename,d_i1,size_i1) 68 CALL ccsdtq_o4_5_1(d_o1,k_o1_offset,d_t2,k_t2_offset,d_i1,k_i1_off 69 &set) 70 CALL RECONCILEFILE(d_i1,size_i1) 71 CALL ccsdtq_o4_5(d_t3,k_t3_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 72 &t) 73 CALL DELETEFILE(d_i1) 74 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdtq_o4',-1,MA 75 &_ERR) 76 CALL OFFSET_ccsdtq_o4_6_1(l_i1_offset,k_i1_offset,size_i1) 77 CALL TCE_FILENAME('ccsdtq_o4_6_1_i1',filename) 78 CALL CREATEFILE(filename,d_i1,size_i1) 79 CALL ccsdtq_o4_6_1(d_o1,k_o1_offset,d_t3,k_t3_offset,d_i1,k_i1_off 80 &set) 81 CALL RECONCILEFILE(d_i1,size_i1) 82 CALL ccsdtq_o4_6(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 83 &t) 84 CALL DELETEFILE(d_i1) 85 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdtq_o4',-1,MA 86 &_ERR) 87 RETURN 88 END 89 SUBROUTINE ccsdtq_o4_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 90 &t) 91C $Id$ 92C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 93C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 94C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_to + = 1 * P( 4 ) * Sum ( h9 ) * o ( h9 h1 )_o * t ( p5 p6 p7 p8 h2 h3 h4 h9 )_t 95 IMPLICIT NONE 96#include "global.fh" 97#include "mafdecls.fh" 98#include "sym.fh" 99#include "errquit.fh" 100#include "tce.fh" 101 INTEGER d_a 102 INTEGER k_a_offset 103 INTEGER d_b 104 INTEGER k_b_offset 105 INTEGER d_c 106 INTEGER k_c_offset 107 INTEGER NXTASK 108 INTEGER next 109 INTEGER nprocs 110 INTEGER count 111 INTEGER p5b 112 INTEGER p6b 113 INTEGER p7b 114 INTEGER p8b 115 INTEGER h1b 116 INTEGER h2b 117 INTEGER h3b 118 INTEGER h4b 119 INTEGER dimc 120 INTEGER l_c_sort 121 INTEGER k_c_sort 122 INTEGER h9b 123 INTEGER h9b_1 124 INTEGER h1b_1 125 INTEGER p5b_2 126 INTEGER p6b_2 127 INTEGER p7b_2 128 INTEGER p8b_2 129 INTEGER h2b_2 130 INTEGER h3b_2 131 INTEGER h4b_2 132 INTEGER h9b_2 133 INTEGER dim_common 134 INTEGER dima_sort 135 INTEGER dima 136 INTEGER dimb_sort 137 INTEGER dimb 138 INTEGER l_a_sort 139 INTEGER k_a_sort 140 INTEGER l_a 141 INTEGER k_a 142 INTEGER l_b_sort 143 INTEGER k_b_sort 144 INTEGER l_b 145 INTEGER k_b 146 INTEGER l_c 147 INTEGER k_c 148 EXTERNAL NXTASK 149 nprocs = GA_NNODES() 150 count = 0 151 next = NXTASK(nprocs,1) 152 DO p5b = noab+1,noab+nvab 153 DO p6b = p5b,noab+nvab 154 DO p7b = p6b,noab+nvab 155 DO p8b = p7b,noab+nvab 156 DO h1b = 1,noab 157 DO h2b = 1,noab 158 DO h3b = h2b,noab 159 DO h4b = h3b,noab 160 IF (next.eq.count) THEN 161 IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1 162 &)+int_mb(k_spin+p7b-1)+int_mb(k_spin+p8b-1)+int_mb(k_spin+h1b-1)+i 163 &nt_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.1 164 &6)) THEN 165 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) 166 &+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 167 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) THEN 168 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 169 &k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h1b-1),ieo 170 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1) 171 &))))))) .eq. ieor(irrep_t,irrep_o)) THEN 172 dimc = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb(k_ra 173 &nge+p7b-1) * int_mb(k_range+p8b-1) * int_mb(k_range+h1b-1) * int_m 174 &b(k_range+h2b-1) * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 175 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 176 & ERRQUIT('ccsdtq_o4_1',0,MA_ERR) 177 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 178 DO h9b = 1,noab 179 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 180 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. irrep_o) TH 181 &EN 182 CALL TCE_RESTRICTED_2(h9b,h1b,h9b_1,h1b_1) 183 CALL TCE_RESTRICTED_8(p5b,p6b,p7b,p8b,h2b,h3b,h4b,h9b,p5b_2,p6b_2, 184 &p7b_2,p8b_2,h2b_2,h3b_2,h4b_2,h9b_2) 185 dim_common = int_mb(k_range+h9b-1) 186 dima_sort = int_mb(k_range+h1b-1) 187 dima = dim_common * dima_sort 188 dimb_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb 189 &(k_range+p7b-1) * int_mb(k_range+p8b-1) * int_mb(k_range+h2b-1) * 190 &int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 191 dimb = dim_common * dimb_sort 192 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 193 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 194 & ERRQUIT('ccsdtq_o4_1',1,MA_ERR) 195 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 196 &ccsdtq_o4_1',2,MA_ERR) 197 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 198 & - 1 + (noab+nvab) * (h9b_1 - 1))) 199 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 200 &,int_mb(k_range+h1b-1),2,1,1.0d0) 201 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o4_1',3,MA_ERR) 202 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 203 & ERRQUIT('ccsdtq_o4_1',4,MA_ERR) 204 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 205 &ccsdtq_o4_1',5,MA_ERR) 206 IF ((h9b .lt. h2b)) THEN 207 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 208 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h9b_2 - 1 + 209 & noab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b 210 &_2 - noab - 1 + nvab * (p5b_2 - noab - 1))))))))) 211 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 212 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 213 &,int_mb(k_range+h9b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 214 &,int_mb(k_range+h4b-1),8,7,6,4,3,2,1,5,-1.0d0) 215 END IF 216 IF ((h2b .le. h9b) .and. (h9b .lt. h3b)) THEN 217 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 218 & - 1 + noab * (h3b_2 - 1 + noab * (h9b_2 - 1 + noab * (h2b_2 - 1 + 219 & noab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b 220 &_2 - noab - 1 + nvab * (p5b_2 - noab - 1))))))))) 221 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 222 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 223 &,int_mb(k_range+h2b-1),int_mb(k_range+h9b-1),int_mb(k_range+h3b-1) 224 &,int_mb(k_range+h4b-1),8,7,5,4,3,2,1,6,1.0d0) 225 END IF 226 IF ((h3b .le. h9b) .and. (h9b .lt. h4b)) THEN 227 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 228 & - 1 + noab * (h9b_2 - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + 229 & noab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b 230 &_2 - noab - 1 + nvab * (p5b_2 - noab - 1))))))))) 231 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 232 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 233 &,int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),int_mb(k_range+h9b-1) 234 &,int_mb(k_range+h4b-1),8,6,5,4,3,2,1,7,-1.0d0) 235 END IF 236 IF ((h4b .le. h9b)) THEN 237 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h9b_2 238 & - 1 + noab * (h4b_2 - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + 239 & noab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b 240 &_2 - noab - 1 + nvab * (p5b_2 - noab - 1))))))))) 241 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 242 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 243 &,int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),int_mb(k_range+h4b-1) 244 &,int_mb(k_range+h9b-1),7,6,5,4,3,2,1,8,1.0d0) 245 END IF 246 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o4_1',6,MA_ERR) 247 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 248 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 249 &t),dima_sort) 250 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o4_1',7,MA_E 251 &RR) 252 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o4_1',8,MA_E 253 &RR) 254 END IF 255 END IF 256 END IF 257 END DO 258 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 259 &ccsdtq_o4_1',9,MA_ERR) 260 IF ((h1b .le. h2b)) THEN 261 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 262 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 263 &,int_mb(k_range+p7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 264 &,int_mb(k_range+h1b-1),7,6,5,4,8,3,2,1,1.0d0) 265 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 266 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 267 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 268 &+ nvab * (p5b - noab - 1))))))))) 269 END IF 270 IF ((h2b .le. h1b) .and. (h1b .le. h3b)) THEN 271 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 272 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 273 &,int_mb(k_range+p7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 274 &,int_mb(k_range+h1b-1),7,6,5,4,3,8,2,1,-1.0d0) 275 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 276 & 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * 277 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 278 &+ nvab * (p5b - noab - 1))))))))) 279 END IF 280 IF ((h3b .le. h1b) .and. (h1b .le. h4b)) THEN 281 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 282 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 283 &,int_mb(k_range+p7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 284 &,int_mb(k_range+h1b-1),7,6,5,4,3,2,8,1,1.0d0) 285 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 286 & 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 287 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 288 &+ nvab * (p5b - noab - 1))))))))) 289 END IF 290 IF ((h4b .le. h1b)) THEN 291 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 292 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 293 &,int_mb(k_range+p7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 294 &,int_mb(k_range+h1b-1),7,6,5,4,3,2,1,8,-1.0d0) 295 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 296 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 297 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 298 &+ nvab * (p5b - noab - 1))))))))) 299 END IF 300 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o4_1',10,MA_ERR) 301 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o4_1',11,MA_ 302 &ERR) 303 END IF 304 END IF 305 END IF 306 next = NXTASK(nprocs,1) 307 END IF 308 count = count + 1 309 END DO 310 END DO 311 END DO 312 END DO 313 END DO 314 END DO 315 END DO 316 END DO 317 next = NXTASK(-nprocs,1) 318 call GA_SYNC() 319 RETURN 320 END 321 SUBROUTINE ccsdtq_o4_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 322 &t) 323C $Id$ 324C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 325C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 326C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_to + = -1 * P( 4 ) * Sum ( p9 ) * o ( p5 p9 )_o * t ( p6 p7 p8 p9 h1 h2 h3 h4 )_t 327 IMPLICIT NONE 328#include "global.fh" 329#include "mafdecls.fh" 330#include "sym.fh" 331#include "errquit.fh" 332#include "tce.fh" 333 INTEGER d_a 334 INTEGER k_a_offset 335 INTEGER d_b 336 INTEGER k_b_offset 337 INTEGER d_c 338 INTEGER k_c_offset 339 INTEGER NXTASK 340 INTEGER next 341 INTEGER nprocs 342 INTEGER count 343 INTEGER p5b 344 INTEGER p6b 345 INTEGER p7b 346 INTEGER p8b 347 INTEGER h1b 348 INTEGER h2b 349 INTEGER h3b 350 INTEGER h4b 351 INTEGER dimc 352 INTEGER l_c_sort 353 INTEGER k_c_sort 354 INTEGER p9b 355 INTEGER p5b_1 356 INTEGER p9b_1 357 INTEGER p6b_2 358 INTEGER p7b_2 359 INTEGER p8b_2 360 INTEGER p9b_2 361 INTEGER h1b_2 362 INTEGER h2b_2 363 INTEGER h3b_2 364 INTEGER h4b_2 365 INTEGER dim_common 366 INTEGER dima_sort 367 INTEGER dima 368 INTEGER dimb_sort 369 INTEGER dimb 370 INTEGER l_a_sort 371 INTEGER k_a_sort 372 INTEGER l_a 373 INTEGER k_a 374 INTEGER l_b_sort 375 INTEGER k_b_sort 376 INTEGER l_b 377 INTEGER k_b 378 INTEGER l_c 379 INTEGER k_c 380 EXTERNAL NXTASK 381 nprocs = GA_NNODES() 382 count = 0 383 next = NXTASK(nprocs,1) 384 DO p5b = noab+1,noab+nvab 385 DO p6b = noab+1,noab+nvab 386 DO p7b = p6b,noab+nvab 387 DO p8b = p7b,noab+nvab 388 DO h1b = 1,noab 389 DO h2b = h1b,noab 390 DO h3b = h2b,noab 391 DO h4b = h3b,noab 392 IF (next.eq.count) THEN 393 IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1 394 &)+int_mb(k_spin+p7b-1)+int_mb(k_spin+p8b-1)+int_mb(k_spin+h1b-1)+i 395 &nt_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.1 396 &6)) THEN 397 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) 398 &+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 399 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) THEN 400 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 401 &k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h1b-1),ieo 402 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1) 403 &))))))) .eq. ieor(irrep_t,irrep_o)) THEN 404 dimc = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb(k_ra 405 &nge+p7b-1) * int_mb(k_range+p8b-1) * int_mb(k_range+h1b-1) * int_m 406 &b(k_range+h2b-1) * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 407 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 408 & ERRQUIT('ccsdtq_o4_2',0,MA_ERR) 409 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 410 DO p9b = noab+1,noab+nvab 411 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+p9b-1)) THEN 412 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+p9b-1)) .eq. irrep_o) TH 413 &EN 414 CALL TCE_RESTRICTED_2(p5b,p9b,p5b_1,p9b_1) 415 CALL TCE_RESTRICTED_8(p6b,p7b,p8b,p9b,h1b,h2b,h3b,h4b,p6b_2,p7b_2, 416 &p8b_2,p9b_2,h1b_2,h2b_2,h3b_2,h4b_2) 417 dim_common = int_mb(k_range+p9b-1) 418 dima_sort = int_mb(k_range+p5b-1) 419 dima = dim_common * dima_sort 420 dimb_sort = int_mb(k_range+p6b-1) * int_mb(k_range+p7b-1) * int_mb 421 &(k_range+p8b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * 422 &int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 423 dimb = dim_common * dimb_sort 424 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 425 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 426 & ERRQUIT('ccsdtq_o4_2',1,MA_ERR) 427 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 428 &ccsdtq_o4_2',2,MA_ERR) 429 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p9b_1 430 & - 1 + (noab+nvab) * (p5b_1 - 1))) 431 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 432 &,int_mb(k_range+p9b-1),1,2,1.0d0) 433 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o4_2',3,MA_ERR) 434 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 435 & ERRQUIT('ccsdtq_o4_2',4,MA_ERR) 436 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 437 &ccsdtq_o4_2',5,MA_ERR) 438 IF ((p9b .lt. p6b)) THEN 439 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 440 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 441 & noab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b 442 &_2 - noab - 1 + nvab * (p9b_2 - noab - 1))))))))) 443 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p9b-1) 444 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 445 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 446 &,int_mb(k_range+h4b-1),8,7,6,5,4,3,2,1,-1.0d0) 447 END IF 448 IF ((p6b .le. p9b) .and. (p9b .lt. p7b)) THEN 449 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 450 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 451 & noab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p9b 452 &_2 - noab - 1 + nvab * (p6b_2 - noab - 1))))))))) 453 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p6b-1) 454 &,int_mb(k_range+p9b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 455 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 456 &,int_mb(k_range+h4b-1),8,7,6,5,4,3,1,2,1.0d0) 457 END IF 458 IF ((p7b .le. p9b) .and. (p9b .lt. p8b)) THEN 459 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 460 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 461 & noab * (p8b_2 - noab - 1 + nvab * (p9b_2 - noab - 1 + nvab * (p7b 462 &_2 - noab - 1 + nvab * (p6b_2 - noab - 1))))))))) 463 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p6b-1) 464 &,int_mb(k_range+p7b-1),int_mb(k_range+p9b-1),int_mb(k_range+p8b-1) 465 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 466 &,int_mb(k_range+h4b-1),8,7,6,5,4,2,1,3,-1.0d0) 467 END IF 468 IF ((p8b .le. p9b)) THEN 469 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 470 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 471 & noab * (p9b_2 - noab - 1 + nvab * (p8b_2 - noab - 1 + nvab * (p7b 472 &_2 - noab - 1 + nvab * (p6b_2 - noab - 1))))))))) 473 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p6b-1) 474 &,int_mb(k_range+p7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1) 475 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 476 &,int_mb(k_range+h4b-1),8,7,6,5,3,2,1,4,1.0d0) 477 END IF 478 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o4_2',6,MA_ERR) 479 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 480 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 481 &t),dima_sort) 482 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o4_2',7,MA_E 483 &RR) 484 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o4_2',8,MA_E 485 &RR) 486 END IF 487 END IF 488 END IF 489 END DO 490 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 491 &ccsdtq_o4_2',9,MA_ERR) 492 IF ((p5b .le. p6b)) THEN 493 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 494 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 495 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 496 &,int_mb(k_range+p5b-1),8,7,6,5,4,3,2,1,-1.0d0) 497 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 498 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 499 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 500 &+ nvab * (p5b - noab - 1))))))))) 501 END IF 502 IF ((p6b .le. p5b) .and. (p5b .le. p7b)) THEN 503 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 504 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 505 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 506 &,int_mb(k_range+p5b-1),7,8,6,5,4,3,2,1,1.0d0) 507 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 508 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 509 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p5b - noab - 1 510 &+ nvab * (p6b - noab - 1))))))))) 511 END IF 512 IF ((p7b .le. p5b) .and. (p5b .le. p8b)) THEN 513 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 514 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 515 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 516 &,int_mb(k_range+p5b-1),7,6,8,5,4,3,2,1,-1.0d0) 517 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 518 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 519 &(p8b - noab - 1 + nvab * (p5b - noab - 1 + nvab * (p7b - noab - 1 520 &+ nvab * (p6b - noab - 1))))))))) 521 END IF 522 IF ((p8b .le. p5b)) THEN 523 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 524 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 525 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 526 &,int_mb(k_range+p5b-1),7,6,5,8,4,3,2,1,1.0d0) 527 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 528 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 529 &(p5b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p7b - noab - 1 530 &+ nvab * (p6b - noab - 1))))))))) 531 END IF 532 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o4_2',10,MA_ERR) 533 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o4_2',11,MA_ 534 &ERR) 535 END IF 536 END IF 537 END IF 538 next = NXTASK(nprocs,1) 539 END IF 540 count = count + 1 541 END DO 542 END DO 543 END DO 544 END DO 545 END DO 546 END DO 547 END DO 548 END DO 549 next = NXTASK(-nprocs,1) 550 call GA_SYNC() 551 RETURN 552 END 553 SUBROUTINE ccsdtq_o4_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 554 &t) 555C $Id$ 556C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 557C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 558C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_ott + = -1 * P( 4 ) * Sum ( h9 ) * t ( p5 p6 p7 p8 h1 h2 h3 h9 )_t * i1 ( h9 h4 )_ot 559 IMPLICIT NONE 560#include "global.fh" 561#include "mafdecls.fh" 562#include "sym.fh" 563#include "errquit.fh" 564#include "tce.fh" 565 INTEGER d_a 566 INTEGER k_a_offset 567 INTEGER d_b 568 INTEGER k_b_offset 569 INTEGER d_c 570 INTEGER k_c_offset 571 INTEGER NXTASK 572 INTEGER next 573 INTEGER nprocs 574 INTEGER count 575 INTEGER p5b 576 INTEGER p6b 577 INTEGER p7b 578 INTEGER p8b 579 INTEGER h1b 580 INTEGER h2b 581 INTEGER h3b 582 INTEGER h4b 583 INTEGER dimc 584 INTEGER l_c_sort 585 INTEGER k_c_sort 586 INTEGER h9b 587 INTEGER p5b_1 588 INTEGER p6b_1 589 INTEGER p7b_1 590 INTEGER p8b_1 591 INTEGER h1b_1 592 INTEGER h2b_1 593 INTEGER h3b_1 594 INTEGER h9b_1 595 INTEGER h9b_2 596 INTEGER h4b_2 597 INTEGER dim_common 598 INTEGER dima_sort 599 INTEGER dima 600 INTEGER dimb_sort 601 INTEGER dimb 602 INTEGER l_a_sort 603 INTEGER k_a_sort 604 INTEGER l_a 605 INTEGER k_a 606 INTEGER l_b_sort 607 INTEGER k_b_sort 608 INTEGER l_b 609 INTEGER k_b 610 INTEGER l_c 611 INTEGER k_c 612 EXTERNAL NXTASK 613 nprocs = GA_NNODES() 614 count = 0 615 next = NXTASK(nprocs,1) 616 DO p5b = noab+1,noab+nvab 617 DO p6b = p5b,noab+nvab 618 DO p7b = p6b,noab+nvab 619 DO p8b = p7b,noab+nvab 620 DO h1b = 1,noab 621 DO h2b = h1b,noab 622 DO h3b = h2b,noab 623 DO h4b = 1,noab 624 IF (next.eq.count) THEN 625 IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1 626 &)+int_mb(k_spin+p7b-1)+int_mb(k_spin+p8b-1)+int_mb(k_spin+h1b-1)+i 627 &nt_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.1 628 &6)) THEN 629 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) 630 &+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 631 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) THEN 632 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 633 &k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h1b-1),ieo 634 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1) 635 &))))))) .eq. ieor(irrep_o,ieor(irrep_t,irrep_t))) THEN 636 dimc = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb(k_ra 637 &nge+p7b-1) * int_mb(k_range+p8b-1) * int_mb(k_range+h1b-1) * int_m 638 &b(k_range+h2b-1) * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 639 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 640 & ERRQUIT('ccsdtq_o4_3',0,MA_ERR) 641 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 642 DO h9b = 1,noab 643 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) 644 &+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 645 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h9b-1)) THEN 646 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 647 &k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h1b-1),ieo 648 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h9b-1) 649 &))))))) .eq. irrep_t) THEN 650 CALL TCE_RESTRICTED_8(p5b,p6b,p7b,p8b,h1b,h2b,h3b,h9b,p5b_1,p6b_1, 651 &p7b_1,p8b_1,h1b_1,h2b_1,h3b_1,h9b_1) 652 CALL TCE_RESTRICTED_2(h9b,h4b,h9b_2,h4b_2) 653 dim_common = int_mb(k_range+h9b-1) 654 dima_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb 655 &(k_range+p7b-1) * int_mb(k_range+p8b-1) * int_mb(k_range+h1b-1) * 656 &int_mb(k_range+h2b-1) * int_mb(k_range+h3b-1) 657 dima = dim_common * dima_sort 658 dimb_sort = int_mb(k_range+h4b-1) 659 dimb = dim_common * dimb_sort 660 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 661 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 662 & ERRQUIT('ccsdtq_o4_3',1,MA_ERR) 663 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 664 &ccsdtq_o4_3',2,MA_ERR) 665 IF ((h9b .lt. h1b)) THEN 666 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 667 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h9b_1 - 1 + 668 & noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * (p6b 669 &_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 670 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 671 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 672 &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 673 &,int_mb(k_range+h3b-1),8,7,6,4,3,2,1,5,-1.0d0) 674 END IF 675 IF ((h1b .le. h9b) .and. (h9b .lt. h2b)) THEN 676 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 677 & - 1 + noab * (h2b_1 - 1 + noab * (h9b_1 - 1 + noab * (h1b_1 - 1 + 678 & noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * (p6b 679 &_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 680 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 681 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 682 &,int_mb(k_range+h1b-1),int_mb(k_range+h9b-1),int_mb(k_range+h2b-1) 683 &,int_mb(k_range+h3b-1),8,7,5,4,3,2,1,6,1.0d0) 684 END IF 685 IF ((h2b .le. h9b) .and. (h9b .lt. h3b)) THEN 686 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 687 & - 1 + noab * (h9b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 688 & noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * (p6b 689 &_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 690 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 691 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 692 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h9b-1) 693 &,int_mb(k_range+h3b-1),8,6,5,4,3,2,1,7,-1.0d0) 694 END IF 695 IF ((h3b .le. h9b)) THEN 696 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h9b_1 697 & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 698 & noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * (p6b 699 &_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 700 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 701 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 702 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 703 &,int_mb(k_range+h9b-1),7,6,5,4,3,2,1,8,1.0d0) 704 END IF 705 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o4_3',3,MA_ERR) 706 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 707 & ERRQUIT('ccsdtq_o4_3',4,MA_ERR) 708 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 709 &ccsdtq_o4_3',5,MA_ERR) 710 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 711 & - 1 + noab * (h9b_2 - 1))) 712 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 713 &,int_mb(k_range+h4b-1),2,1,1.0d0) 714 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o4_3',6,MA_ERR) 715 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 716 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 717 &t),dima_sort) 718 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o4_3',7,MA_E 719 &RR) 720 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o4_3',8,MA_E 721 &RR) 722 END IF 723 END IF 724 END IF 725 END DO 726 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 727 &ccsdtq_o4_3',9,MA_ERR) 728 IF ((h3b .le. h4b)) THEN 729 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 730 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 731 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 732 &,int_mb(k_range+p5b-1),8,7,6,5,4,3,2,1,-1.0d0) 733 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 734 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 735 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 736 &+ nvab * (p5b - noab - 1))))))))) 737 END IF 738 IF ((h4b .le. h1b)) THEN 739 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 740 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 741 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 742 &,int_mb(k_range+p5b-1),8,7,6,5,1,4,3,2,1.0d0) 743 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 744 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (h4b - 1 + noab * 745 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 746 &+ nvab * (p5b - noab - 1))))))))) 747 END IF 748 IF ((h1b .le. h4b) .and. (h4b .le. h2b)) THEN 749 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 750 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 751 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 752 &,int_mb(k_range+p5b-1),8,7,6,5,4,1,3,2,-1.0d0) 753 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 754 & 1 + noab * (h2b - 1 + noab * (h4b - 1 + noab * (h1b - 1 + noab * 755 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 756 &+ nvab * (p5b - noab - 1))))))))) 757 END IF 758 IF ((h2b .le. h4b) .and. (h4b .le. h3b)) THEN 759 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 760 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 761 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 762 &,int_mb(k_range+p5b-1),8,7,6,5,4,3,1,2,1.0d0) 763 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 764 & 1 + noab * (h4b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 765 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 766 &+ nvab * (p5b - noab - 1))))))))) 767 END IF 768 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o4_3',10,MA_ERR) 769 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o4_3',11,MA_ 770 &ERR) 771 END IF 772 END IF 773 END IF 774 next = NXTASK(nprocs,1) 775 END IF 776 count = count + 1 777 END DO 778 END DO 779 END DO 780 END DO 781 END DO 782 END DO 783 END DO 784 END DO 785 next = NXTASK(-nprocs,1) 786 call GA_SYNC() 787 RETURN 788 END 789 SUBROUTINE ccsdtq_o4_3_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 790 &set) 791C $Id$ 792C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 793C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 794C i1 ( h9 h1 )_ot + = 1 * Sum ( p10 ) * o ( h9 p10 )_o * t ( p10 h1 )_t 795 IMPLICIT NONE 796#include "global.fh" 797#include "mafdecls.fh" 798#include "sym.fh" 799#include "errquit.fh" 800#include "tce.fh" 801 INTEGER d_a 802 INTEGER k_a_offset 803 INTEGER d_b 804 INTEGER k_b_offset 805 INTEGER d_c 806 INTEGER k_c_offset 807 INTEGER NXTASK 808 INTEGER next 809 INTEGER nprocs 810 INTEGER count 811 INTEGER h9b 812 INTEGER h1b 813 INTEGER dimc 814 INTEGER l_c_sort 815 INTEGER k_c_sort 816 INTEGER p10b 817 INTEGER h9b_1 818 INTEGER p10b_1 819 INTEGER p10b_2 820 INTEGER h1b_2 821 INTEGER dim_common 822 INTEGER dima_sort 823 INTEGER dima 824 INTEGER dimb_sort 825 INTEGER dimb 826 INTEGER l_a_sort 827 INTEGER k_a_sort 828 INTEGER l_a 829 INTEGER k_a 830 INTEGER l_b_sort 831 INTEGER k_b_sort 832 INTEGER l_b 833 INTEGER k_b 834 INTEGER l_c 835 INTEGER k_c 836 EXTERNAL NXTASK 837 nprocs = GA_NNODES() 838 count = 0 839 next = NXTASK(nprocs,1) 840 DO h9b = 1,noab 841 DO h1b = 1,noab 842 IF (next.eq.count) THEN 843 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1 844 &).ne.4)) THEN 845 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 846 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 847 &o,irrep_t)) THEN 848 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) 849 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 850 & ERRQUIT('ccsdtq_o4_3_1',0,MA_ERR) 851 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 852 DO p10b = noab+1,noab+nvab 853 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p10b-1)) THEN 854 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p10b-1)) .eq. irrep_o) T 855 &HEN 856 CALL TCE_RESTRICTED_2(h9b,p10b,h9b_1,p10b_1) 857 CALL TCE_RESTRICTED_2(p10b,h1b,p10b_2,h1b_2) 858 dim_common = int_mb(k_range+p10b-1) 859 dima_sort = int_mb(k_range+h9b-1) 860 dima = dim_common * dima_sort 861 dimb_sort = int_mb(k_range+h1b-1) 862 dimb = dim_common * dimb_sort 863 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 864 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 865 & ERRQUIT('ccsdtq_o4_3_1',1,MA_ERR) 866 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 867 &ccsdtq_o4_3_1',2,MA_ERR) 868 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 869 &1 - 1 + (noab+nvab) * (h9b_1 - 1))) 870 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 871 &,int_mb(k_range+p10b-1),1,2,1.0d0) 872 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o4_3_1',3,MA_ERR) 873 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 874 & ERRQUIT('ccsdtq_o4_3_1',4,MA_ERR) 875 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 876 &ccsdtq_o4_3_1',5,MA_ERR) 877 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 878 & - 1 + noab * (p10b_2 - noab - 1))) 879 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p10b-1 880 &),int_mb(k_range+h1b-1),2,1,1.0d0) 881 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o4_3_1',6,MA_ERR) 882 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 883 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 884 &t),dima_sort) 885 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o4_3_1',7,MA 886 &_ERR) 887 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o4_3_1',8,MA 888 &_ERR) 889 END IF 890 END IF 891 END IF 892 END DO 893 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 894 &ccsdtq_o4_3_1',9,MA_ERR) 895 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 896 &,int_mb(k_range+h9b-1),2,1,1.0d0) 897 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 898 & 1 + noab * (h9b - 1))) 899 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o4_3_1',10,MA_ERR 900 &) 901 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o4_3_1',11,M 902 &A_ERR) 903 END IF 904 END IF 905 END IF 906 next = NXTASK(nprocs,1) 907 END IF 908 count = count + 1 909 END DO 910 END DO 911 next = NXTASK(-nprocs,1) 912 call GA_SYNC() 913 RETURN 914 END 915 SUBROUTINE OFFSET_ccsdtq_o4_3_1(l_a_offset,k_a_offset,size) 916C $Id$ 917C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 918C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 919C i1 ( h9 h1 )_ot 920 IMPLICIT NONE 921#include "global.fh" 922#include "mafdecls.fh" 923#include "sym.fh" 924#include "errquit.fh" 925#include "tce.fh" 926 INTEGER l_a_offset 927 INTEGER k_a_offset 928 INTEGER size 929 INTEGER length 930 INTEGER addr 931 INTEGER h9b 932 INTEGER h1b 933 length = 0 934 DO h9b = 1,noab 935 DO h1b = 1,noab 936 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 937 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 938 &o,irrep_t)) THEN 939 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1 940 &).ne.4)) THEN 941 length = length + 1 942 END IF 943 END IF 944 END IF 945 END DO 946 END DO 947 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 948 &set)) CALL ERRQUIT('ccsdtq_o4_3_1',0,MA_ERR) 949 int_mb(k_a_offset) = length 950 addr = 0 951 size = 0 952 DO h9b = 1,noab 953 DO h1b = 1,noab 954 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 955 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 956 &o,irrep_t)) THEN 957 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1 958 &).ne.4)) THEN 959 addr = addr + 1 960 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h9b - 1) 961 int_mb(k_a_offset+length+addr) = size 962 size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) 963 END IF 964 END IF 965 END IF 966 END DO 967 END DO 968 RETURN 969 END 970 SUBROUTINE ccsdtq_o4_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 971 &t) 972C $Id$ 973C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 974C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 975C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_ott + = -1 * P( 4 ) * Sum ( h9 ) * t ( p5 h9 )_t * i1 ( h9 p6 p7 p8 h1 h2 h3 h4 )_ot 976 IMPLICIT NONE 977#include "global.fh" 978#include "mafdecls.fh" 979#include "sym.fh" 980#include "errquit.fh" 981#include "tce.fh" 982 INTEGER d_a 983 INTEGER k_a_offset 984 INTEGER d_b 985 INTEGER k_b_offset 986 INTEGER d_c 987 INTEGER k_c_offset 988 INTEGER NXTASK 989 INTEGER next 990 INTEGER nprocs 991 INTEGER count 992 INTEGER p5b 993 INTEGER p6b 994 INTEGER p7b 995 INTEGER p8b 996 INTEGER h1b 997 INTEGER h2b 998 INTEGER h3b 999 INTEGER h4b 1000 INTEGER dimc 1001 INTEGER l_c_sort 1002 INTEGER k_c_sort 1003 INTEGER h9b 1004 INTEGER p5b_1 1005 INTEGER h9b_1 1006 INTEGER p6b_2 1007 INTEGER p7b_2 1008 INTEGER p8b_2 1009 INTEGER h9b_2 1010 INTEGER h1b_2 1011 INTEGER h2b_2 1012 INTEGER h3b_2 1013 INTEGER h4b_2 1014 INTEGER dim_common 1015 INTEGER dima_sort 1016 INTEGER dima 1017 INTEGER dimb_sort 1018 INTEGER dimb 1019 INTEGER l_a_sort 1020 INTEGER k_a_sort 1021 INTEGER l_a 1022 INTEGER k_a 1023 INTEGER l_b_sort 1024 INTEGER k_b_sort 1025 INTEGER l_b 1026 INTEGER k_b 1027 INTEGER l_c 1028 INTEGER k_c 1029 EXTERNAL NXTASK 1030 nprocs = GA_NNODES() 1031 count = 0 1032 next = NXTASK(nprocs,1) 1033 DO p5b = noab+1,noab+nvab 1034 DO p6b = noab+1,noab+nvab 1035 DO p7b = p6b,noab+nvab 1036 DO p8b = p7b,noab+nvab 1037 DO h1b = 1,noab 1038 DO h2b = h1b,noab 1039 DO h3b = h2b,noab 1040 DO h4b = h3b,noab 1041 IF (next.eq.count) THEN 1042 IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1 1043 &)+int_mb(k_spin+p7b-1)+int_mb(k_spin+p8b-1)+int_mb(k_spin+h1b-1)+i 1044 &nt_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.1 1045 &6)) THEN 1046 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) 1047 &+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 1048 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) THEN 1049 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 1050 &k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h1b-1),ieo 1051 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1) 1052 &))))))) .eq. ieor(irrep_o,ieor(irrep_t,irrep_t))) THEN 1053 dimc = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb(k_ra 1054 &nge+p7b-1) * int_mb(k_range+p8b-1) * int_mb(k_range+h1b-1) * int_m 1055 &b(k_range+h2b-1) * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 1056 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1057 & ERRQUIT('ccsdtq_o4_4',0,MA_ERR) 1058 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1059 DO h9b = 1,noab 1060 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h9b-1)) THEN 1061 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h9b-1)) .eq. irrep_t) TH 1062 &EN 1063 CALL TCE_RESTRICTED_2(p5b,h9b,p5b_1,h9b_1) 1064 CALL TCE_RESTRICTED_8(p6b,p7b,p8b,h9b,h1b,h2b,h3b,h4b,p6b_2,p7b_2, 1065 &p8b_2,h9b_2,h1b_2,h2b_2,h3b_2,h4b_2) 1066 dim_common = int_mb(k_range+h9b-1) 1067 dima_sort = int_mb(k_range+p5b-1) 1068 dima = dim_common * dima_sort 1069 dimb_sort = int_mb(k_range+p6b-1) * int_mb(k_range+p7b-1) * int_mb 1070 &(k_range+p8b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * 1071 &int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 1072 dimb = dim_common * dimb_sort 1073 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1074 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1075 & ERRQUIT('ccsdtq_o4_4',1,MA_ERR) 1076 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1077 &ccsdtq_o4_4',2,MA_ERR) 1078 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h9b_1 1079 & - 1 + noab * (p5b_1 - noab - 1))) 1080 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1081 &,int_mb(k_range+h9b-1),1,2,1.0d0) 1082 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o4_4',3,MA_ERR) 1083 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1084 & ERRQUIT('ccsdtq_o4_4',4,MA_ERR) 1085 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1086 &ccsdtq_o4_4',5,MA_ERR) 1087 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 1088 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 1089 & noab * (h9b_2 - 1 + noab * (p8b_2 - noab - 1 + nvab * (p7b_2 - no 1090 &ab - 1 + nvab * (p6b_2 - noab - 1))))))))) 1091 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p6b-1) 1092 &,int_mb(k_range+p7b-1),int_mb(k_range+p8b-1),int_mb(k_range+h9b-1) 1093 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 1094 &,int_mb(k_range+h4b-1),8,7,6,5,3,2,1,4,1.0d0) 1095 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o4_4',6,MA_ERR) 1096 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1097 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1098 &t),dima_sort) 1099 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o4_4',7,MA_E 1100 &RR) 1101 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o4_4',8,MA_E 1102 &RR) 1103 END IF 1104 END IF 1105 END IF 1106 END DO 1107 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1108 &ccsdtq_o4_4',9,MA_ERR) 1109 IF ((p5b .le. p6b)) THEN 1110 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1111 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 1112 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1113 &,int_mb(k_range+p5b-1),8,7,6,5,4,3,2,1,-1.0d0) 1114 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1115 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 1116 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 1117 &+ nvab * (p5b - noab - 1))))))))) 1118 END IF 1119 IF ((p6b .le. p5b) .and. (p5b .le. p7b)) THEN 1120 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1121 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 1122 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1123 &,int_mb(k_range+p5b-1),7,8,6,5,4,3,2,1,1.0d0) 1124 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1125 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 1126 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p5b - noab - 1 1127 &+ nvab * (p6b - noab - 1))))))))) 1128 END IF 1129 IF ((p7b .le. p5b) .and. (p5b .le. p8b)) THEN 1130 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1131 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 1132 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1133 &,int_mb(k_range+p5b-1),7,6,8,5,4,3,2,1,-1.0d0) 1134 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1135 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 1136 &(p8b - noab - 1 + nvab * (p5b - noab - 1 + nvab * (p7b - noab - 1 1137 &+ nvab * (p6b - noab - 1))))))))) 1138 END IF 1139 IF ((p8b .le. p5b)) THEN 1140 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1141 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 1142 &,int_mb(k_range+p8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1143 &,int_mb(k_range+p5b-1),7,6,5,8,4,3,2,1,1.0d0) 1144 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1145 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 1146 &(p5b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p7b - noab - 1 1147 &+ nvab * (p6b - noab - 1))))))))) 1148 END IF 1149 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o4_4',10,MA_ERR) 1150 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o4_4',11,MA_ 1151 &ERR) 1152 END IF 1153 END IF 1154 END IF 1155 next = NXTASK(nprocs,1) 1156 END IF 1157 count = count + 1 1158 END DO 1159 END DO 1160 END DO 1161 END DO 1162 END DO 1163 END DO 1164 END DO 1165 END DO 1166 next = NXTASK(-nprocs,1) 1167 call GA_SYNC() 1168 RETURN 1169 END 1170 SUBROUTINE ccsdtq_o4_4_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 1171 &set) 1172C $Id$ 1173C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1174C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1175C i1 ( h9 p5 p6 p7 h1 h2 h3 h4 )_ot + = -1 * Sum ( p10 ) * o ( h9 p10 )_o * t ( p5 p6 p7 p10 h1 h2 h3 h4 )_t 1176 IMPLICIT NONE 1177#include "global.fh" 1178#include "mafdecls.fh" 1179#include "sym.fh" 1180#include "errquit.fh" 1181#include "tce.fh" 1182 INTEGER d_a 1183 INTEGER k_a_offset 1184 INTEGER d_b 1185 INTEGER k_b_offset 1186 INTEGER d_c 1187 INTEGER k_c_offset 1188 INTEGER NXTASK 1189 INTEGER next 1190 INTEGER nprocs 1191 INTEGER count 1192 INTEGER p5b 1193 INTEGER p6b 1194 INTEGER p7b 1195 INTEGER h9b 1196 INTEGER h1b 1197 INTEGER h2b 1198 INTEGER h3b 1199 INTEGER h4b 1200 INTEGER dimc 1201 INTEGER l_c_sort 1202 INTEGER k_c_sort 1203 INTEGER p10b 1204 INTEGER h9b_1 1205 INTEGER p10b_1 1206 INTEGER p5b_2 1207 INTEGER p6b_2 1208 INTEGER p7b_2 1209 INTEGER p10b_2 1210 INTEGER h1b_2 1211 INTEGER h2b_2 1212 INTEGER h3b_2 1213 INTEGER h4b_2 1214 INTEGER dim_common 1215 INTEGER dima_sort 1216 INTEGER dima 1217 INTEGER dimb_sort 1218 INTEGER dimb 1219 INTEGER l_a_sort 1220 INTEGER k_a_sort 1221 INTEGER l_a 1222 INTEGER k_a 1223 INTEGER l_b_sort 1224 INTEGER k_b_sort 1225 INTEGER l_b 1226 INTEGER k_b 1227 INTEGER l_c 1228 INTEGER k_c 1229 EXTERNAL NXTASK 1230 nprocs = GA_NNODES() 1231 count = 0 1232 next = NXTASK(nprocs,1) 1233 DO p5b = noab+1,noab+nvab 1234 DO p6b = p5b,noab+nvab 1235 DO p7b = p6b,noab+nvab 1236 DO h9b = 1,noab 1237 DO h1b = 1,noab 1238 DO h2b = h1b,noab 1239 DO h3b = h2b,noab 1240 DO h4b = h3b,noab 1241 IF (next.eq.count) THEN 1242 IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1 1243 &)+int_mb(k_spin+p7b-1)+int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1)+i 1244 &nt_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.1 1245 &6)) THEN 1246 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) 1247 &+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 1248 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) THEN 1249 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 1250 &k_sym+p7b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h1b-1),ieo 1251 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1) 1252 &))))))) .eq. ieor(irrep_o,irrep_t)) THEN 1253 dimc = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb(k_ra 1254 &nge+p7b-1) * int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) * int_m 1255 &b(k_range+h2b-1) * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 1256 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1257 & ERRQUIT('ccsdtq_o4_4_1',0,MA_ERR) 1258 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1259 DO p10b = noab+1,noab+nvab 1260 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p10b-1)) THEN 1261 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p10b-1)) .eq. irrep_o) T 1262 &HEN 1263 CALL TCE_RESTRICTED_2(h9b,p10b,h9b_1,p10b_1) 1264 CALL TCE_RESTRICTED_8(p5b,p6b,p7b,p10b,h1b,h2b,h3b,h4b,p5b_2,p6b_2 1265 &,p7b_2,p10b_2,h1b_2,h2b_2,h3b_2,h4b_2) 1266 dim_common = int_mb(k_range+p10b-1) 1267 dima_sort = int_mb(k_range+h9b-1) 1268 dima = dim_common * dima_sort 1269 dimb_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb 1270 &(k_range+p7b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * 1271 &int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 1272 dimb = dim_common * dimb_sort 1273 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1274 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1275 & ERRQUIT('ccsdtq_o4_4_1',1,MA_ERR) 1276 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1277 &ccsdtq_o4_4_1',2,MA_ERR) 1278 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 1279 &1 - 1 + (noab+nvab) * (h9b_1 - 1))) 1280 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 1281 &,int_mb(k_range+p10b-1),1,2,1.0d0) 1282 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o4_4_1',3,MA_ERR) 1283 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1284 & ERRQUIT('ccsdtq_o4_4_1',4,MA_ERR) 1285 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1286 &ccsdtq_o4_4_1',5,MA_ERR) 1287 IF ((p10b .lt. p5b)) THEN 1288 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 1289 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 1290 & noab * (p7b_2 - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (p5b 1291 &_2 - noab - 1 + nvab * (p10b_2 - noab - 1))))))))) 1292 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p10b-1 1293 &),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b-1 1294 &),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1 1295 &),int_mb(k_range+h4b-1),8,7,6,5,4,3,2,1,-1.0d0) 1296 END IF 1297 IF ((p5b .le. p10b) .and. (p10b .lt. p6b)) THEN 1298 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 1299 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 1300 & noab * (p7b_2 - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (p10 1301 &b_2 - noab - 1 + nvab * (p5b_2 - noab - 1))))))))) 1302 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 1303 &,int_mb(k_range+p10b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b-1 1304 &),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1 1305 &),int_mb(k_range+h4b-1),8,7,6,5,4,3,1,2,1.0d0) 1306 END IF 1307 IF ((p6b .le. p10b) .and. (p10b .lt. p7b)) THEN 1308 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 1309 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 1310 & noab * (p7b_2 - noab - 1 + nvab * (p10b_2 - noab - 1 + nvab * (p6 1311 &b_2 - noab - 1 + nvab * (p5b_2 - noab - 1))))))))) 1312 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 1313 &,int_mb(k_range+p6b-1),int_mb(k_range+p10b-1),int_mb(k_range+p7b-1 1314 &),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1 1315 &),int_mb(k_range+h4b-1),8,7,6,5,4,2,1,3,-1.0d0) 1316 END IF 1317 IF ((p7b .le. p10b)) THEN 1318 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 1319 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + 1320 & noab * (p10b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6 1321 &b_2 - noab - 1 + nvab * (p5b_2 - noab - 1))))))))) 1322 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 1323 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p10b-1 1324 &),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1 1325 &),int_mb(k_range+h4b-1),8,7,6,5,3,2,1,4,1.0d0) 1326 END IF 1327 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o4_4_1',6,MA_ERR) 1328 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1329 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1330 &t),dima_sort) 1331 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o4_4_1',7,MA 1332 &_ERR) 1333 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o4_4_1',8,MA 1334 &_ERR) 1335 END IF 1336 END IF 1337 END IF 1338 END DO 1339 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1340 &ccsdtq_o4_4_1',9,MA_ERR) 1341 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1342 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 1343 &,int_mb(k_range+p7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 1344 &,int_mb(k_range+h9b-1),7,6,5,8,4,3,2,1,-1.0d0) 1345 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1346 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 1347 &(h9b - 1 + noab * (p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab 1348 &* (p5b - noab - 1))))))))) 1349 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o4_4_1',10,MA_ERR 1350 &) 1351 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o4_4_1',11,M 1352 &A_ERR) 1353 END IF 1354 END IF 1355 END IF 1356 next = NXTASK(nprocs,1) 1357 END IF 1358 count = count + 1 1359 END DO 1360 END DO 1361 END DO 1362 END DO 1363 END DO 1364 END DO 1365 END DO 1366 END DO 1367 next = NXTASK(-nprocs,1) 1368 call GA_SYNC() 1369 RETURN 1370 END 1371 SUBROUTINE OFFSET_ccsdtq_o4_4_1(l_a_offset,k_a_offset,size) 1372C $Id$ 1373C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1374C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1375C i1 ( h9 p5 p6 p7 h1 h2 h3 h4 )_ot 1376 IMPLICIT NONE 1377#include "global.fh" 1378#include "mafdecls.fh" 1379#include "sym.fh" 1380#include "errquit.fh" 1381#include "tce.fh" 1382 INTEGER l_a_offset 1383 INTEGER k_a_offset 1384 INTEGER size 1385 INTEGER length 1386 INTEGER addr 1387 INTEGER p5b 1388 INTEGER p6b 1389 INTEGER p7b 1390 INTEGER h9b 1391 INTEGER h1b 1392 INTEGER h2b 1393 INTEGER h3b 1394 INTEGER h4b 1395 length = 0 1396 DO p5b = noab+1,noab+nvab 1397 DO p6b = p5b,noab+nvab 1398 DO p7b = p6b,noab+nvab 1399 DO h9b = 1,noab 1400 DO h1b = 1,noab 1401 DO h2b = h1b,noab 1402 DO h3b = h2b,noab 1403 DO h4b = h3b,noab 1404 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 1405 &+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 1406 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) THEN 1407 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 1408 &k_sym+p6b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb(k_sym+h1b-1),ieo 1409 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1) 1410 &))))))) .eq. ieor(irrep_o,irrep_t)) THEN 1411 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1 1412 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1)+int_mb(k_spin+h1b-1)+i 1413 &nt_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.1 1414 &6)) THEN 1415 length = length + 1 1416 END IF 1417 END IF 1418 END IF 1419 END DO 1420 END DO 1421 END DO 1422 END DO 1423 END DO 1424 END DO 1425 END DO 1426 END DO 1427 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1428 &set)) CALL ERRQUIT('ccsdtq_o4_4_1',0,MA_ERR) 1429 int_mb(k_a_offset) = length 1430 addr = 0 1431 size = 0 1432 DO p5b = noab+1,noab+nvab 1433 DO p6b = p5b,noab+nvab 1434 DO p7b = p6b,noab+nvab 1435 DO h9b = 1,noab 1436 DO h1b = 1,noab 1437 DO h2b = h1b,noab 1438 DO h3b = h2b,noab 1439 DO h4b = h3b,noab 1440 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 1441 &+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 1442 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) THEN 1443 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 1444 &k_sym+p6b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb(k_sym+h1b-1),ieo 1445 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1) 1446 &))))))) .eq. ieor(irrep_o,irrep_t)) THEN 1447 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1 1448 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1)+int_mb(k_spin+h1b-1)+i 1449 &nt_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.1 1450 &6)) THEN 1451 addr = addr + 1 1452 int_mb(k_a_offset+addr) = h4b - 1 + noab * (h3b - 1 + noab * (h2b 1453 &- 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p7b - noab - 1 + 1454 & nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1))))))) 1455 int_mb(k_a_offset+length+addr) = size 1456 size = size + int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_ 1457 &mb(k_range+p7b-1) * int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) 1458 &* int_mb(k_range+h2b-1) * int_mb(k_range+h3b-1) * int_mb(k_range+h 1459 &4b-1) 1460 END IF 1461 END IF 1462 END IF 1463 END DO 1464 END DO 1465 END DO 1466 END DO 1467 END DO 1468 END DO 1469 END DO 1470 END DO 1471 RETURN 1472 END 1473 SUBROUTINE ccsdtq_o4_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 1474 &t) 1475C $Id$ 1476C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1477C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1478C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_ott + = -1 * P( 24 ) * Sum ( h9 ) * t ( p5 p6 p7 h1 h2 h9 )_t * i1 ( h9 p8 h3 h4 )_ot 1479 IMPLICIT NONE 1480#include "global.fh" 1481#include "mafdecls.fh" 1482#include "sym.fh" 1483#include "errquit.fh" 1484#include "tce.fh" 1485 INTEGER d_a 1486 INTEGER k_a_offset 1487 INTEGER d_b 1488 INTEGER k_b_offset 1489 INTEGER d_c 1490 INTEGER k_c_offset 1491 INTEGER NXTASK 1492 INTEGER next 1493 INTEGER nprocs 1494 INTEGER count 1495 INTEGER p5b 1496 INTEGER p6b 1497 INTEGER p7b 1498 INTEGER p8b 1499 INTEGER h1b 1500 INTEGER h2b 1501 INTEGER h3b 1502 INTEGER h4b 1503 INTEGER dimc 1504 INTEGER l_c_sort 1505 INTEGER k_c_sort 1506 INTEGER h9b 1507 INTEGER p5b_1 1508 INTEGER p6b_1 1509 INTEGER p7b_1 1510 INTEGER h1b_1 1511 INTEGER h2b_1 1512 INTEGER h9b_1 1513 INTEGER p8b_2 1514 INTEGER h9b_2 1515 INTEGER h3b_2 1516 INTEGER h4b_2 1517 INTEGER dim_common 1518 INTEGER dima_sort 1519 INTEGER dima 1520 INTEGER dimb_sort 1521 INTEGER dimb 1522 INTEGER l_a_sort 1523 INTEGER k_a_sort 1524 INTEGER l_a 1525 INTEGER k_a 1526 INTEGER l_b_sort 1527 INTEGER k_b_sort 1528 INTEGER l_b 1529 INTEGER k_b 1530 INTEGER l_c 1531 INTEGER k_c 1532 EXTERNAL NXTASK 1533 nprocs = GA_NNODES() 1534 count = 0 1535 next = NXTASK(nprocs,1) 1536 DO p5b = noab+1,noab+nvab 1537 DO p6b = p5b,noab+nvab 1538 DO p7b = p6b,noab+nvab 1539 DO p8b = noab+1,noab+nvab 1540 DO h1b = 1,noab 1541 DO h2b = h1b,noab 1542 DO h3b = 1,noab 1543 DO h4b = h3b,noab 1544 IF (next.eq.count) THEN 1545 IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1 1546 &)+int_mb(k_spin+p7b-1)+int_mb(k_spin+p8b-1)+int_mb(k_spin+h1b-1)+i 1547 &nt_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.1 1548 &6)) THEN 1549 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) 1550 &+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 1551 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) THEN 1552 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 1553 &k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h1b-1),ieo 1554 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1) 1555 &))))))) .eq. ieor(irrep_o,ieor(irrep_t,irrep_t))) THEN 1556 dimc = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb(k_ra 1557 &nge+p7b-1) * int_mb(k_range+p8b-1) * int_mb(k_range+h1b-1) * int_m 1558 &b(k_range+h2b-1) * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 1559 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1560 & ERRQUIT('ccsdtq_o4_5',0,MA_ERR) 1561 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1562 DO h9b = 1,noab 1563 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) 1564 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h9b- 1565 &1)) THEN 1566 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 1567 &k_sym+p7b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 1568 &_mb(k_sym+h9b-1)))))) .eq. irrep_t) THEN 1569 CALL TCE_RESTRICTED_6(p5b,p6b,p7b,h1b,h2b,h9b,p5b_1,p6b_1,p7b_1,h1 1570 &b_1,h2b_1,h9b_1) 1571 CALL TCE_RESTRICTED_4(p8b,h9b,h3b,h4b,p8b_2,h9b_2,h3b_2,h4b_2) 1572 dim_common = int_mb(k_range+h9b-1) 1573 dima_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb 1574 &(k_range+p7b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 1575 dima = dim_common * dima_sort 1576 dimb_sort = int_mb(k_range+p8b-1) * int_mb(k_range+h3b-1) * int_mb 1577 &(k_range+h4b-1) 1578 dimb = dim_common * dimb_sort 1579 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1580 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1581 & ERRQUIT('ccsdtq_o4_5',1,MA_ERR) 1582 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1583 &ccsdtq_o4_5',2,MA_ERR) 1584 IF ((h9b .lt. h1b)) THEN 1585 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 1586 & - 1 + noab * (h1b_1 - 1 + noab * (h9b_1 - 1 + noab * (p7b_1 - noa 1587 &b - 1 + nvab * (p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 1588 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1589 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+h9b-1) 1590 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,3,2,1,4,1.0d0) 1591 END IF 1592 IF ((h1b .le. h9b) .and. (h9b .lt. h2b)) THEN 1593 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 1594 & - 1 + noab * (h9b_1 - 1 + noab * (h1b_1 - 1 + noab * (p7b_1 - noa 1595 &b - 1 + nvab * (p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 1596 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1597 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+h1b-1) 1598 &,int_mb(k_range+h9b-1),int_mb(k_range+h2b-1),6,4,3,2,1,5,-1.0d0) 1599 END IF 1600 IF ((h2b .le. h9b)) THEN 1601 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h9b_1 1602 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p7b_1 - noa 1603 &b - 1 + nvab * (p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 1604 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1605 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+h1b-1) 1606 &,int_mb(k_range+h2b-1),int_mb(k_range+h9b-1),5,4,3,2,1,6,1.0d0) 1607 END IF 1608 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o4_5',3,MA_ERR) 1609 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1610 & ERRQUIT('ccsdtq_o4_5',4,MA_ERR) 1611 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1612 &ccsdtq_o4_5',5,MA_ERR) 1613 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 1614 & - 1 + noab * (h3b_2 - 1 + noab * (h9b_2 - 1 + noab * (p8b_2 - noa 1615 &b - 1))))) 1616 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p8b-1) 1617 &,int_mb(k_range+h9b-1),int_mb(k_range+h3b-1),int_mb(k_range+h4b-1) 1618 &,4,3,1,2,1.0d0) 1619 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o4_5',6,MA_ERR) 1620 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1621 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1622 &t),dima_sort) 1623 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o4_5',7,MA_E 1624 &RR) 1625 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o4_5',8,MA_E 1626 &RR) 1627 END IF 1628 END IF 1629 END IF 1630 END DO 1631 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1632 &ccsdtq_o4_5',9,MA_ERR) 1633 IF ((p7b .le. p8b) .and. (h2b .le. h3b)) THEN 1634 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1635 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1636 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1637 &,int_mb(k_range+p5b-1),8,7,6,3,5,4,2,1,-1.0d0) 1638 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1639 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 1640 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 1641 &+ nvab * (p5b - noab - 1))))))))) 1642 END IF 1643 IF ((p7b .le. p8b) .and. (h3b .le. h1b) .and. (h2b .le. h4b)) THEN 1644 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1645 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1646 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1647 &,int_mb(k_range+p5b-1),8,7,6,3,2,5,4,1,-1.0d0) 1648 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1649 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * 1650 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 1651 &+ nvab * (p5b - noab - 1))))))))) 1652 END IF 1653 IF ((p7b .le. p8b) .and. (h1b .le. h3b) .and. (h3b .le. h2b) .and. 1654 & (h2b .le. h4b)) THEN 1655 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1656 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1657 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1658 &,int_mb(k_range+p5b-1),8,7,6,3,5,2,4,1,1.0d0) 1659 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1660 & 1 + noab * (h2b - 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * 1661 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 1662 &+ nvab * (p5b - noab - 1))))))))) 1663 END IF 1664 IF ((p7b .le. p8b) .and. (h3b .le. h1b) .and. (h1b .le. h4b) .and. 1665 & (h4b .le. h2b)) THEN 1666 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1667 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1668 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1669 &,int_mb(k_range+p5b-1),8,7,6,3,2,5,1,4,1.0d0) 1670 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1671 & 1 + noab * (h4b - 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * 1672 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 1673 &+ nvab * (p5b - noab - 1))))))))) 1674 END IF 1675 IF ((p7b .le. p8b) .and. (h1b .le. h3b) .and. (h4b .le. h2b)) THEN 1676 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1677 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1678 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1679 &,int_mb(k_range+p5b-1),8,7,6,3,5,2,1,4,-1.0d0) 1680 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1681 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * 1682 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 1683 &+ nvab * (p5b - noab - 1))))))))) 1684 END IF 1685 IF ((p7b .le. p8b) .and. (h4b .le. h1b)) THEN 1686 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1687 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1688 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1689 &,int_mb(k_range+p5b-1),8,7,6,3,2,1,5,4,-1.0d0) 1690 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1691 & 1 + noab * (h1b - 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * 1692 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 1693 &+ nvab * (p5b - noab - 1))))))))) 1694 END IF 1695 IF ((p8b .le. p5b) .and. (h2b .le. h3b)) THEN 1696 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1697 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1698 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1699 &,int_mb(k_range+p5b-1),3,8,7,6,5,4,2,1,1.0d0) 1700 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1701 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 1702 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1 1703 &+ nvab * (p8b - noab - 1))))))))) 1704 END IF 1705 IF ((p8b .le. p5b) .and. (h3b .le. h1b) .and. (h2b .le. h4b)) THEN 1706 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1707 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1708 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1709 &,int_mb(k_range+p5b-1),3,8,7,6,2,5,4,1,1.0d0) 1710 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1711 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * 1712 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1 1713 &+ nvab * (p8b - noab - 1))))))))) 1714 END IF 1715 IF ((p8b .le. p5b) .and. (h1b .le. h3b) .and. (h3b .le. h2b) .and. 1716 & (h2b .le. h4b)) THEN 1717 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1718 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1719 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1720 &,int_mb(k_range+p5b-1),3,8,7,6,5,2,4,1,-1.0d0) 1721 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1722 & 1 + noab * (h2b - 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * 1723 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1 1724 &+ nvab * (p8b - noab - 1))))))))) 1725 END IF 1726 IF ((p8b .le. p5b) .and. (h3b .le. h1b) .and. (h1b .le. h4b) .and. 1727 & (h4b .le. h2b)) THEN 1728 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1729 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1730 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1731 &,int_mb(k_range+p5b-1),3,8,7,6,2,5,1,4,-1.0d0) 1732 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1733 & 1 + noab * (h4b - 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * 1734 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1 1735 &+ nvab * (p8b - noab - 1))))))))) 1736 END IF 1737 IF ((p8b .le. p5b) .and. (h1b .le. h3b) .and. (h4b .le. h2b)) THEN 1738 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1739 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1740 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1741 &,int_mb(k_range+p5b-1),3,8,7,6,5,2,1,4,1.0d0) 1742 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1743 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * 1744 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1 1745 &+ nvab * (p8b - noab - 1))))))))) 1746 END IF 1747 IF ((p8b .le. p5b) .and. (h4b .le. h1b)) THEN 1748 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1749 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1750 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1751 &,int_mb(k_range+p5b-1),3,8,7,6,2,1,5,4,1.0d0) 1752 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1753 & 1 + noab * (h1b - 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * 1754 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1 1755 &+ nvab * (p8b - noab - 1))))))))) 1756 END IF 1757 IF ((p5b .le. p8b) .and. (p8b .le. p6b) .and. (h2b .le. h3b)) THEN 1758 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1759 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1760 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1761 &,int_mb(k_range+p5b-1),8,3,7,6,5,4,2,1,-1.0d0) 1762 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1763 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 1764 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p8b - noab - 1 1765 &+ nvab * (p5b - noab - 1))))))))) 1766 END IF 1767 IF ((p5b .le. p8b) .and. (p8b .le. p6b) .and. (h3b .le. h1b) .and. 1768 & (h2b .le. h4b)) THEN 1769 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1770 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1771 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1772 &,int_mb(k_range+p5b-1),8,3,7,6,2,5,4,1,-1.0d0) 1773 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1774 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * 1775 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p8b - noab - 1 1776 &+ nvab * (p5b - noab - 1))))))))) 1777 END IF 1778 IF ((p5b .le. p8b) .and. (p8b .le. p6b) .and. (h1b .le. h3b) .and. 1779 & (h3b .le. h2b) .and. (h2b .le. h4b)) THEN 1780 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1781 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1782 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1783 &,int_mb(k_range+p5b-1),8,3,7,6,5,2,4,1,1.0d0) 1784 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1785 & 1 + noab * (h2b - 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * 1786 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p8b - noab - 1 1787 &+ nvab * (p5b - noab - 1))))))))) 1788 END IF 1789 IF ((p5b .le. p8b) .and. (p8b .le. p6b) .and. (h3b .le. h1b) .and. 1790 & (h1b .le. h4b) .and. (h4b .le. h2b)) THEN 1791 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1792 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1793 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1794 &,int_mb(k_range+p5b-1),8,3,7,6,2,5,1,4,1.0d0) 1795 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1796 & 1 + noab * (h4b - 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * 1797 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p8b - noab - 1 1798 &+ nvab * (p5b - noab - 1))))))))) 1799 END IF 1800 IF ((p5b .le. p8b) .and. (p8b .le. p6b) .and. (h1b .le. h3b) .and. 1801 & (h4b .le. h2b)) THEN 1802 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1803 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1804 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1805 &,int_mb(k_range+p5b-1),8,3,7,6,5,2,1,4,-1.0d0) 1806 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1807 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * 1808 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p8b - noab - 1 1809 &+ nvab * (p5b - noab - 1))))))))) 1810 END IF 1811 IF ((p5b .le. p8b) .and. (p8b .le. p6b) .and. (h4b .le. h1b)) THEN 1812 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1813 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1814 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1815 &,int_mb(k_range+p5b-1),8,3,7,6,2,1,5,4,-1.0d0) 1816 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1817 & 1 + noab * (h1b - 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * 1818 &(p7b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p8b - noab - 1 1819 &+ nvab * (p5b - noab - 1))))))))) 1820 END IF 1821 IF ((p6b .le. p8b) .and. (p8b .le. p7b) .and. (h2b .le. h3b)) THEN 1822 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1823 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1824 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1825 &,int_mb(k_range+p5b-1),8,7,3,6,5,4,2,1,1.0d0) 1826 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1827 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 1828 &(p7b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p6b - noab - 1 1829 &+ nvab * (p5b - noab - 1))))))))) 1830 END IF 1831 IF ((p6b .le. p8b) .and. (p8b .le. p7b) .and. (h3b .le. h1b) .and. 1832 & (h2b .le. h4b)) THEN 1833 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1834 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1835 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1836 &,int_mb(k_range+p5b-1),8,7,3,6,2,5,4,1,1.0d0) 1837 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1838 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * 1839 &(p7b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p6b - noab - 1 1840 &+ nvab * (p5b - noab - 1))))))))) 1841 END IF 1842 IF ((p6b .le. p8b) .and. (p8b .le. p7b) .and. (h1b .le. h3b) .and. 1843 & (h3b .le. h2b) .and. (h2b .le. h4b)) THEN 1844 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1845 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1846 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1847 &,int_mb(k_range+p5b-1),8,7,3,6,5,2,4,1,-1.0d0) 1848 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1849 & 1 + noab * (h2b - 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * 1850 &(p7b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p6b - noab - 1 1851 &+ nvab * (p5b - noab - 1))))))))) 1852 END IF 1853 IF ((p6b .le. p8b) .and. (p8b .le. p7b) .and. (h3b .le. h1b) .and. 1854 & (h1b .le. h4b) .and. (h4b .le. h2b)) THEN 1855 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1856 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1857 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1858 &,int_mb(k_range+p5b-1),8,7,3,6,2,5,1,4,-1.0d0) 1859 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1860 & 1 + noab * (h4b - 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * 1861 &(p7b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p6b - noab - 1 1862 &+ nvab * (p5b - noab - 1))))))))) 1863 END IF 1864 IF ((p6b .le. p8b) .and. (p8b .le. p7b) .and. (h1b .le. h3b) .and. 1865 & (h4b .le. h2b)) THEN 1866 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1867 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1868 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1869 &,int_mb(k_range+p5b-1),8,7,3,6,5,2,1,4,1.0d0) 1870 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1871 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * 1872 &(p7b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p6b - noab - 1 1873 &+ nvab * (p5b - noab - 1))))))))) 1874 END IF 1875 IF ((p6b .le. p8b) .and. (p8b .le. p7b) .and. (h4b .le. h1b)) THEN 1876 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1877 &,int_mb(k_range+h3b-1),int_mb(k_range+p8b-1),int_mb(k_range+h2b-1) 1878 &,int_mb(k_range+h1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p6b-1) 1879 &,int_mb(k_range+p5b-1),8,7,3,6,2,1,5,4,1.0d0) 1880 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1881 & 1 + noab * (h1b - 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * 1882 &(p7b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p6b - noab - 1 1883 &+ nvab * (p5b - noab - 1))))))))) 1884 END IF 1885 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o4_5',10,MA_ERR) 1886 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o4_5',11,MA_ 1887 &ERR) 1888 END IF 1889 END IF 1890 END IF 1891 next = NXTASK(nprocs,1) 1892 END IF 1893 count = count + 1 1894 END DO 1895 END DO 1896 END DO 1897 END DO 1898 END DO 1899 END DO 1900 END DO 1901 END DO 1902 next = NXTASK(-nprocs,1) 1903 call GA_SYNC() 1904 RETURN 1905 END 1906 SUBROUTINE ccsdtq_o4_5_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 1907 &set) 1908C $Id$ 1909C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1910C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1911C i1 ( h9 p5 h1 h2 )_ot + = -1 * Sum ( p10 ) * o ( h9 p10 )_o * t ( p5 p10 h1 h2 )_t 1912 IMPLICIT NONE 1913#include "global.fh" 1914#include "mafdecls.fh" 1915#include "sym.fh" 1916#include "errquit.fh" 1917#include "tce.fh" 1918 INTEGER d_a 1919 INTEGER k_a_offset 1920 INTEGER d_b 1921 INTEGER k_b_offset 1922 INTEGER d_c 1923 INTEGER k_c_offset 1924 INTEGER NXTASK 1925 INTEGER next 1926 INTEGER nprocs 1927 INTEGER count 1928 INTEGER p5b 1929 INTEGER h9b 1930 INTEGER h1b 1931 INTEGER h2b 1932 INTEGER dimc 1933 INTEGER l_c_sort 1934 INTEGER k_c_sort 1935 INTEGER p10b 1936 INTEGER h9b_1 1937 INTEGER p10b_1 1938 INTEGER p5b_2 1939 INTEGER p10b_2 1940 INTEGER h1b_2 1941 INTEGER h2b_2 1942 INTEGER dim_common 1943 INTEGER dima_sort 1944 INTEGER dima 1945 INTEGER dimb_sort 1946 INTEGER dimb 1947 INTEGER l_a_sort 1948 INTEGER k_a_sort 1949 INTEGER l_a 1950 INTEGER k_a 1951 INTEGER l_b_sort 1952 INTEGER k_b_sort 1953 INTEGER l_b 1954 INTEGER k_b 1955 INTEGER l_c 1956 INTEGER k_c 1957 EXTERNAL NXTASK 1958 nprocs = GA_NNODES() 1959 count = 0 1960 next = NXTASK(nprocs,1) 1961 DO p5b = noab+1,noab+nvab 1962 DO h9b = 1,noab 1963 DO h1b = 1,noab 1964 DO h2b = h1b,noab 1965 IF (next.eq.count) THEN 1966 IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+h9b-1 1967 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1968 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 1969 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1970 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 1971 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_o,irrep_t)) TH 1972 &EN 1973 dimc = int_mb(k_range+p5b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 1974 &nge+h1b-1) * int_mb(k_range+h2b-1) 1975 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1976 & ERRQUIT('ccsdtq_o4_5_1',0,MA_ERR) 1977 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1978 DO p10b = noab+1,noab+nvab 1979 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p10b-1)) THEN 1980 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p10b-1)) .eq. irrep_o) T 1981 &HEN 1982 CALL TCE_RESTRICTED_2(h9b,p10b,h9b_1,p10b_1) 1983 CALL TCE_RESTRICTED_4(p5b,p10b,h1b,h2b,p5b_2,p10b_2,h1b_2,h2b_2) 1984 dim_common = int_mb(k_range+p10b-1) 1985 dima_sort = int_mb(k_range+h9b-1) 1986 dima = dim_common * dima_sort 1987 dimb_sort = int_mb(k_range+p5b-1) * int_mb(k_range+h1b-1) * int_mb 1988 &(k_range+h2b-1) 1989 dimb = dim_common * dimb_sort 1990 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1991 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1992 & ERRQUIT('ccsdtq_o4_5_1',1,MA_ERR) 1993 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1994 &ccsdtq_o4_5_1',2,MA_ERR) 1995 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 1996 &1 - 1 + (noab+nvab) * (h9b_1 - 1))) 1997 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 1998 &,int_mb(k_range+p10b-1),1,2,1.0d0) 1999 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o4_5_1',3,MA_ERR) 2000 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2001 & ERRQUIT('ccsdtq_o4_5_1',4,MA_ERR) 2002 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2003 &ccsdtq_o4_5_1',5,MA_ERR) 2004 IF ((p10b .lt. p5b)) THEN 2005 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 2006 & - 1 + noab * (h1b_2 - 1 + noab * (p5b_2 - noab - 1 + nvab * (p10b 2007 &_2 - noab - 1))))) 2008 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p10b-1 2009 &),int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 2010 &),4,3,2,1,-1.0d0) 2011 END IF 2012 IF ((p5b .le. p10b)) THEN 2013 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 2014 & - 1 + noab * (h1b_2 - 1 + noab * (p10b_2 - noab - 1 + nvab * (p5b 2015 &_2 - noab - 1))))) 2016 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 2017 &,int_mb(k_range+p10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 2018 &),4,3,1,2,1.0d0) 2019 END IF 2020 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o4_5_1',6,MA_ERR) 2021 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2022 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2023 &t),dima_sort) 2024 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o4_5_1',7,MA 2025 &_ERR) 2026 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o4_5_1',8,MA 2027 &_ERR) 2028 END IF 2029 END IF 2030 END IF 2031 END DO 2032 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2033 &ccsdtq_o4_5_1',9,MA_ERR) 2034 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 2035 &,int_mb(k_range+h1b-1),int_mb(k_range+p5b-1),int_mb(k_range+h9b-1) 2036 &,3,4,2,1,-1.0d0) 2037 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 2038 & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p5b - noab - 1))) 2039 &)) 2040 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o4_5_1',10,MA_ERR 2041 &) 2042 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o4_5_1',11,M 2043 &A_ERR) 2044 END IF 2045 END IF 2046 END IF 2047 next = NXTASK(nprocs,1) 2048 END IF 2049 count = count + 1 2050 END DO 2051 END DO 2052 END DO 2053 END DO 2054 next = NXTASK(-nprocs,1) 2055 call GA_SYNC() 2056 RETURN 2057 END 2058 SUBROUTINE OFFSET_ccsdtq_o4_5_1(l_a_offset,k_a_offset,size) 2059C $Id$ 2060C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2061C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2062C i1 ( h9 p5 h1 h2 )_ot 2063 IMPLICIT NONE 2064#include "global.fh" 2065#include "mafdecls.fh" 2066#include "sym.fh" 2067#include "errquit.fh" 2068#include "tce.fh" 2069 INTEGER l_a_offset 2070 INTEGER k_a_offset 2071 INTEGER size 2072 INTEGER length 2073 INTEGER addr 2074 INTEGER p5b 2075 INTEGER h9b 2076 INTEGER h1b 2077 INTEGER h2b 2078 length = 0 2079 DO p5b = noab+1,noab+nvab 2080 DO h9b = 1,noab 2081 DO h1b = 1,noab 2082 DO h2b = h1b,noab 2083 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 2084 &1b-1)+int_mb(k_spin+h2b-1)) THEN 2085 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 2086 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_o,irrep_t)) TH 2087 &EN 2088 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1 2089 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 2090 length = length + 1 2091 END IF 2092 END IF 2093 END IF 2094 END DO 2095 END DO 2096 END DO 2097 END DO 2098 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2099 &set)) CALL ERRQUIT('ccsdtq_o4_5_1',0,MA_ERR) 2100 int_mb(k_a_offset) = length 2101 addr = 0 2102 size = 0 2103 DO p5b = noab+1,noab+nvab 2104 DO h9b = 1,noab 2105 DO h1b = 1,noab 2106 DO h2b = h1b,noab 2107 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 2108 &1b-1)+int_mb(k_spin+h2b-1)) THEN 2109 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 2110 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_o,irrep_t)) TH 2111 &EN 2112 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1 2113 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 2114 addr = addr + 1 2115 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h9b 2116 &- 1 + noab * (p5b - noab - 1))) 2117 int_mb(k_a_offset+length+addr) = size 2118 size = size + int_mb(k_range+p5b-1) * int_mb(k_range+h9b-1) * int_ 2119 &mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 2120 END IF 2121 END IF 2122 END IF 2123 END DO 2124 END DO 2125 END DO 2126 END DO 2127 RETURN 2128 END 2129 SUBROUTINE ccsdtq_o4_6(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 2130 &t) 2131C $Id$ 2132C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2133C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2134C i0 ( p5 p6 p7 p8 h1 h2 h3 h4 )_ott + = -1 * P( 24 ) * Sum ( h9 ) * t ( p5 p6 h1 h9 )_t * i1 ( h9 p7 p8 h2 h3 h4 )_ot 2135 IMPLICIT NONE 2136#include "global.fh" 2137#include "mafdecls.fh" 2138#include "sym.fh" 2139#include "errquit.fh" 2140#include "tce.fh" 2141 INTEGER d_a 2142 INTEGER k_a_offset 2143 INTEGER d_b 2144 INTEGER k_b_offset 2145 INTEGER d_c 2146 INTEGER k_c_offset 2147 INTEGER NXTASK 2148 INTEGER next 2149 INTEGER nprocs 2150 INTEGER count 2151 INTEGER p5b 2152 INTEGER p6b 2153 INTEGER p7b 2154 INTEGER p8b 2155 INTEGER h1b 2156 INTEGER h2b 2157 INTEGER h3b 2158 INTEGER h4b 2159 INTEGER dimc 2160 INTEGER l_c_sort 2161 INTEGER k_c_sort 2162 INTEGER h9b 2163 INTEGER p5b_1 2164 INTEGER p6b_1 2165 INTEGER h1b_1 2166 INTEGER h9b_1 2167 INTEGER p7b_2 2168 INTEGER p8b_2 2169 INTEGER h9b_2 2170 INTEGER h2b_2 2171 INTEGER h3b_2 2172 INTEGER h4b_2 2173 INTEGER dim_common 2174 INTEGER dima_sort 2175 INTEGER dima 2176 INTEGER dimb_sort 2177 INTEGER dimb 2178 INTEGER l_a_sort 2179 INTEGER k_a_sort 2180 INTEGER l_a 2181 INTEGER k_a 2182 INTEGER l_b_sort 2183 INTEGER k_b_sort 2184 INTEGER l_b 2185 INTEGER k_b 2186 INTEGER l_c 2187 INTEGER k_c 2188 EXTERNAL NXTASK 2189 nprocs = GA_NNODES() 2190 count = 0 2191 next = NXTASK(nprocs,1) 2192 DO p5b = noab+1,noab+nvab 2193 DO p6b = p5b,noab+nvab 2194 DO p7b = noab+1,noab+nvab 2195 DO p8b = p7b,noab+nvab 2196 DO h1b = 1,noab 2197 DO h2b = 1,noab 2198 DO h3b = h2b,noab 2199 DO h4b = h3b,noab 2200 IF (next.eq.count) THEN 2201 IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1 2202 &)+int_mb(k_spin+p7b-1)+int_mb(k_spin+p8b-1)+int_mb(k_spin+h1b-1)+i 2203 &nt_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.1 2204 &6)) THEN 2205 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) 2206 &+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 2207 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) THEN 2208 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 2209 &k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h1b-1),ieo 2210 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1) 2211 &))))))) .eq. ieor(irrep_o,ieor(irrep_t,irrep_t))) THEN 2212 dimc = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb(k_ra 2213 &nge+p7b-1) * int_mb(k_range+p8b-1) * int_mb(k_range+h1b-1) * int_m 2214 &b(k_range+h2b-1) * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 2215 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2216 & ERRQUIT('ccsdtq_o4_6',0,MA_ERR) 2217 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2218 DO h9b = 1,noab 2219 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 2220 &1b-1)+int_mb(k_spin+h9b-1)) THEN 2221 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 2222 &k_sym+h1b-1),int_mb(k_sym+h9b-1)))) .eq. irrep_t) THEN 2223 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h9b,p5b_1,p6b_1,h1b_1,h9b_1) 2224 CALL TCE_RESTRICTED_6(p7b,p8b,h9b,h2b,h3b,h4b,p7b_2,p8b_2,h9b_2,h2 2225 &b_2,h3b_2,h4b_2) 2226 dim_common = int_mb(k_range+h9b-1) 2227 dima_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb 2228 &(k_range+h1b-1) 2229 dima = dim_common * dima_sort 2230 dimb_sort = int_mb(k_range+p7b-1) * int_mb(k_range+p8b-1) * int_mb 2231 &(k_range+h2b-1) * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 2232 dimb = dim_common * dimb_sort 2233 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2234 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2235 & ERRQUIT('ccsdtq_o4_6',1,MA_ERR) 2236 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2237 &ccsdtq_o4_6',2,MA_ERR) 2238 IF ((h9b .lt. h1b)) THEN 2239 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2240 & - 1 + noab * (h9b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 2241 &1 - noab - 1))))) 2242 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 2243 &,int_mb(k_range+p6b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1) 2244 &,4,2,1,3,-1.0d0) 2245 END IF 2246 IF ((h1b .le. h9b)) THEN 2247 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h9b_1 2248 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 2249 &1 - noab - 1))))) 2250 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 2251 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h9b-1) 2252 &,3,2,1,4,1.0d0) 2253 END IF 2254 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o4_6',3,MA_ERR) 2255 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2256 & ERRQUIT('ccsdtq_o4_6',4,MA_ERR) 2257 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2258 &ccsdtq_o4_6',5,MA_ERR) 2259 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 2260 & - 1 + noab * (h3b_2 - 1 + noab * (h2b_2 - 1 + noab * (h9b_2 - 1 + 2261 & noab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1))))))) 2262 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p7b-1) 2263 &,int_mb(k_range+p8b-1),int_mb(k_range+h9b-1),int_mb(k_range+h2b-1) 2264 &,int_mb(k_range+h3b-1),int_mb(k_range+h4b-1),6,5,4,2,1,3,1.0d0) 2265 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o4_6',6,MA_ERR) 2266 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2267 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2268 &t),dima_sort) 2269 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o4_6',7,MA_E 2270 &RR) 2271 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o4_6',8,MA_E 2272 &RR) 2273 END IF 2274 END IF 2275 END IF 2276 END DO 2277 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2278 &ccsdtq_o4_6',9,MA_ERR) 2279 IF ((p6b .le. p7b) .and. (h1b .le. h2b)) THEN 2280 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2281 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2282 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2283 &,int_mb(k_range+p5b-1),8,7,5,4,6,3,2,1,-1.0d0) 2284 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2285 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 2286 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 2287 &+ nvab * (p5b - noab - 1))))))))) 2288 END IF 2289 IF ((p6b .le. p7b) .and. (h2b .le. h1b) .and. (h1b .le. h3b)) THEN 2290 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2291 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2292 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2293 &,int_mb(k_range+p5b-1),8,7,5,4,3,6,2,1,1.0d0) 2294 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2295 & 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * 2296 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 2297 &+ nvab * (p5b - noab - 1))))))))) 2298 END IF 2299 IF ((p6b .le. p7b) .and. (h3b .le. h1b) .and. (h1b .le. h4b)) THEN 2300 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2301 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2302 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2303 &,int_mb(k_range+p5b-1),8,7,5,4,3,2,6,1,-1.0d0) 2304 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2305 & 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2306 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 2307 &+ nvab * (p5b - noab - 1))))))))) 2308 END IF 2309 IF ((p6b .le. p7b) .and. (h4b .le. h1b)) THEN 2310 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2311 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2312 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2313 &,int_mb(k_range+p5b-1),8,7,5,4,3,2,1,6,1.0d0) 2314 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2315 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2316 &(p8b - noab - 1 + nvab * (p7b - noab - 1 + nvab * (p6b - noab - 1 2317 &+ nvab * (p5b - noab - 1))))))))) 2318 END IF 2319 IF ((p7b .le. p5b) .and. (p6b .le. p8b) .and. (h1b .le. h2b)) THEN 2320 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2321 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2322 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2323 &,int_mb(k_range+p5b-1),5,8,7,4,6,3,2,1,-1.0d0) 2324 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2325 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 2326 &(p8b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1 2327 &+ nvab * (p7b - noab - 1))))))))) 2328 END IF 2329 IF ((p7b .le. p5b) .and. (p6b .le. p8b) .and. (h2b .le. h1b) .and. 2330 & (h1b .le. h3b)) THEN 2331 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2332 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2333 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2334 &,int_mb(k_range+p5b-1),5,8,7,4,3,6,2,1,1.0d0) 2335 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2336 & 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * 2337 &(p8b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1 2338 &+ nvab * (p7b - noab - 1))))))))) 2339 END IF 2340 IF ((p7b .le. p5b) .and. (p6b .le. p8b) .and. (h3b .le. h1b) .and. 2341 & (h1b .le. h4b)) THEN 2342 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2343 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2344 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2345 &,int_mb(k_range+p5b-1),5,8,7,4,3,2,6,1,-1.0d0) 2346 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2347 & 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2348 &(p8b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1 2349 &+ nvab * (p7b - noab - 1))))))))) 2350 END IF 2351 IF ((p7b .le. p5b) .and. (p6b .le. p8b) .and. (h4b .le. h1b)) THEN 2352 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2353 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2354 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2355 &,int_mb(k_range+p5b-1),5,8,7,4,3,2,1,6,1.0d0) 2356 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2357 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2358 &(p8b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p5b - noab - 1 2359 &+ nvab * (p7b - noab - 1))))))))) 2360 END IF 2361 IF ((p5b .le. p7b) .and. (p7b .le. p6b) .and. (p6b .le. p8b) .and. 2362 & (h1b .le. h2b)) THEN 2363 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2364 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2365 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2366 &,int_mb(k_range+p5b-1),8,5,7,4,6,3,2,1,1.0d0) 2367 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2368 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 2369 &(p8b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p7b - noab - 1 2370 &+ nvab * (p5b - noab - 1))))))))) 2371 END IF 2372 IF ((p5b .le. p7b) .and. (p7b .le. p6b) .and. (p6b .le. p8b) .and. 2373 & (h2b .le. h1b) .and. (h1b .le. h3b)) THEN 2374 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2375 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2376 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2377 &,int_mb(k_range+p5b-1),8,5,7,4,3,6,2,1,-1.0d0) 2378 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2379 & 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * 2380 &(p8b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p7b - noab - 1 2381 &+ nvab * (p5b - noab - 1))))))))) 2382 END IF 2383 IF ((p5b .le. p7b) .and. (p7b .le. p6b) .and. (p6b .le. p8b) .and. 2384 & (h3b .le. h1b) .and. (h1b .le. h4b)) THEN 2385 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2386 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2387 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2388 &,int_mb(k_range+p5b-1),8,5,7,4,3,2,6,1,1.0d0) 2389 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2390 & 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2391 &(p8b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p7b - noab - 1 2392 &+ nvab * (p5b - noab - 1))))))))) 2393 END IF 2394 IF ((p5b .le. p7b) .and. (p7b .le. p6b) .and. (p6b .le. p8b) .and. 2395 & (h4b .le. h1b)) THEN 2396 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2397 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2398 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2399 &,int_mb(k_range+p5b-1),8,5,7,4,3,2,1,6,-1.0d0) 2400 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2401 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2402 &(p8b - noab - 1 + nvab * (p6b - noab - 1 + nvab * (p7b - noab - 1 2403 &+ nvab * (p5b - noab - 1))))))))) 2404 END IF 2405 IF ((p7b .le. p5b) .and. (p5b .le. p8b) .and. (p8b .le. p6b) .and. 2406 & (h1b .le. h2b)) THEN 2407 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2408 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2409 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2410 &,int_mb(k_range+p5b-1),5,8,4,7,6,3,2,1,1.0d0) 2411 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2412 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 2413 &(p6b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p5b - noab - 1 2414 &+ nvab * (p7b - noab - 1))))))))) 2415 END IF 2416 IF ((p7b .le. p5b) .and. (p5b .le. p8b) .and. (p8b .le. p6b) .and. 2417 & (h2b .le. h1b) .and. (h1b .le. h3b)) THEN 2418 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2419 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2420 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2421 &,int_mb(k_range+p5b-1),5,8,4,7,3,6,2,1,-1.0d0) 2422 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2423 & 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * 2424 &(p6b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p5b - noab - 1 2425 &+ nvab * (p7b - noab - 1))))))))) 2426 END IF 2427 IF ((p7b .le. p5b) .and. (p5b .le. p8b) .and. (p8b .le. p6b) .and. 2428 & (h3b .le. h1b) .and. (h1b .le. h4b)) THEN 2429 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2430 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2431 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2432 &,int_mb(k_range+p5b-1),5,8,4,7,3,2,6,1,1.0d0) 2433 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2434 & 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2435 &(p6b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p5b - noab - 1 2436 &+ nvab * (p7b - noab - 1))))))))) 2437 END IF 2438 IF ((p7b .le. p5b) .and. (p5b .le. p8b) .and. (p8b .le. p6b) .and. 2439 & (h4b .le. h1b)) THEN 2440 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2441 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2442 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2443 &,int_mb(k_range+p5b-1),5,8,4,7,3,2,1,6,-1.0d0) 2444 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2445 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2446 &(p6b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p5b - noab - 1 2447 &+ nvab * (p7b - noab - 1))))))))) 2448 END IF 2449 IF ((p5b .le. p7b) .and. (p8b .le. p6b) .and. (h1b .le. h2b)) THEN 2450 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2451 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2452 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2453 &,int_mb(k_range+p5b-1),8,5,4,7,6,3,2,1,-1.0d0) 2454 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2455 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 2456 &(p6b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p7b - noab - 1 2457 &+ nvab * (p5b - noab - 1))))))))) 2458 END IF 2459 IF ((p5b .le. p7b) .and. (p8b .le. p6b) .and. (h2b .le. h1b) .and. 2460 & (h1b .le. h3b)) THEN 2461 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2462 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2463 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2464 &,int_mb(k_range+p5b-1),8,5,4,7,3,6,2,1,1.0d0) 2465 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2466 & 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * 2467 &(p6b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p7b - noab - 1 2468 &+ nvab * (p5b - noab - 1))))))))) 2469 END IF 2470 IF ((p5b .le. p7b) .and. (p8b .le. p6b) .and. (h3b .le. h1b) .and. 2471 & (h1b .le. h4b)) THEN 2472 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2473 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2474 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2475 &,int_mb(k_range+p5b-1),8,5,4,7,3,2,6,1,-1.0d0) 2476 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2477 & 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2478 &(p6b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p7b - noab - 1 2479 &+ nvab * (p5b - noab - 1))))))))) 2480 END IF 2481 IF ((p5b .le. p7b) .and. (p8b .le. p6b) .and. (h4b .le. h1b)) THEN 2482 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2483 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2484 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2485 &,int_mb(k_range+p5b-1),8,5,4,7,3,2,1,6,1.0d0) 2486 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2487 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2488 &(p6b - noab - 1 + nvab * (p8b - noab - 1 + nvab * (p7b - noab - 1 2489 &+ nvab * (p5b - noab - 1))))))))) 2490 END IF 2491 IF ((p8b .le. p5b) .and. (h1b .le. h2b)) THEN 2492 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2493 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2494 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2495 &,int_mb(k_range+p5b-1),5,4,8,7,6,3,2,1,-1.0d0) 2496 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2497 & 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * 2498 &(p6b - noab - 1 + nvab * (p5b - noab - 1 + nvab * (p8b - noab - 1 2499 &+ nvab * (p7b - noab - 1))))))))) 2500 END IF 2501 IF ((p8b .le. p5b) .and. (h2b .le. h1b) .and. (h1b .le. h3b)) THEN 2502 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2503 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2504 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2505 &,int_mb(k_range+p5b-1),5,4,8,7,3,6,2,1,1.0d0) 2506 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2507 & 1 + noab * (h3b - 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * 2508 &(p6b - noab - 1 + nvab * (p5b - noab - 1 + nvab * (p8b - noab - 1 2509 &+ nvab * (p7b - noab - 1))))))))) 2510 END IF 2511 IF ((p8b .le. p5b) .and. (h3b .le. h1b) .and. (h1b .le. h4b)) THEN 2512 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2513 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2514 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2515 &,int_mb(k_range+p5b-1),5,4,8,7,3,2,6,1,-1.0d0) 2516 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 2517 & 1 + noab * (h1b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2518 &(p6b - noab - 1 + nvab * (p5b - noab - 1 + nvab * (p8b - noab - 1 2519 &+ nvab * (p7b - noab - 1))))))))) 2520 END IF 2521 IF ((p8b .le. p5b) .and. (h4b .le. h1b)) THEN 2522 CALL TCE_SORT_8(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 2523 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 2524 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2525 &,int_mb(k_range+p5b-1),5,4,8,7,3,2,1,6,1.0d0) 2526 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2527 & 1 + noab * (h4b - 1 + noab * (h3b - 1 + noab * (h2b - 1 + noab * 2528 &(p6b - noab - 1 + nvab * (p5b - noab - 1 + nvab * (p8b - noab - 1 2529 &+ nvab * (p7b - noab - 1))))))))) 2530 END IF 2531 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o4_6',10,MA_ERR) 2532 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o4_6',11,MA_ 2533 &ERR) 2534 END IF 2535 END IF 2536 END IF 2537 next = NXTASK(nprocs,1) 2538 END IF 2539 count = count + 1 2540 END DO 2541 END DO 2542 END DO 2543 END DO 2544 END DO 2545 END DO 2546 END DO 2547 END DO 2548 next = NXTASK(-nprocs,1) 2549 call GA_SYNC() 2550 RETURN 2551 END 2552 SUBROUTINE ccsdtq_o4_6_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 2553 &set) 2554C $Id$ 2555C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2556C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2557C i1 ( h9 p5 p6 h1 h2 h3 )_ot + = 1 * Sum ( p10 ) * o ( h9 p10 )_o * t ( p5 p6 p10 h1 h2 h3 )_t 2558 IMPLICIT NONE 2559#include "global.fh" 2560#include "mafdecls.fh" 2561#include "sym.fh" 2562#include "errquit.fh" 2563#include "tce.fh" 2564 INTEGER d_a 2565 INTEGER k_a_offset 2566 INTEGER d_b 2567 INTEGER k_b_offset 2568 INTEGER d_c 2569 INTEGER k_c_offset 2570 INTEGER NXTASK 2571 INTEGER next 2572 INTEGER nprocs 2573 INTEGER count 2574 INTEGER p5b 2575 INTEGER p6b 2576 INTEGER h9b 2577 INTEGER h1b 2578 INTEGER h2b 2579 INTEGER h3b 2580 INTEGER dimc 2581 INTEGER l_c_sort 2582 INTEGER k_c_sort 2583 INTEGER p10b 2584 INTEGER h9b_1 2585 INTEGER p10b_1 2586 INTEGER p5b_2 2587 INTEGER p6b_2 2588 INTEGER p10b_2 2589 INTEGER h1b_2 2590 INTEGER h2b_2 2591 INTEGER h3b_2 2592 INTEGER dim_common 2593 INTEGER dima_sort 2594 INTEGER dima 2595 INTEGER dimb_sort 2596 INTEGER dimb 2597 INTEGER l_a_sort 2598 INTEGER k_a_sort 2599 INTEGER l_a 2600 INTEGER k_a 2601 INTEGER l_b_sort 2602 INTEGER k_b_sort 2603 INTEGER l_b 2604 INTEGER k_b 2605 INTEGER l_c 2606 INTEGER k_c 2607 EXTERNAL NXTASK 2608 nprocs = GA_NNODES() 2609 count = 0 2610 next = NXTASK(nprocs,1) 2611 DO p5b = noab+1,noab+nvab 2612 DO p6b = p5b,noab+nvab 2613 DO h9b = 1,noab 2614 DO h1b = 1,noab 2615 DO h2b = h1b,noab 2616 DO h3b = h2b,noab 2617 IF (next.eq.count) THEN 2618 IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1 2619 &)+int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 2620 &nt_mb(k_spin+h3b-1).ne.12)) THEN 2621 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h9b-1) 2622 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 2623 &1)) THEN 2624 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 2625 &k_sym+h9b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 2626 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_o,irrep_t)) THEN 2627 dimc = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb(k_ra 2628 &nge+h9b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 2629 &b(k_range+h3b-1) 2630 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2631 & ERRQUIT('ccsdtq_o4_6_1',0,MA_ERR) 2632 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2633 DO p10b = noab+1,noab+nvab 2634 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p10b-1)) THEN 2635 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p10b-1)) .eq. irrep_o) T 2636 &HEN 2637 CALL TCE_RESTRICTED_2(h9b,p10b,h9b_1,p10b_1) 2638 CALL TCE_RESTRICTED_6(p5b,p6b,p10b,h1b,h2b,h3b,p5b_2,p6b_2,p10b_2, 2639 &h1b_2,h2b_2,h3b_2) 2640 dim_common = int_mb(k_range+p10b-1) 2641 dima_sort = int_mb(k_range+h9b-1) 2642 dima = dim_common * dima_sort 2643 dimb_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb 2644 &(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_mb(k_range+h3b-1) 2645 dimb = dim_common * dimb_sort 2646 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2647 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2648 & ERRQUIT('ccsdtq_o4_6_1',1,MA_ERR) 2649 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2650 &ccsdtq_o4_6_1',2,MA_ERR) 2651 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 2652 &1 - 1 + (noab+nvab) * (h9b_1 - 1))) 2653 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 2654 &,int_mb(k_range+p10b-1),1,2,1.0d0) 2655 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o4_6_1',3,MA_ERR) 2656 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2657 & ERRQUIT('ccsdtq_o4_6_1',4,MA_ERR) 2658 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2659 &ccsdtq_o4_6_1',5,MA_ERR) 2660 IF ((p10b .lt. p5b)) THEN 2661 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 2662 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (p6b_2 - noa 2663 &b - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p10b_2 - noab - 1)))))) 2664 &) 2665 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p10b-1 2666 &),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1 2667 &),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,4,3,2,1,1.0d0) 2668 END IF 2669 IF ((p5b .le. p10b) .and. (p10b .lt. p6b)) THEN 2670 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 2671 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (p6b_2 - noa 2672 &b - 1 + nvab * (p10b_2 - noab - 1 + nvab * (p5b_2 - noab - 1)))))) 2673 &) 2674 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 2675 &,int_mb(k_range+p10b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1 2676 &),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,4,3,1,2,-1.0d0) 2677 END IF 2678 IF ((p6b .le. p10b)) THEN 2679 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 2680 & - 1 + noab * (h2b_2 - 1 + noab * (h1b_2 - 1 + noab * (p10b_2 - no 2681 &ab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1)))))) 2682 &) 2683 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1) 2684 &,int_mb(k_range+p6b-1),int_mb(k_range+p10b-1),int_mb(k_range+h1b-1 2685 &),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1),6,5,4,2,1,3,1.0d0) 2686 END IF 2687 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o4_6_1',6,MA_ERR) 2688 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2689 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2690 &t),dima_sort) 2691 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o4_6_1',7,MA 2692 &_ERR) 2693 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o4_6_1',8,MA 2694 &_ERR) 2695 END IF 2696 END IF 2697 END IF 2698 END DO 2699 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2700 &ccsdtq_o4_6_1',9,MA_ERR) 2701 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 2702 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 2703 &,int_mb(k_range+p5b-1),int_mb(k_range+h9b-1),5,4,6,3,2,1,1.0d0) 2704 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 2705 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * 2706 &(p6b - noab - 1 + nvab * (p5b - noab - 1))))))) 2707 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o4_6_1',10,MA_ERR 2708 &) 2709 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o4_6_1',11,M 2710 &A_ERR) 2711 END IF 2712 END IF 2713 END IF 2714 next = NXTASK(nprocs,1) 2715 END IF 2716 count = count + 1 2717 END DO 2718 END DO 2719 END DO 2720 END DO 2721 END DO 2722 END DO 2723 next = NXTASK(-nprocs,1) 2724 call GA_SYNC() 2725 RETURN 2726 END 2727 SUBROUTINE OFFSET_ccsdtq_o4_6_1(l_a_offset,k_a_offset,size) 2728C $Id$ 2729C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2730C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2731C i1 ( h9 p5 p6 h1 h2 h3 )_ot 2732 IMPLICIT NONE 2733#include "global.fh" 2734#include "mafdecls.fh" 2735#include "sym.fh" 2736#include "errquit.fh" 2737#include "tce.fh" 2738 INTEGER l_a_offset 2739 INTEGER k_a_offset 2740 INTEGER size 2741 INTEGER length 2742 INTEGER addr 2743 INTEGER p5b 2744 INTEGER p6b 2745 INTEGER h9b 2746 INTEGER h1b 2747 INTEGER h2b 2748 INTEGER h3b 2749 length = 0 2750 DO p5b = noab+1,noab+nvab 2751 DO p6b = p5b,noab+nvab 2752 DO h9b = 1,noab 2753 DO h1b = 1,noab 2754 DO h2b = h1b,noab 2755 DO h3b = h2b,noab 2756 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 2757 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 2758 &1)) THEN 2759 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 2760 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 2761 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_o,irrep_t)) THEN 2762 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1 2763 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 2764 &nt_mb(k_spin+h3b-1).ne.12)) THEN 2765 length = length + 1 2766 END IF 2767 END IF 2768 END IF 2769 END DO 2770 END DO 2771 END DO 2772 END DO 2773 END DO 2774 END DO 2775 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2776 &set)) CALL ERRQUIT('ccsdtq_o4_6_1',0,MA_ERR) 2777 int_mb(k_a_offset) = length 2778 addr = 0 2779 size = 0 2780 DO p5b = noab+1,noab+nvab 2781 DO p6b = p5b,noab+nvab 2782 DO h9b = 1,noab 2783 DO h1b = 1,noab 2784 DO h2b = h1b,noab 2785 DO h3b = h2b,noab 2786 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 2787 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 2788 &1)) THEN 2789 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 2790 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 2791 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_o,irrep_t)) THEN 2792 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p5b-1 2793 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 2794 &nt_mb(k_spin+h3b-1).ne.12)) THEN 2795 addr = addr + 1 2796 int_mb(k_a_offset+addr) = h3b - 1 + noab * (h2b - 1 + noab * (h1b 2797 &- 1 + noab * (h9b - 1 + noab * (p6b - noab - 1 + nvab * (p5b - noa 2798 &b - 1))))) 2799 int_mb(k_a_offset+length+addr) = size 2800 size = size + int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_ 2801 &mb(k_range+h9b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 2802 &* int_mb(k_range+h3b-1) 2803 END IF 2804 END IF 2805 END IF 2806 END DO 2807 END DO 2808 END DO 2809 END DO 2810 END DO 2811 END DO 2812 RETURN 2813 END 2814