1 SUBROUTINE cc2_x1(d_f1,d_i0,d_t1,d_t2,d_v2,d_x1,d_x2,k_f1_offset,k 2 &_i0_offset,k_t1_offset,k_t2_offset,k_v2_offset,k_x1_offset,k_x2_of 3 &fset) 4C $Id$ 5C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7C i0 ( p2 h1 )_xf + = -1 * Sum ( h6 ) * x ( p2 h6 )_x * i1 ( h6 h1 )_f 8C i1 ( h6 h1 )_f + = 1 * f ( h6 h1 )_f 9C i1 ( h6 h1 )_ft + = 1 * Sum ( p7 ) * t ( p7 h1 )_t * i2 ( h6 p7 )_f 10C i2 ( h6 p7 )_f + = 1 * f ( h6 p7 )_f 11C i2 ( h6 p7 )_vt + = 1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 h6 p4 p7 )_v 12C i1 ( h6 h1 )_vt + = -1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 h6 h1 p3 )_v 13C i1 ( h6 h1 )_vt + = -1/2 * Sum ( h5 p3 p4 ) * t ( p3 p4 h1 h5 )_t * v ( h5 h6 p3 p4 )_v 14C i0 ( p2 h1 )_xf + = 1 * Sum ( p6 ) * x ( p6 h1 )_x * i1 ( p2 p6 )_f 15C i1 ( p2 p6 )_f + = 1 * f ( p2 p6 )_f 16C i1 ( p2 p6 )_vt + = 1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 p2 p3 p6 )_v 17C i0 ( p2 h1 )_xv + = -1 * Sum ( p4 h3 ) * x ( p4 h3 )_x * v ( h3 p2 h1 p4 )_v 18C i0 ( p2 h1 )_xf + = 1 * Sum ( p7 h6 ) * x ( p2 p7 h1 h6 )_x * i1 ( h6 p7 )_f 19C i1 ( h6 p7 )_f + = 1 * f ( h6 p7 )_f 20C i1 ( h6 p7 )_vt + = 1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 h6 p3 p7 )_v 21C i0 ( p2 h1 )_xv + = -1/2 * Sum ( p7 h6 h8 ) * x ( p2 p7 h6 h8 )_x * i1 ( h6 h8 h1 p7 )_v 22C i1 ( h6 h8 h1 p7 )_v + = 1 * v ( h6 h8 h1 p7 )_v 23C i1 ( h6 h8 h1 p7 )_vt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * v ( h6 h8 p3 p7 )_v 24C i0 ( p2 h1 )_xv + = -1/2 * Sum ( p4 p5 h3 ) * x ( p4 p5 h1 h3 )_x * v ( h3 p2 p4 p5 )_v 25C i0 ( p2 h1 )_fxt + = -1 * Sum ( h8 ) * t ( p2 h8 )_t * i1 ( h8 h1 )_fx 26C i1 ( h8 h1 )_fx + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * i2 ( h8 p3 )_f 27C i2 ( h8 p3 )_f + = 1 * f ( h8 p3 )_f 28C i2 ( h8 p3 )_vt + = -1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 h8 p3 p4 )_v 29C i1 ( h8 h1 )_vx + = -1 * Sum ( h4 p5 ) * x ( p5 h4 )_x * v ( h4 h8 h1 p5 )_v 30C i1 ( h8 h1 )_vx + = -1/2 * Sum ( h4 p5 p6 ) * x ( p5 p6 h1 h4 )_x * v ( h4 h8 p5 p6 )_v 31C i1 ( h8 h1 )_vxt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * i2 ( h8 p3 )_vx 32C i2 ( h8 p3 )_vx + = -1 * Sum ( h5 p6 ) * x ( p6 h5 )_x * v ( h5 h8 p3 p6 )_v 33C i0 ( p2 h1 )_vxt + = -1 * Sum ( p3 ) * t ( p3 h1 )_t * i1 ( p2 p3 )_vx 34C i1 ( p2 p3 )_vx + = 1 * Sum ( h4 p5 ) * x ( p5 h4 )_x * v ( h4 p2 p3 p5 )_v 35C i0 ( p2 h1 )_vxt + = 1 * Sum ( h4 p3 ) * t ( p2 p3 h1 h4 )_t * i1 ( h4 p3 )_vx 36C i1 ( h4 p3 )_vx + = 1 * Sum ( h5 p6 ) * x ( p6 h5 )_x * v ( h4 h5 p3 p6 )_v 37C i0 ( p2 h1 )_vxt + = 1/2 * Sum ( h4 h5 p3 ) * t ( p2 p3 h4 h5 )_t * i1 ( h4 h5 h1 p3 )_vx 38C i1 ( h4 h5 h1 p3 )_vx + = 1 * Sum ( p6 ) * x ( p6 h1 )_x * v ( h4 h5 p3 p6 )_v 39 IMPLICIT NONE 40#include "global.fh" 41#include "mafdecls.fh" 42#include "util.fh" 43#include "errquit.fh" 44#include "tce.fh" 45 INTEGER d_i0 46 INTEGER k_i0_offset 47 INTEGER d_x1 48 INTEGER k_x1_offset 49 INTEGER d_i1 50 INTEGER k_i1_offset 51 INTEGER d_v2 52 INTEGER k_v2_offset 53 INTEGER d_x2 54 INTEGER k_x2_offset 55 INTEGER d_t1 56 INTEGER k_t1_offset 57 INTEGER d_t2 58 INTEGER k_t2_offset 59 INTEGER l_i1_offset 60 INTEGER d_f1 61 INTEGER k_f1_offset 62 INTEGER size_i1 63 INTEGER d_i2 64 INTEGER k_i2_offset 65 INTEGER l_i2_offset 66 INTEGER size_i2 67 CHARACTER*255 filename 68 CALL OFFSET_cc2_x1_1_1(l_i1_offset,k_i1_offset,size_i1) 69 CALL TCE_FILENAME('cc2_x1_1_1_i1',filename) 70 CALL CREATEFILE(filename,d_i1,size_i1) 71 CALL cc2_x1_1_1(d_f1,k_f1_offset,d_i1,k_i1_offset) 72 CALL OFFSET_cc2_x1_1_2_1(l_i2_offset,k_i2_offset,size_i2) 73 CALL TCE_FILENAME('cc2_x1_1_2_1_i2',filename) 74 CALL CREATEFILE(filename,d_i2,size_i2) 75 CALL cc2_x1_1_2_1(d_f1,k_f1_offset,d_i2,k_i2_offset) 76 CALL cc2_x1_1_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_offs 77 &et) 78 CALL RECONCILEFILE(d_i2,size_i2) 79 CALL cc2_x1_1_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k_i1_offset 80 &) 81 CALL DELETEFILE(d_i2) 82 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 83 &R) 84 CALL cc2_x1_1_3(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset 85 &) 86 CALL cc2_x1_1_4(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1,k_i1_offset 87 &) 88 CALL RECONCILEFILE(d_i1,size_i1) 89 CALL cc2_x1_1(d_x1,k_x1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset) 90 CALL DELETEFILE(d_i1) 91 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 92 &R) 93 CALL OFFSET_cc2_x1_2_1(l_i1_offset,k_i1_offset,size_i1) 94 CALL TCE_FILENAME('cc2_x1_2_1_i1',filename) 95 CALL CREATEFILE(filename,d_i1,size_i1) 96 CALL cc2_x1_2_1(d_f1,k_f1_offset,d_i1,k_i1_offset) 97 CALL cc2_x1_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset 98 &) 99 CALL RECONCILEFILE(d_i1,size_i1) 100 CALL cc2_x1_2(d_x1,k_x1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset) 101 CALL DELETEFILE(d_i1) 102 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 103 &R) 104 CALL cc2_x1_3(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i0,k_i0_offset) 105 CALL OFFSET_cc2_x1_4_1(l_i1_offset,k_i1_offset,size_i1) 106 CALL TCE_FILENAME('cc2_x1_4_1_i1',filename) 107 CALL CREATEFILE(filename,d_i1,size_i1) 108 CALL cc2_x1_4_1(d_f1,k_f1_offset,d_i1,k_i1_offset) 109 CALL cc2_x1_4_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset 110 &) 111 CALL RECONCILEFILE(d_i1,size_i1) 112 CALL cc2_x1_4(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset) 113 CALL DELETEFILE(d_i1) 114 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 115 &R) 116 CALL OFFSET_cc2_x1_5_1(l_i1_offset,k_i1_offset,size_i1) 117 CALL TCE_FILENAME('cc2_x1_5_1_i1',filename) 118 CALL CREATEFILE(filename,d_i1,size_i1) 119 CALL cc2_x1_5_1(d_v2,k_v2_offset,d_i1,k_i1_offset) 120 CALL cc2_x1_5_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset 121 &) 122 CALL RECONCILEFILE(d_i1,size_i1) 123 CALL cc2_x1_5(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset) 124 CALL DELETEFILE(d_i1) 125 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 126 &R) 127 CALL cc2_x1_6(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i0,k_i0_offset) 128 CALL OFFSET_cc2_x1_7_1(l_i1_offset,k_i1_offset,size_i1) 129 CALL TCE_FILENAME('cc2_x1_7_1_i1',filename) 130 CALL CREATEFILE(filename,d_i1,size_i1) 131 CALL OFFSET_cc2_x1_7_1_1(l_i2_offset,k_i2_offset,size_i2) 132 CALL TCE_FILENAME('cc2_x1_7_1_1_i2',filename) 133 CALL CREATEFILE(filename,d_i2,size_i2) 134 CALL cc2_x1_7_1_1(d_f1,k_f1_offset,d_i2,k_i2_offset) 135 CALL cc2_x1_7_1_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_offs 136 &et) 137 CALL RECONCILEFILE(d_i2,size_i2) 138 CALL cc2_x1_7_1(d_x1,k_x1_offset,d_i2,k_i2_offset,d_i1,k_i1_offset 139 &) 140 CALL DELETEFILE(d_i2) 141 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 142 &R) 143 CALL cc2_x1_7_2(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset 144 &) 145 CALL cc2_x1_7_3(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i1,k_i1_offset 146 &) 147 CALL OFFSET_cc2_x1_7_4_1(l_i2_offset,k_i2_offset,size_i2) 148 CALL TCE_FILENAME('cc2_x1_7_4_1_i2',filename) 149 CALL CREATEFILE(filename,d_i2,size_i2) 150 CALL cc2_x1_7_4_1(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i2,k_i2_offs 151 &et) 152 CALL RECONCILEFILE(d_i2,size_i2) 153 CALL cc2_x1_7_4(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k_i1_offset 154 &) 155 CALL DELETEFILE(d_i2) 156 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 157 &R) 158 CALL RECONCILEFILE(d_i1,size_i1) 159 CALL cc2_x1_7(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset) 160 CALL DELETEFILE(d_i1) 161 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 162 &R) 163 CALL OFFSET_cc2_x1_8_1(l_i1_offset,k_i1_offset,size_i1) 164 CALL TCE_FILENAME('cc2_x1_8_1_i1',filename) 165 CALL CREATEFILE(filename,d_i1,size_i1) 166 CALL cc2_x1_8_1(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset 167 &) 168 CALL RECONCILEFILE(d_i1,size_i1) 169 CALL cc2_x1_8(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset) 170 CALL DELETEFILE(d_i1) 171 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 172 &R) 173 CALL OFFSET_cc2_x1_9_1(l_i1_offset,k_i1_offset,size_i1) 174 CALL TCE_FILENAME('cc2_x1_9_1_i1',filename) 175 CALL CREATEFILE(filename,d_i1,size_i1) 176 CALL cc2_x1_9_1(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset 177 &) 178 CALL RECONCILEFILE(d_i1,size_i1) 179 CALL cc2_x1_9(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset) 180 CALL DELETEFILE(d_i1) 181 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 182 &R) 183 CALL OFFSET_cc2_x1_10_1(l_i1_offset,k_i1_offset,size_i1) 184 CALL TCE_FILENAME('cc2_x1_10_1_i1',filename) 185 CALL CREATEFILE(filename,d_i1,size_i1) 186 CALL cc2_x1_10_1(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i1,k_i1_offse 187 &t) 188 CALL RECONCILEFILE(d_i1,size_i1) 189 CALL cc2_x1_10(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset) 190 CALL DELETEFILE(d_i1) 191 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER 192 &R) 193 RETURN 194 END 195 SUBROUTINE cc2_x1_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 196C $Id$ 197C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 198C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 199C i0 ( p2 h1 )_xf + = -1 * Sum ( h6 ) * x ( p2 h6 )_x * i1 ( h6 h1 )_f 200 IMPLICIT NONE 201#include "global.fh" 202#include "mafdecls.fh" 203#include "sym.fh" 204#include "errquit.fh" 205#include "tce.fh" 206 INTEGER d_a 207 INTEGER k_a_offset 208 INTEGER d_b 209 INTEGER k_b_offset 210 INTEGER d_c 211 INTEGER k_c_offset 212 INTEGER NXTASK 213 INTEGER next 214 INTEGER nprocs 215 INTEGER count 216 INTEGER p2b 217 INTEGER h1b 218 INTEGER dimc 219 INTEGER l_c_sort 220 INTEGER k_c_sort 221 INTEGER h6b 222 INTEGER p2b_1 223 INTEGER h6b_1 224 INTEGER h6b_2 225 INTEGER h1b_2 226 INTEGER dim_common 227 INTEGER dima_sort 228 INTEGER dima 229 INTEGER dimb_sort 230 INTEGER dimb 231 INTEGER l_a_sort 232 INTEGER k_a_sort 233 INTEGER l_a 234 INTEGER k_a 235 INTEGER l_b_sort 236 INTEGER k_b_sort 237 INTEGER l_b 238 INTEGER k_b 239 INTEGER l_c 240 INTEGER k_c 241 EXTERNAL NXTASK 242 nprocs = GA_NNODES() 243 count = 0 244 next = NXTASK(nprocs,1) 245 DO p2b = noab+1,noab+nvab 246 DO h1b = 1,noab 247 IF (next.eq.count) THEN 248 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 249 &).ne.4)) THEN 250 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 251 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 252 &x,irrep_f)) THEN 253 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 254 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 255 & ERRQUIT('cc2_x1_1',0,MA_ERR) 256 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 257 DO h6b = 1,noab 258 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h6b-1)) THEN 259 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h6b-1)) .eq. irrep_x) TH 260 &EN 261 CALL TCE_RESTRICTED_2(p2b,h6b,p2b_1,h6b_1) 262 CALL TCE_RESTRICTED_2(h6b,h1b,h6b_2,h1b_2) 263 dim_common = int_mb(k_range+h6b-1) 264 dima_sort = int_mb(k_range+p2b-1) 265 dima = dim_common * dima_sort 266 dimb_sort = int_mb(k_range+h1b-1) 267 dimb = dim_common * dimb_sort 268 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 269 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 270 & ERRQUIT('cc2_x1_1',1,MA_ERR) 271 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 272 &cc2_x1_1',2,MA_ERR) 273 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 274 &int_mb(k_a_offset),(h6b_1 275 & - 1 + noab * (p2b_1 - noab - 1))) 276 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 277 &,int_mb(k_range+h6b-1),1,2,1.0d0) 278 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1',3,MA_ERR) 279 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 280 & ERRQUIT('cc2_x1_1',4,MA_ERR) 281 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 282 &cc2_x1_1',5,MA_ERR) 283 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 284 & - 1 + noab * (h6b_2 - 1))) 285 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 286 &,int_mb(k_range+h1b-1),2,1,1.0d0) 287 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_1',6,MA_ERR) 288 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 289 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 290 &t),dima_sort) 291 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_1',7,MA_ERR) 292 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1',8,MA_ERR) 293 END IF 294 END IF 295 END IF 296 END DO 297 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 298 &cc2_x1_1',9,MA_ERR) 299 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 300 &,int_mb(k_range+p2b-1),2,1,-1.0d0) 301 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 302 & 1 + noab * (p2b - noab - 1))) 303 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1',10,MA_ERR) 304 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_1',11,MA_ERR 305 &) 306 END IF 307 END IF 308 END IF 309 next = NXTASK(nprocs,1) 310 END IF 311 count = count + 1 312 END DO 313 END DO 314 next = NXTASK(-nprocs,1) 315 call GA_SYNC() 316 RETURN 317 END 318 SUBROUTINE cc2_x1_1_1(d_a,k_a_offset,d_c,k_c_offset) 319C $Id$ 320C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 321C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 322C i1 ( h6 h1 )_f + = 1 * f ( h6 h1 )_f 323 IMPLICIT NONE 324#include "global.fh" 325#include "mafdecls.fh" 326#include "sym.fh" 327#include "errquit.fh" 328#include "tce.fh" 329 INTEGER d_a 330 INTEGER k_a_offset 331 INTEGER d_c 332 INTEGER k_c_offset 333 INTEGER NXTASK 334 INTEGER next 335 INTEGER nprocs 336 INTEGER count 337 INTEGER h6b 338 INTEGER h1b 339 INTEGER dimc 340 INTEGER h6b_1 341 INTEGER h1b_1 342 INTEGER dim_common 343 INTEGER dima_sort 344 INTEGER dima 345 INTEGER l_a_sort 346 INTEGER k_a_sort 347 INTEGER l_a 348 INTEGER k_a 349 INTEGER l_c 350 INTEGER k_c 351 EXTERNAL NXTASK 352 nprocs = GA_NNODES() 353 count = 0 354 next = NXTASK(nprocs,1) 355 DO h6b = 1,noab 356 DO h1b = 1,noab 357 IF (next.eq.count) THEN 358 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1 359 &).ne.4)) THEN 360 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 361 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 362 &EN 363 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1) 364 CALL TCE_RESTRICTED_2(h6b,h1b,h6b_1,h1b_1) 365 dim_common = 1 366 dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1) 367 dima = dim_common * dima_sort 368 IF (dima .gt. 0) THEN 369 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 370 & ERRQUIT('cc2_x1_1_1',0,MA_ERR) 371 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 372 &cc2_x1_1_1',1,MA_ERR) 373 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 374 & - 1 + (noab+nvab) * (h6b_1 - 1))) 375 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1) 376 &,int_mb(k_range+h1b-1),2,1,1.0d0) 377 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_1',2,MA_ERR) 378 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 379 &cc2_x1_1_1',3,MA_ERR) 380 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 381 &,int_mb(k_range+h6b-1),2,1,1.0d0) 382 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 383 & 1 + noab * (h6b - 1))) 384 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_1',4,MA_ERR) 385 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_1',5,MA_ER 386 &R) 387 END IF 388 END IF 389 END IF 390 END IF 391 next = NXTASK(nprocs,1) 392 END IF 393 count = count + 1 394 END DO 395 END DO 396 next = NXTASK(-nprocs,1) 397 call GA_SYNC() 398 RETURN 399 END 400 SUBROUTINE OFFSET_cc2_x1_1_1(l_a_offset,k_a_offset,size) 401C $Id$ 402C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 403C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 404C i1 ( h6 h1 )_f 405 IMPLICIT NONE 406#include "global.fh" 407#include "mafdecls.fh" 408#include "sym.fh" 409#include "errquit.fh" 410#include "tce.fh" 411 INTEGER l_a_offset 412 INTEGER k_a_offset 413 INTEGER size 414 INTEGER length 415 INTEGER addr 416 INTEGER h6b 417 INTEGER h1b 418 length = 0 419 DO h6b = 1,noab 420 DO h1b = 1,noab 421 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 422 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 423 &EN 424 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1 425 &).ne.4)) THEN 426 length = length + 1 427 END IF 428 END IF 429 END IF 430 END DO 431 END DO 432 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 433 &set)) CALL ERRQUIT('cc2_x1_1_1',0,MA_ERR) 434 int_mb(k_a_offset) = length 435 addr = 0 436 size = 0 437 DO h6b = 1,noab 438 DO h1b = 1,noab 439 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 440 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 441 &EN 442 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1 443 &).ne.4)) THEN 444 addr = addr + 1 445 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h6b - 1) 446 int_mb(k_a_offset+length+addr) = size 447 size = size + int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1) 448 END IF 449 END IF 450 END IF 451 END DO 452 END DO 453 RETURN 454 END 455 SUBROUTINE cc2_x1_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 456 &) 457C $Id$ 458C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 459C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 460C i1 ( h6 h1 )_ft + = 1 * Sum ( p7 ) * t ( p7 h1 )_t * i2 ( h6 p7 )_f 461 IMPLICIT NONE 462#include "global.fh" 463#include "mafdecls.fh" 464#include "sym.fh" 465#include "errquit.fh" 466#include "tce.fh" 467 INTEGER d_a 468 INTEGER k_a_offset 469 INTEGER d_b 470 INTEGER k_b_offset 471 INTEGER d_c 472 INTEGER k_c_offset 473 INTEGER NXTASK 474 INTEGER next 475 INTEGER nprocs 476 INTEGER count 477 INTEGER h6b 478 INTEGER h1b 479 INTEGER dimc 480 INTEGER l_c_sort 481 INTEGER k_c_sort 482 INTEGER p7b 483 INTEGER p7b_1 484 INTEGER h1b_1 485 INTEGER h6b_2 486 INTEGER p7b_2 487 INTEGER dim_common 488 INTEGER dima_sort 489 INTEGER dima 490 INTEGER dimb_sort 491 INTEGER dimb 492 INTEGER l_a_sort 493 INTEGER k_a_sort 494 INTEGER l_a 495 INTEGER k_a 496 INTEGER l_b_sort 497 INTEGER k_b_sort 498 INTEGER l_b 499 INTEGER k_b 500 INTEGER l_c 501 INTEGER k_c 502 EXTERNAL NXTASK 503 nprocs = GA_NNODES() 504 count = 0 505 next = NXTASK(nprocs,1) 506 DO h6b = 1,noab 507 DO h1b = 1,noab 508 IF (next.eq.count) THEN 509 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1 510 &).ne.4)) THEN 511 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 512 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 513 &f,irrep_t)) THEN 514 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1) 515 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 516 & ERRQUIT('cc2_x1_1_2',0,MA_ERR) 517 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 518 DO p7b = noab+1,noab+nvab 519 IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)) THEN 520 IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 521 &EN 522 CALL TCE_RESTRICTED_2(p7b,h1b,p7b_1,h1b_1) 523 CALL TCE_RESTRICTED_2(h6b,p7b,h6b_2,p7b_2) 524 dim_common = int_mb(k_range+p7b-1) 525 dima_sort = int_mb(k_range+h1b-1) 526 dima = dim_common * dima_sort 527 dimb_sort = int_mb(k_range+h6b-1) 528 dimb = dim_common * dimb_sort 529 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 530 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 531 & ERRQUIT('cc2_x1_1_2',1,MA_ERR) 532 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 533 &cc2_x1_1_2',2,MA_ERR) 534 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 535 &int_mb(k_a_offset),(h1b_1 536 & - 1 + noab * (p7b_1 - noab - 1))) 537 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 538 &,int_mb(k_range+h1b-1),2,1,1.0d0) 539 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_2',3,MA_ERR) 540 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 541 & ERRQUIT('cc2_x1_1_2',4,MA_ERR) 542 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 543 &cc2_x1_1_2',5,MA_ERR) 544 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 545 & - noab - 1 + nvab * (h6b_2 - 1))) 546 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 547 &,int_mb(k_range+p7b-1),1,2,1.0d0) 548 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_1_2',6,MA_ERR) 549 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 550 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 551 &t),dima_sort) 552 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_1_2',7,MA_ER 553 &R) 554 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_2',8,MA_ER 555 &R) 556 END IF 557 END IF 558 END IF 559 END DO 560 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 561 &cc2_x1_1_2',9,MA_ERR) 562 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h6b-1) 563 &,int_mb(k_range+h1b-1),1,2,1.0d0) 564 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 565 & 1 + noab * (h6b - 1))) 566 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_2',10,MA_ERR) 567 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_1_2',11,MA_E 568 &RR) 569 END IF 570 END IF 571 END IF 572 next = NXTASK(nprocs,1) 573 END IF 574 count = count + 1 575 END DO 576 END DO 577 next = NXTASK(-nprocs,1) 578 call GA_SYNC() 579 RETURN 580 END 581 SUBROUTINE cc2_x1_1_2_1(d_a,k_a_offset,d_c,k_c_offset) 582C $Id$ 583C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 584C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 585C i2 ( h6 p7 )_f + = 1 * f ( h6 p7 )_f 586 IMPLICIT NONE 587#include "global.fh" 588#include "mafdecls.fh" 589#include "sym.fh" 590#include "errquit.fh" 591#include "tce.fh" 592 INTEGER d_a 593 INTEGER k_a_offset 594 INTEGER d_c 595 INTEGER k_c_offset 596 INTEGER NXTASK 597 INTEGER next 598 INTEGER nprocs 599 INTEGER count 600 INTEGER h6b 601 INTEGER p7b 602 INTEGER dimc 603 INTEGER h6b_1 604 INTEGER p7b_1 605 INTEGER dim_common 606 INTEGER dima_sort 607 INTEGER dima 608 INTEGER l_a_sort 609 INTEGER k_a_sort 610 INTEGER l_a 611 INTEGER k_a 612 INTEGER l_c 613 INTEGER k_c 614 EXTERNAL NXTASK 615 nprocs = GA_NNODES() 616 count = 0 617 next = NXTASK(nprocs,1) 618 DO h6b = 1,noab 619 DO p7b = noab+1,noab+nvab 620 IF (next.eq.count) THEN 621 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1 622 &).ne.4)) THEN 623 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN 624 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH 625 &EN 626 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1) 627 CALL TCE_RESTRICTED_2(h6b,p7b,h6b_1,p7b_1) 628 dim_common = 1 629 dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1) 630 dima = dim_common * dima_sort 631 IF (dima .gt. 0) THEN 632 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 633 & ERRQUIT('cc2_x1_1_2_1',0,MA_ERR) 634 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 635 &cc2_x1_1_2_1',1,MA_ERR) 636 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p7b_1 637 & - 1 + (noab+nvab) * (h6b_1 - 1))) 638 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1) 639 &,int_mb(k_range+p7b-1),2,1,1.0d0) 640 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_2_1',2,MA_ERR) 641 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 642 &cc2_x1_1_2_1',3,MA_ERR) 643 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p7b-1) 644 &,int_mb(k_range+h6b-1),2,1,1.0d0) 645 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b - 646 & noab - 1 + nvab * (h6b - 1))) 647 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_2_1',4,MA_ERR) 648 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_2_1',5,MA_ 649 &ERR) 650 END IF 651 END IF 652 END IF 653 END IF 654 next = NXTASK(nprocs,1) 655 END IF 656 count = count + 1 657 END DO 658 END DO 659 next = NXTASK(-nprocs,1) 660 call GA_SYNC() 661 RETURN 662 END 663 SUBROUTINE OFFSET_cc2_x1_1_2_1(l_a_offset,k_a_offset,size) 664C $Id$ 665C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 666C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 667C i2 ( h6 p7 )_f 668 IMPLICIT NONE 669#include "global.fh" 670#include "mafdecls.fh" 671#include "sym.fh" 672#include "errquit.fh" 673#include "tce.fh" 674 INTEGER l_a_offset 675 INTEGER k_a_offset 676 INTEGER size 677 INTEGER length 678 INTEGER addr 679 INTEGER h6b 680 INTEGER p7b 681 length = 0 682 DO h6b = 1,noab 683 DO p7b = noab+1,noab+nvab 684 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN 685 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH 686 &EN 687 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1 688 &).ne.4)) THEN 689 length = length + 1 690 END IF 691 END IF 692 END IF 693 END DO 694 END DO 695 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 696 &set)) CALL ERRQUIT('cc2_x1_1_2_1',0,MA_ERR) 697 int_mb(k_a_offset) = length 698 addr = 0 699 size = 0 700 DO h6b = 1,noab 701 DO p7b = noab+1,noab+nvab 702 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN 703 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH 704 &EN 705 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1 706 &).ne.4)) THEN 707 addr = addr + 1 708 int_mb(k_a_offset+addr) = p7b - noab - 1 + nvab * (h6b - 1) 709 int_mb(k_a_offset+length+addr) = size 710 size = size + int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1) 711 END IF 712 END IF 713 END IF 714 END DO 715 END DO 716 RETURN 717 END 718 SUBROUTINE cc2_x1_1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offs 719 &et) 720C $Id$ 721C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 722C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 723C i2 ( h6 p7 )_vt + = 1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 h6 p4 p7 )_v 724 IMPLICIT NONE 725#include "global.fh" 726#include "mafdecls.fh" 727#include "sym.fh" 728#include "errquit.fh" 729#include "tce.fh" 730 INTEGER d_a 731 INTEGER k_a_offset 732 INTEGER d_b 733 INTEGER k_b_offset 734 INTEGER d_c 735 INTEGER k_c_offset 736 INTEGER NXTASK 737 INTEGER next 738 INTEGER nprocs 739 INTEGER count 740 INTEGER h6b 741 INTEGER p7b 742 INTEGER dimc 743 INTEGER l_c_sort 744 INTEGER k_c_sort 745 INTEGER p4b 746 INTEGER h5b 747 INTEGER p4b_1 748 INTEGER h5b_1 749 INTEGER h6b_2 750 INTEGER h5b_2 751 INTEGER p7b_2 752 INTEGER p4b_2 753 INTEGER dim_common 754 INTEGER dima_sort 755 INTEGER dima 756 INTEGER dimb_sort 757 INTEGER dimb 758 INTEGER l_a_sort 759 INTEGER k_a_sort 760 INTEGER l_a 761 INTEGER k_a 762 INTEGER l_b_sort 763 INTEGER k_b_sort 764 INTEGER l_b 765 INTEGER k_b 766 INTEGER l_c 767 INTEGER k_c 768 EXTERNAL NXTASK 769 nprocs = GA_NNODES() 770 count = 0 771 next = NXTASK(nprocs,1) 772 DO h6b = 1,noab 773 DO p7b = noab+1,noab+nvab 774 IF (next.eq.count) THEN 775 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1 776 &).ne.4)) THEN 777 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN 778 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. ieor(irrep_ 779 &v,irrep_t)) THEN 780 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1) 781 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 782 & ERRQUIT('cc2_x1_1_2_2',0,MA_ERR) 783 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 784 DO p4b = noab+1,noab+nvab 785 DO h5b = 1,noab 786 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h5b-1)) THEN 787 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h5b-1)) .eq. irrep_t) TH 788 &EN 789 CALL TCE_RESTRICTED_2(p4b,h5b,p4b_1,h5b_1) 790 CALL TCE_RESTRICTED_4(h6b,h5b,p7b,p4b,h6b_2,h5b_2,p7b_2,p4b_2) 791 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h5b-1) 792 dima_sort = 1 793 dima = dim_common * dima_sort 794 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1) 795 dimb = dim_common * dimb_sort 796 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 797 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 798 & ERRQUIT('cc2_x1_1_2_2',1,MA_ERR) 799 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 800 &cc2_x1_1_2_2',2,MA_ERR) 801 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 802 &int_mb(k_a_offset),(h5b_1 803 & - 1 + noab * (p4b_1 - noab - 1))) 804 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 805 &,int_mb(k_range+h5b-1),2,1,1.0d0) 806 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_2_2',3,MA_ERR) 807 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 808 & ERRQUIT('cc2_x1_1_2_2',4,MA_ERR) 809 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 810 &cc2_x1_1_2_2',5,MA_ERR) 811 IF ((h5b .le. h6b) .and. (p4b .le. p7b)) THEN 812 if(.not.intorb) then 813 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 814 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 815 &+nvab) * (h5b_2 - 1))))) 816 else 817 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 818 &(p7b_2 819 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 820 &+nvab) * (h5b_2 - 1)))),p7b_2,p4b_2,h6b_2,h5b_2) 821 end if 822 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 823 &,int_mb(k_range+h6b-1),int_mb(k_range+p4b-1),int_mb(k_range+p7b-1) 824 &,4,2,1,3,1.0d0) 825 END IF 826 IF ((h5b .le. h6b) .and. (p7b .lt. p4b)) THEN 827 if(.not.intorb) then 828 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 829 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 830 &+nvab) * (h5b_2 - 1))))) 831 else 832 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 833 &(p4b_2 834 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 835 &+nvab) * (h5b_2 - 1)))),p4b_2,p7b_2,h6b_2,h5b_2) 836 end if 837 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 838 &,int_mb(k_range+h6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p4b-1) 839 &,3,2,1,4,-1.0d0) 840 END IF 841 IF ((h6b .lt. h5b) .and. (p4b .le. p7b)) THEN 842 if(.not.intorb) then 843 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 844 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 845 &+nvab) * (h6b_2 - 1))))) 846 else 847 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 848 &(p7b_2 849 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 850 &+nvab) * (h6b_2 - 1)))),p7b_2,p4b_2,h5b_2,h6b_2) 851 end if 852 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 853 &,int_mb(k_range+h5b-1),int_mb(k_range+p4b-1),int_mb(k_range+p7b-1) 854 &,4,1,2,3,-1.0d0) 855 END IF 856 IF ((h6b .lt. h5b) .and. (p7b .lt. p4b)) THEN 857 if(.not.intorb) then 858 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 859 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 860 &+nvab) * (h6b_2 - 1))))) 861 else 862 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 863 &(p4b_2 864 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 865 &+nvab) * (h6b_2 - 1)))),p4b_2,p7b_2,h5b_2,h6b_2) 866 end if 867 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 868 &,int_mb(k_range+h5b-1),int_mb(k_range+p7b-1),int_mb(k_range+p4b-1) 869 &,3,1,2,4,1.0d0) 870 END IF 871 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_1_2_2',6,MA_ERR) 872 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 873 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 874 &t),dima_sort) 875 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_1_2_2',7,MA_ 876 &ERR) 877 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_2_2',8,MA_ 878 &ERR) 879 END IF 880 END IF 881 END IF 882 END DO 883 END DO 884 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 885 &cc2_x1_1_2_2',9,MA_ERR) 886 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p7b-1) 887 &,int_mb(k_range+h6b-1),2,1,1.0d0) 888 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b - 889 & noab - 1 + nvab * (h6b - 1))) 890 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_2_2',10,MA_ERR) 891 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_1_2_2',11,MA 892 &_ERR) 893 END IF 894 END IF 895 END IF 896 next = NXTASK(nprocs,1) 897 END IF 898 count = count + 1 899 END DO 900 END DO 901 next = NXTASK(-nprocs,1) 902 call GA_SYNC() 903 RETURN 904 END 905 SUBROUTINE cc2_x1_1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 906 &) 907C $Id$ 908C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 909C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 910C i1 ( h6 h1 )_vt + = -1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 h6 h1 p3 )_v 911 IMPLICIT NONE 912#include "global.fh" 913#include "mafdecls.fh" 914#include "sym.fh" 915#include "errquit.fh" 916#include "tce.fh" 917 INTEGER d_a 918 INTEGER k_a_offset 919 INTEGER d_b 920 INTEGER k_b_offset 921 INTEGER d_c 922 INTEGER k_c_offset 923 INTEGER NXTASK 924 INTEGER next 925 INTEGER nprocs 926 INTEGER count 927 INTEGER h6b 928 INTEGER h1b 929 INTEGER dimc 930 INTEGER l_c_sort 931 INTEGER k_c_sort 932 INTEGER p3b 933 INTEGER h4b 934 INTEGER p3b_1 935 INTEGER h4b_1 936 INTEGER h6b_2 937 INTEGER h4b_2 938 INTEGER h1b_2 939 INTEGER p3b_2 940 INTEGER dim_common 941 INTEGER dima_sort 942 INTEGER dima 943 INTEGER dimb_sort 944 INTEGER dimb 945 INTEGER l_a_sort 946 INTEGER k_a_sort 947 INTEGER l_a 948 INTEGER k_a 949 INTEGER l_b_sort 950 INTEGER k_b_sort 951 INTEGER l_b 952 INTEGER k_b 953 INTEGER l_c 954 INTEGER k_c 955 EXTERNAL NXTASK 956 nprocs = GA_NNODES() 957 count = 0 958 next = NXTASK(nprocs,1) 959 DO h6b = 1,noab 960 DO h1b = 1,noab 961 IF (next.eq.count) THEN 962 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1 963 &).ne.4)) THEN 964 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 965 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 966 &v,irrep_t)) THEN 967 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1) 968 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 969 & ERRQUIT('cc2_x1_1_3',0,MA_ERR) 970 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 971 DO p3b = noab+1,noab+nvab 972 DO h4b = 1,noab 973 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN 974 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_t) TH 975 &EN 976 CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1) 977 CALL TCE_RESTRICTED_4(h6b,h4b,h1b,p3b,h6b_2,h4b_2,h1b_2,p3b_2) 978 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) 979 dima_sort = 1 980 dima = dim_common * dima_sort 981 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1) 982 dimb = dim_common * dimb_sort 983 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 984 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 985 & ERRQUIT('cc2_x1_1_3',1,MA_ERR) 986 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 987 &cc2_x1_1_3',2,MA_ERR) 988 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 989 &int_mb(k_a_offset),(h4b_1 990 & - 1 + noab * (p3b_1 - noab - 1))) 991 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 992 &,int_mb(k_range+h4b-1),2,1,1.0d0) 993 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_3',3,MA_ERR) 994 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 995 & ERRQUIT('cc2_x1_1_3',4,MA_ERR) 996 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 997 &cc2_x1_1_3',5,MA_ERR) 998 IF ((h4b .le. h6b) .and. (h1b .le. p3b)) THEN 999 if(.not.intorb) then 1000 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 1001 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 1002 &+nvab) * (h4b_2 - 1))))) 1003 else 1004 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1005 &(p3b_2 1006 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 1007 &+nvab) * (h4b_2 - 1)))),p3b_2,h1b_2,h6b_2,h4b_2) 1008 end if 1009 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 1010 &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1011 &,3,2,1,4,1.0d0) 1012 END IF 1013 IF ((h6b .lt. h4b) .and. (h1b .le. p3b)) THEN 1014 if(.not.intorb) then 1015 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 1016 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 1017 &+nvab) * (h6b_2 - 1))))) 1018 else 1019 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1020 &(p3b_2 1021 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 1022 &+nvab) * (h6b_2 - 1)))),p3b_2,h1b_2,h4b_2,h6b_2) 1023 end if 1024 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 1025 &,int_mb(k_range+h4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1026 &,3,1,2,4,-1.0d0) 1027 END IF 1028 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_1_3',6,MA_ERR) 1029 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1030 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1031 &t),dima_sort) 1032 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_1_3',7,MA_ER 1033 &R) 1034 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_3',8,MA_ER 1035 &R) 1036 END IF 1037 END IF 1038 END IF 1039 END DO 1040 END DO 1041 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1042 &cc2_x1_1_3',9,MA_ERR) 1043 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 1044 &,int_mb(k_range+h6b-1),2,1,-1.0d0) 1045 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1046 & 1 + noab * (h6b - 1))) 1047 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_3',10,MA_ERR) 1048 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_1_3',11,MA_E 1049 &RR) 1050 END IF 1051 END IF 1052 END IF 1053 next = NXTASK(nprocs,1) 1054 END IF 1055 count = count + 1 1056 END DO 1057 END DO 1058 next = NXTASK(-nprocs,1) 1059 call GA_SYNC() 1060 RETURN 1061 END 1062 SUBROUTINE cc2_x1_1_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 1063 &) 1064C $Id$ 1065C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1066C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1067C i1 ( h6 h1 )_vt + = -1/2 * Sum ( h5 p3 p4 ) * t ( p3 p4 h1 h5 )_t * v ( h5 h6 p3 p4 )_v 1068 IMPLICIT NONE 1069#include "global.fh" 1070#include "mafdecls.fh" 1071#include "sym.fh" 1072#include "errquit.fh" 1073#include "tce.fh" 1074 INTEGER d_a 1075 INTEGER k_a_offset 1076 INTEGER d_b 1077 INTEGER k_b_offset 1078 INTEGER d_c 1079 INTEGER k_c_offset 1080 INTEGER NXTASK 1081 INTEGER next 1082 INTEGER nprocs 1083 INTEGER count 1084 INTEGER h6b 1085 INTEGER h1b 1086 INTEGER dimc 1087 INTEGER l_c_sort 1088 INTEGER k_c_sort 1089 INTEGER p3b 1090 INTEGER p4b 1091 INTEGER h5b 1092 INTEGER p3b_1 1093 INTEGER p4b_1 1094 INTEGER h1b_1 1095 INTEGER h5b_1 1096 INTEGER h6b_2 1097 INTEGER h5b_2 1098 INTEGER p3b_2 1099 INTEGER p4b_2 1100 INTEGER dim_common 1101 INTEGER dima_sort 1102 INTEGER dima 1103 INTEGER dimb_sort 1104 INTEGER dimb 1105 INTEGER l_a_sort 1106 INTEGER k_a_sort 1107 INTEGER l_a 1108 INTEGER k_a 1109 INTEGER l_b_sort 1110 INTEGER k_b_sort 1111 INTEGER l_b 1112 INTEGER k_b 1113 INTEGER nsuperp(2) 1114 INTEGER isuperp 1115 INTEGER l_c 1116 INTEGER k_c 1117 DOUBLE PRECISION FACTORIAL 1118 EXTERNAL NXTASK 1119 EXTERNAL FACTORIAL 1120 nprocs = GA_NNODES() 1121 count = 0 1122 next = NXTASK(nprocs,1) 1123 DO h6b = 1,noab 1124 DO h1b = 1,noab 1125 IF (next.eq.count) THEN 1126 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1 1127 &).ne.4)) THEN 1128 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1129 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1130 &v,irrep_t)) THEN 1131 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1) 1132 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1133 & ERRQUIT('cc2_x1_1_4',0,MA_ERR) 1134 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1135 DO p3b = noab+1,noab+nvab 1136 DO p4b = p3b,noab+nvab 1137 DO h5b = 1,noab 1138 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 1139 &1b-1)+int_mb(k_spin+h5b-1)) THEN 1140 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 1141 &k_sym+h1b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN 1142 CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h5b,p3b_1,p4b_1,h1b_1,h5b_1) 1143 CALL TCE_RESTRICTED_4(h6b,h5b,p3b,p4b,h6b_2,h5b_2,p3b_2,p4b_2) 1144 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m 1145 &b(k_range+h5b-1) 1146 dima_sort = int_mb(k_range+h1b-1) 1147 dima = dim_common * dima_sort 1148 dimb_sort = int_mb(k_range+h6b-1) 1149 dimb = dim_common * dimb_sort 1150 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1151 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1152 & ERRQUIT('cc2_x1_1_4',1,MA_ERR) 1153 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1154 &cc2_x1_1_4',2,MA_ERR) 1155 IF ((h5b .lt. h1b)) THEN 1156 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1157 & - 1 + noab * (h5b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 1158 &1 - noab - 1))))) 1159 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1160 &,int_mb(k_range+p4b-1),int_mb(k_range+h5b-1),int_mb(k_range+h1b-1) 1161 &,4,3,2,1,-1.0d0) 1162 END IF 1163 IF ((h1b .le. h5b)) THEN 1164 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 1165 & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 1166 &1 - noab - 1))))) 1167 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1168 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h5b-1) 1169 &,3,4,2,1,1.0d0) 1170 END IF 1171 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_4',3,MA_ERR) 1172 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1173 & ERRQUIT('cc2_x1_1_4',4,MA_ERR) 1174 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1175 &cc2_x1_1_4',5,MA_ERR) 1176 IF ((h5b .le. h6b)) THEN 1177 if(.not.intorb) then 1178 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 1179 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 1180 &+nvab) * (h5b_2 - 1))))) 1181 else 1182 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1183 &(p4b_2 1184 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 1185 &+nvab) * (h5b_2 - 1)))),p4b_2,p3b_2,h6b_2,h5b_2) 1186 end if 1187 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 1188 &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 1189 &,2,1,4,3,1.0d0) 1190 END IF 1191 IF ((h6b .lt. h5b)) THEN 1192 if(.not.intorb) then 1193 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 1194 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 1195 &+nvab) * (h6b_2 - 1))))) 1196 else 1197 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1198 &(p4b_2 1199 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 1200 &+nvab) * (h6b_2 - 1)))),p4b_2,p3b_2,h5b_2,h6b_2) 1201 end if 1202 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 1203 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 1204 &,1,2,4,3,-1.0d0) 1205 END IF 1206 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_1_4',6,MA_ERR) 1207 nsuperp(1) = 1 1208 nsuperp(2) = 1 1209 isuperp = 1 1210 IF (p3b .eq. p4b) THEN 1211 nsuperp(isuperp) = nsuperp(isuperp) + 1 1212 ELSE 1213 isuperp = isuperp + 1 1214 END IF 1215 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 1216 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 1217 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 1218 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_1_4',7,MA_ER 1219 &R) 1220 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_4',8,MA_ER 1221 &R) 1222 END IF 1223 END IF 1224 END IF 1225 END DO 1226 END DO 1227 END DO 1228 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1229 &cc2_x1_1_4',9,MA_ERR) 1230 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h6b-1) 1231 &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0) 1232 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1233 & 1 + noab * (h6b - 1))) 1234 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_4',10,MA_ERR) 1235 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_1_4',11,MA_E 1236 &RR) 1237 END IF 1238 END IF 1239 END IF 1240 next = NXTASK(nprocs,1) 1241 END IF 1242 count = count + 1 1243 END DO 1244 END DO 1245 next = NXTASK(-nprocs,1) 1246 call GA_SYNC() 1247 RETURN 1248 END 1249 SUBROUTINE cc2_x1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 1250C $Id$ 1251C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1252C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1253C i0 ( p2 h1 )_xf + = 1 * Sum ( p6 ) * x ( p6 h1 )_x * i1 ( p2 p6 )_f 1254 IMPLICIT NONE 1255#include "global.fh" 1256#include "mafdecls.fh" 1257#include "sym.fh" 1258#include "errquit.fh" 1259#include "tce.fh" 1260 INTEGER d_a 1261 INTEGER k_a_offset 1262 INTEGER d_b 1263 INTEGER k_b_offset 1264 INTEGER d_c 1265 INTEGER k_c_offset 1266 INTEGER NXTASK 1267 INTEGER next 1268 INTEGER nprocs 1269 INTEGER count 1270 INTEGER p2b 1271 INTEGER h1b 1272 INTEGER dimc 1273 INTEGER l_c_sort 1274 INTEGER k_c_sort 1275 INTEGER p6b 1276 INTEGER p6b_1 1277 INTEGER h1b_1 1278 INTEGER p2b_2 1279 INTEGER p6b_2 1280 INTEGER dim_common 1281 INTEGER dima_sort 1282 INTEGER dima 1283 INTEGER dimb_sort 1284 INTEGER dimb 1285 INTEGER l_a_sort 1286 INTEGER k_a_sort 1287 INTEGER l_a 1288 INTEGER k_a 1289 INTEGER l_b_sort 1290 INTEGER k_b_sort 1291 INTEGER l_b 1292 INTEGER k_b 1293 INTEGER l_c 1294 INTEGER k_c 1295 EXTERNAL NXTASK 1296 nprocs = GA_NNODES() 1297 count = 0 1298 next = NXTASK(nprocs,1) 1299 DO p2b = noab+1,noab+nvab 1300 DO h1b = 1,noab 1301 IF (next.eq.count) THEN 1302 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 1303 &).ne.4)) THEN 1304 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1305 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1306 &x,irrep_f)) THEN 1307 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 1308 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1309 & ERRQUIT('cc2_x1_2',0,MA_ERR) 1310 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1311 DO p6b = noab+1,noab+nvab 1312 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1313 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH 1314 &EN 1315 CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1) 1316 CALL TCE_RESTRICTED_2(p2b,p6b,p2b_2,p6b_2) 1317 dim_common = int_mb(k_range+p6b-1) 1318 dima_sort = int_mb(k_range+h1b-1) 1319 dima = dim_common * dima_sort 1320 dimb_sort = int_mb(k_range+p2b-1) 1321 dimb = dim_common * dimb_sort 1322 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1323 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1324 & ERRQUIT('cc2_x1_2',1,MA_ERR) 1325 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1326 &cc2_x1_2',2,MA_ERR) 1327 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 1328 &int_mb(k_a_offset),(h1b_1 1329 & - 1 + noab * (p6b_1 - noab - 1))) 1330 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 1331 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1332 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_2',3,MA_ERR) 1333 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1334 & ERRQUIT('cc2_x1_2',4,MA_ERR) 1335 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1336 &cc2_x1_2',5,MA_ERR) 1337 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 1338 & - noab - 1 + nvab * (p2b_2 - noab - 1))) 1339 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1) 1340 &,int_mb(k_range+p6b-1),1,2,1.0d0) 1341 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_2',6,MA_ERR) 1342 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1343 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1344 &t),dima_sort) 1345 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_2',7,MA_ERR) 1346 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_2',8,MA_ERR) 1347 END IF 1348 END IF 1349 END IF 1350 END DO 1351 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1352 &cc2_x1_2',9,MA_ERR) 1353 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1) 1354 &,int_mb(k_range+h1b-1),1,2,1.0d0) 1355 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1356 & 1 + noab * (p2b - noab - 1))) 1357 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_2',10,MA_ERR) 1358 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_2',11,MA_ERR 1359 &) 1360 END IF 1361 END IF 1362 END IF 1363 next = NXTASK(nprocs,1) 1364 END IF 1365 count = count + 1 1366 END DO 1367 END DO 1368 next = NXTASK(-nprocs,1) 1369 call GA_SYNC() 1370 RETURN 1371 END 1372 SUBROUTINE cc2_x1_2_1(d_a,k_a_offset,d_c,k_c_offset) 1373C $Id$ 1374C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1375C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1376C i1 ( p2 p6 )_f + = 1 * f ( p2 p6 )_f 1377 IMPLICIT NONE 1378#include "global.fh" 1379#include "mafdecls.fh" 1380#include "sym.fh" 1381#include "errquit.fh" 1382#include "tce.fh" 1383 INTEGER d_a 1384 INTEGER k_a_offset 1385 INTEGER d_c 1386 INTEGER k_c_offset 1387 INTEGER NXTASK 1388 INTEGER next 1389 INTEGER nprocs 1390 INTEGER count 1391 INTEGER p2b 1392 INTEGER p6b 1393 INTEGER dimc 1394 INTEGER p2b_1 1395 INTEGER p6b_1 1396 INTEGER dim_common 1397 INTEGER dima_sort 1398 INTEGER dima 1399 INTEGER l_a_sort 1400 INTEGER k_a_sort 1401 INTEGER l_a 1402 INTEGER k_a 1403 INTEGER l_c 1404 INTEGER k_c 1405 EXTERNAL NXTASK 1406 nprocs = GA_NNODES() 1407 count = 0 1408 next = NXTASK(nprocs,1) 1409 DO p2b = noab+1,noab+nvab 1410 DO p6b = noab+1,noab+nvab 1411 IF (next.eq.count) THEN 1412 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p6b-1 1413 &).ne.4)) THEN 1414 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p6b-1)) THEN 1415 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p6b-1)) .eq. irrep_f) TH 1416 &EN 1417 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p6b-1) 1418 CALL TCE_RESTRICTED_2(p2b,p6b,p2b_1,p6b_1) 1419 dim_common = 1 1420 dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+p6b-1) 1421 dima = dim_common * dima_sort 1422 IF (dima .gt. 0) THEN 1423 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1424 & ERRQUIT('cc2_x1_2_1',0,MA_ERR) 1425 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1426 &cc2_x1_2_1',1,MA_ERR) 1427 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p6b_1 1428 & - 1 + (noab+nvab) * (p2b_1 - 1))) 1429 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 1430 &,int_mb(k_range+p6b-1),2,1,1.0d0) 1431 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_2_1',2,MA_ERR) 1432 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1433 &cc2_x1_2_1',3,MA_ERR) 1434 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p6b-1) 1435 &,int_mb(k_range+p2b-1),2,1,1.0d0) 1436 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p6b - 1437 & noab - 1 + nvab * (p2b - noab - 1))) 1438 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_2_1',4,MA_ERR) 1439 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_2_1',5,MA_ER 1440 &R) 1441 END IF 1442 END IF 1443 END IF 1444 END IF 1445 next = NXTASK(nprocs,1) 1446 END IF 1447 count = count + 1 1448 END DO 1449 END DO 1450 next = NXTASK(-nprocs,1) 1451 call GA_SYNC() 1452 RETURN 1453 END 1454 SUBROUTINE OFFSET_cc2_x1_2_1(l_a_offset,k_a_offset,size) 1455C $Id$ 1456C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1457C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1458C i1 ( p2 p6 )_f 1459 IMPLICIT NONE 1460#include "global.fh" 1461#include "mafdecls.fh" 1462#include "sym.fh" 1463#include "errquit.fh" 1464#include "tce.fh" 1465 INTEGER l_a_offset 1466 INTEGER k_a_offset 1467 INTEGER size 1468 INTEGER length 1469 INTEGER addr 1470 INTEGER p2b 1471 INTEGER p6b 1472 length = 0 1473 DO p2b = noab+1,noab+nvab 1474 DO p6b = noab+1,noab+nvab 1475 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p6b-1)) THEN 1476 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p6b-1)) .eq. irrep_f) TH 1477 &EN 1478 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p6b-1 1479 &).ne.4)) THEN 1480 length = length + 1 1481 END IF 1482 END IF 1483 END IF 1484 END DO 1485 END DO 1486 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1487 &set)) CALL ERRQUIT('cc2_x1_2_1',0,MA_ERR) 1488 int_mb(k_a_offset) = length 1489 addr = 0 1490 size = 0 1491 DO p2b = noab+1,noab+nvab 1492 DO p6b = noab+1,noab+nvab 1493 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p6b-1)) THEN 1494 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p6b-1)) .eq. irrep_f) TH 1495 &EN 1496 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p6b-1 1497 &).ne.4)) THEN 1498 addr = addr + 1 1499 int_mb(k_a_offset+addr) = p6b - noab - 1 + nvab * (p2b - noab - 1) 1500 int_mb(k_a_offset+length+addr) = size 1501 size = size + int_mb(k_range+p2b-1) * int_mb(k_range+p6b-1) 1502 END IF 1503 END IF 1504 END IF 1505 END DO 1506 END DO 1507 RETURN 1508 END 1509 SUBROUTINE cc2_x1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 1510 &) 1511C $Id$ 1512C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1513C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1514C i1 ( p2 p6 )_vt + = 1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 p2 p3 p6 )_v 1515 IMPLICIT NONE 1516#include "global.fh" 1517#include "mafdecls.fh" 1518#include "sym.fh" 1519#include "errquit.fh" 1520#include "tce.fh" 1521 INTEGER d_a 1522 INTEGER k_a_offset 1523 INTEGER d_b 1524 INTEGER k_b_offset 1525 INTEGER d_c 1526 INTEGER k_c_offset 1527 INTEGER NXTASK 1528 INTEGER next 1529 INTEGER nprocs 1530 INTEGER count 1531 INTEGER p2b 1532 INTEGER p6b 1533 INTEGER dimc 1534 INTEGER l_c_sort 1535 INTEGER k_c_sort 1536 INTEGER p3b 1537 INTEGER h4b 1538 INTEGER p3b_1 1539 INTEGER h4b_1 1540 INTEGER p2b_2 1541 INTEGER h4b_2 1542 INTEGER p6b_2 1543 INTEGER p3b_2 1544 INTEGER dim_common 1545 INTEGER dima_sort 1546 INTEGER dima 1547 INTEGER dimb_sort 1548 INTEGER dimb 1549 INTEGER l_a_sort 1550 INTEGER k_a_sort 1551 INTEGER l_a 1552 INTEGER k_a 1553 INTEGER l_b_sort 1554 INTEGER k_b_sort 1555 INTEGER l_b 1556 INTEGER k_b 1557 INTEGER l_c 1558 INTEGER k_c 1559 EXTERNAL NXTASK 1560 nprocs = GA_NNODES() 1561 count = 0 1562 next = NXTASK(nprocs,1) 1563 DO p2b = noab+1,noab+nvab 1564 DO p6b = noab+1,noab+nvab 1565 IF (next.eq.count) THEN 1566 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p6b-1 1567 &).ne.4)) THEN 1568 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p6b-1)) THEN 1569 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p6b-1)) .eq. ieor(irrep_ 1570 &v,irrep_t)) THEN 1571 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p6b-1) 1572 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1573 & ERRQUIT('cc2_x1_2_2',0,MA_ERR) 1574 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1575 DO p3b = noab+1,noab+nvab 1576 DO h4b = 1,noab 1577 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN 1578 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_t) TH 1579 &EN 1580 CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1) 1581 CALL TCE_RESTRICTED_4(p2b,h4b,p6b,p3b,p2b_2,h4b_2,p6b_2,p3b_2) 1582 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) 1583 dima_sort = 1 1584 dima = dim_common * dima_sort 1585 dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+p6b-1) 1586 dimb = dim_common * dimb_sort 1587 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1588 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1589 & ERRQUIT('cc2_x1_2_2',1,MA_ERR) 1590 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1591 &cc2_x1_2_2',2,MA_ERR) 1592 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 1593 &int_mb(k_a_offset),(h4b_1 1594 & - 1 + noab * (p3b_1 - noab - 1))) 1595 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1596 &,int_mb(k_range+h4b-1),2,1,1.0d0) 1597 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_2_2',3,MA_ERR) 1598 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1599 & ERRQUIT('cc2_x1_2_2',4,MA_ERR) 1600 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1601 &cc2_x1_2_2',5,MA_ERR) 1602 IF ((h4b .le. p2b) .and. (p3b .le. p6b)) THEN 1603 if(.not.intorb) then 1604 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 1605 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 1606 &+nvab) * (h4b_2 - 1))))) 1607 else 1608 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1609 &(p6b_2 1610 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 1611 &+nvab) * (h4b_2 - 1)))),p6b_2,p3b_2,p2b_2,h4b_2) 1612 end if 1613 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 1614 &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1) 1615 &,4,2,1,3,1.0d0) 1616 END IF 1617 IF ((h4b .le. p2b) .and. (p6b .lt. p3b)) THEN 1618 if(.not.intorb) then 1619 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 1620 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 1621 &+nvab) * (h4b_2 - 1))))) 1622 else 1623 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1624 &(p3b_2 1625 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 1626 &+nvab) * (h4b_2 - 1)))),p3b_2,p6b_2,p2b_2,h4b_2) 1627 end if 1628 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 1629 &,int_mb(k_range+p2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1) 1630 &,3,2,1,4,-1.0d0) 1631 END IF 1632 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_2_2',6,MA_ERR) 1633 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1634 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1635 &t),dima_sort) 1636 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_2_2',7,MA_ER 1637 &R) 1638 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_2_2',8,MA_ER 1639 &R) 1640 END IF 1641 END IF 1642 END IF 1643 END DO 1644 END DO 1645 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1646 &cc2_x1_2_2',9,MA_ERR) 1647 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p6b-1) 1648 &,int_mb(k_range+p2b-1),2,1,1.0d0) 1649 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p6b - 1650 & noab - 1 + nvab * (p2b - noab - 1))) 1651 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_2_2',10,MA_ERR) 1652 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_2_2',11,MA_E 1653 &RR) 1654 END IF 1655 END IF 1656 END IF 1657 next = NXTASK(nprocs,1) 1658 END IF 1659 count = count + 1 1660 END DO 1661 END DO 1662 next = NXTASK(-nprocs,1) 1663 call GA_SYNC() 1664 RETURN 1665 END 1666 SUBROUTINE cc2_x1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 1667C $Id$ 1668C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1669C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1670C i0 ( p2 h1 )_xv + = -1 * Sum ( p4 h3 ) * x ( p4 h3 )_x * v ( h3 p2 h1 p4 )_v 1671 IMPLICIT NONE 1672#include "global.fh" 1673#include "mafdecls.fh" 1674#include "sym.fh" 1675#include "errquit.fh" 1676#include "tce.fh" 1677 INTEGER d_a 1678 INTEGER k_a_offset 1679 INTEGER d_b 1680 INTEGER k_b_offset 1681 INTEGER d_c 1682 INTEGER k_c_offset 1683 INTEGER NXTASK 1684 INTEGER next 1685 INTEGER nprocs 1686 INTEGER count 1687 INTEGER p2b 1688 INTEGER h1b 1689 INTEGER dimc 1690 INTEGER l_c_sort 1691 INTEGER k_c_sort 1692 INTEGER p4b 1693 INTEGER h3b 1694 INTEGER p4b_1 1695 INTEGER h3b_1 1696 INTEGER p2b_2 1697 INTEGER h3b_2 1698 INTEGER h1b_2 1699 INTEGER p4b_2 1700 INTEGER dim_common 1701 INTEGER dima_sort 1702 INTEGER dima 1703 INTEGER dimb_sort 1704 INTEGER dimb 1705 INTEGER l_a_sort 1706 INTEGER k_a_sort 1707 INTEGER l_a 1708 INTEGER k_a 1709 INTEGER l_b_sort 1710 INTEGER k_b_sort 1711 INTEGER l_b 1712 INTEGER k_b 1713 INTEGER l_c 1714 INTEGER k_c 1715 EXTERNAL NXTASK 1716 nprocs = GA_NNODES() 1717 count = 0 1718 next = NXTASK(nprocs,1) 1719 DO p2b = noab+1,noab+nvab 1720 DO h1b = 1,noab 1721 IF (next.eq.count) THEN 1722 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 1723 &).ne.4)) THEN 1724 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1725 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1726 &x,irrep_v)) THEN 1727 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 1728 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1729 & ERRQUIT('cc2_x1_3',0,MA_ERR) 1730 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1731 DO p4b = noab+1,noab+nvab 1732 DO h3b = 1,noab 1733 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h3b-1)) THEN 1734 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH 1735 &EN 1736 CALL TCE_RESTRICTED_2(p4b,h3b,p4b_1,h3b_1) 1737 CALL TCE_RESTRICTED_4(p2b,h3b,h1b,p4b,p2b_2,h3b_2,h1b_2,p4b_2) 1738 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h3b-1) 1739 dima_sort = 1 1740 dima = dim_common * dima_sort 1741 dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 1742 dimb = dim_common * dimb_sort 1743 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1744 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1745 & ERRQUIT('cc2_x1_3',1,MA_ERR) 1746 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1747 &cc2_x1_3',2,MA_ERR) 1748 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 1749 &int_mb(k_a_offset),(h3b_1 1750 & - 1 + noab * (p4b_1 - noab - 1))) 1751 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 1752 &,int_mb(k_range+h3b-1),2,1,1.0d0) 1753 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_3',3,MA_ERR) 1754 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1755 & ERRQUIT('cc2_x1_3',4,MA_ERR) 1756 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1757 &cc2_x1_3',5,MA_ERR) 1758 IF ((h3b .le. p2b) .and. (h1b .le. p4b)) THEN 1759 if(.not.intorb) then 1760 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 1761 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 1762 &+nvab) * (h3b_2 - 1))))) 1763 else 1764 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1765 &(p4b_2 1766 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 1767 &+nvab) * (h3b_2 - 1)))),p4b_2,h1b_2,p2b_2,h3b_2) 1768 end if 1769 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 1770 &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1) 1771 &,3,2,1,4,1.0d0) 1772 END IF 1773 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_3',6,MA_ERR) 1774 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1775 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1776 &t),dima_sort) 1777 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_3',7,MA_ERR) 1778 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_3',8,MA_ERR) 1779 END IF 1780 END IF 1781 END IF 1782 END DO 1783 END DO 1784 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1785 &cc2_x1_3',9,MA_ERR) 1786 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 1787 &,int_mb(k_range+p2b-1),2,1,-1.0d0) 1788 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1789 & 1 + noab * (p2b - noab - 1))) 1790 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_3',10,MA_ERR) 1791 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_3',11,MA_ERR 1792 &) 1793 END IF 1794 END IF 1795 END IF 1796 next = NXTASK(nprocs,1) 1797 END IF 1798 count = count + 1 1799 END DO 1800 END DO 1801 next = NXTASK(-nprocs,1) 1802 call GA_SYNC() 1803 RETURN 1804 END 1805 SUBROUTINE cc2_x1_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 1806C $Id$ 1807C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1808C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1809C i0 ( p2 h1 )_xf + = 1 * Sum ( p7 h6 ) * x ( p2 p7 h1 h6 )_x * i1 ( h6 p7 )_f 1810 IMPLICIT NONE 1811#include "global.fh" 1812#include "mafdecls.fh" 1813#include "sym.fh" 1814#include "errquit.fh" 1815#include "tce.fh" 1816 INTEGER d_a 1817 INTEGER k_a_offset 1818 INTEGER d_b 1819 INTEGER k_b_offset 1820 INTEGER d_c 1821 INTEGER k_c_offset 1822 INTEGER NXTASK 1823 INTEGER next 1824 INTEGER nprocs 1825 INTEGER count 1826 INTEGER p2b 1827 INTEGER h1b 1828 INTEGER dimc 1829 INTEGER l_c_sort 1830 INTEGER k_c_sort 1831 INTEGER p7b 1832 INTEGER h6b 1833 INTEGER p2b_1 1834 INTEGER p7b_1 1835 INTEGER h1b_1 1836 INTEGER h6b_1 1837 INTEGER h6b_2 1838 INTEGER p7b_2 1839 INTEGER dim_common 1840 INTEGER dima_sort 1841 INTEGER dima 1842 INTEGER dimb_sort 1843 INTEGER dimb 1844 INTEGER l_a_sort 1845 INTEGER k_a_sort 1846 INTEGER l_a 1847 INTEGER k_a 1848 INTEGER l_b_sort 1849 INTEGER k_b_sort 1850 INTEGER l_b 1851 INTEGER k_b 1852 INTEGER l_c 1853 INTEGER k_c 1854 EXTERNAL NXTASK 1855 nprocs = GA_NNODES() 1856 count = 0 1857 next = NXTASK(nprocs,1) 1858 DO p2b = noab+1,noab+nvab 1859 DO h1b = 1,noab 1860 IF (next.eq.count) THEN 1861 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 1862 &).ne.4)) THEN 1863 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1864 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1865 &x,irrep_f)) THEN 1866 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 1867 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1868 & ERRQUIT('cc2_x1_4',0,MA_ERR) 1869 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1870 DO p7b = noab+1,noab+nvab 1871 DO h6b = 1,noab 1872 IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h 1873 &1b-1)+int_mb(k_spin+h6b-1)) THEN 1874 IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb( 1875 &k_sym+h1b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_x) THEN 1876 CALL TCE_RESTRICTED_4(p2b,p7b,h1b,h6b,p2b_1,p7b_1,h1b_1,h6b_1) 1877 CALL TCE_RESTRICTED_2(h6b,p7b,h6b_2,p7b_2) 1878 dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+h6b-1) 1879 dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 1880 dima = dim_common * dima_sort 1881 dimb_sort = 1 1882 dimb = dim_common * dimb_sort 1883 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1884 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1885 & ERRQUIT('cc2_x1_4',1,MA_ERR) 1886 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1887 &cc2_x1_4',2,MA_ERR) 1888 IF ((p7b .lt. p2b) .and. (h6b .lt. h1b)) THEN 1889 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1890 & - 1 + noab * (h6b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p7b_ 1891 &1 - noab - 1))))) 1892 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 1893 &,int_mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 1894 &,4,2,3,1,1.0d0) 1895 END IF 1896 IF ((p7b .lt. p2b) .and. (h1b .le. h6b)) THEN 1897 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 1898 & - 1 + noab * (h1b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p7b_ 1899 &1 - noab - 1))))) 1900 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 1901 &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1) 1902 &,3,2,4,1,-1.0d0) 1903 END IF 1904 IF ((p2b .le. p7b) .and. (h6b .lt. h1b)) THEN 1905 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1906 & - 1 + noab * (h6b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p2b_ 1907 &1 - noab - 1))))) 1908 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 1909 &,int_mb(k_range+p7b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 1910 &,4,1,3,2,-1.0d0) 1911 END IF 1912 IF ((p2b .le. p7b) .and. (h1b .le. h6b)) THEN 1913 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 1914 & - 1 + noab * (h1b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p2b_ 1915 &1 - noab - 1))))) 1916 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 1917 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1) 1918 &,3,1,4,2,1.0d0) 1919 END IF 1920 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_4',3,MA_ERR) 1921 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1922 & ERRQUIT('cc2_x1_4',4,MA_ERR) 1923 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1924 &cc2_x1_4',5,MA_ERR) 1925 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 1926 & - noab - 1 + nvab * (h6b_2 - 1))) 1927 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 1928 &,int_mb(k_range+p7b-1),1,2,1.0d0) 1929 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_4',6,MA_ERR) 1930 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1931 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1932 &t),dima_sort) 1933 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_4',7,MA_ERR) 1934 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_4',8,MA_ERR) 1935 END IF 1936 END IF 1937 END IF 1938 END DO 1939 END DO 1940 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1941 &cc2_x1_4',9,MA_ERR) 1942 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 1943 &,int_mb(k_range+p2b-1),2,1,1.0d0) 1944 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1945 & 1 + noab * (p2b - noab - 1))) 1946 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_4',10,MA_ERR) 1947 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_4',11,MA_ERR 1948 &) 1949 END IF 1950 END IF 1951 END IF 1952 next = NXTASK(nprocs,1) 1953 END IF 1954 count = count + 1 1955 END DO 1956 END DO 1957 next = NXTASK(-nprocs,1) 1958 call GA_SYNC() 1959 RETURN 1960 END 1961 SUBROUTINE cc2_x1_4_1(d_a,k_a_offset,d_c,k_c_offset) 1962C $Id$ 1963C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1964C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1965C i1 ( h6 p7 )_f + = 1 * f ( h6 p7 )_f 1966 IMPLICIT NONE 1967#include "global.fh" 1968#include "mafdecls.fh" 1969#include "sym.fh" 1970#include "errquit.fh" 1971#include "tce.fh" 1972 INTEGER d_a 1973 INTEGER k_a_offset 1974 INTEGER d_c 1975 INTEGER k_c_offset 1976 INTEGER NXTASK 1977 INTEGER next 1978 INTEGER nprocs 1979 INTEGER count 1980 INTEGER h6b 1981 INTEGER p7b 1982 INTEGER dimc 1983 INTEGER h6b_1 1984 INTEGER p7b_1 1985 INTEGER dim_common 1986 INTEGER dima_sort 1987 INTEGER dima 1988 INTEGER l_a_sort 1989 INTEGER k_a_sort 1990 INTEGER l_a 1991 INTEGER k_a 1992 INTEGER l_c 1993 INTEGER k_c 1994 EXTERNAL NXTASK 1995 nprocs = GA_NNODES() 1996 count = 0 1997 next = NXTASK(nprocs,1) 1998 DO h6b = 1,noab 1999 DO p7b = noab+1,noab+nvab 2000 IF (next.eq.count) THEN 2001 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1 2002 &).ne.4)) THEN 2003 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN 2004 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH 2005 &EN 2006 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1) 2007 CALL TCE_RESTRICTED_2(h6b,p7b,h6b_1,p7b_1) 2008 dim_common = 1 2009 dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1) 2010 dima = dim_common * dima_sort 2011 IF (dima .gt. 0) THEN 2012 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2013 & ERRQUIT('cc2_x1_4_1',0,MA_ERR) 2014 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2015 &cc2_x1_4_1',1,MA_ERR) 2016 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p7b_1 2017 & - 1 + (noab+nvab) * (h6b_1 - 1))) 2018 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1) 2019 &,int_mb(k_range+p7b-1),2,1,1.0d0) 2020 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_4_1',2,MA_ERR) 2021 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2022 &cc2_x1_4_1',3,MA_ERR) 2023 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p7b-1) 2024 &,int_mb(k_range+h6b-1),2,1,1.0d0) 2025 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b - 2026 & noab - 1 + nvab * (h6b - 1))) 2027 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_4_1',4,MA_ERR) 2028 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_4_1',5,MA_ER 2029 &R) 2030 END IF 2031 END IF 2032 END IF 2033 END IF 2034 next = NXTASK(nprocs,1) 2035 END IF 2036 count = count + 1 2037 END DO 2038 END DO 2039 next = NXTASK(-nprocs,1) 2040 call GA_SYNC() 2041 RETURN 2042 END 2043 SUBROUTINE OFFSET_cc2_x1_4_1(l_a_offset,k_a_offset,size) 2044C $Id$ 2045C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2046C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2047C i1 ( h6 p7 )_f 2048 IMPLICIT NONE 2049#include "global.fh" 2050#include "mafdecls.fh" 2051#include "sym.fh" 2052#include "errquit.fh" 2053#include "tce.fh" 2054 INTEGER l_a_offset 2055 INTEGER k_a_offset 2056 INTEGER size 2057 INTEGER length 2058 INTEGER addr 2059 INTEGER h6b 2060 INTEGER p7b 2061 length = 0 2062 DO h6b = 1,noab 2063 DO p7b = noab+1,noab+nvab 2064 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN 2065 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH 2066 &EN 2067 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1 2068 &).ne.4)) THEN 2069 length = length + 1 2070 END IF 2071 END IF 2072 END IF 2073 END DO 2074 END DO 2075 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2076 &set)) CALL ERRQUIT('cc2_x1_4_1',0,MA_ERR) 2077 int_mb(k_a_offset) = length 2078 addr = 0 2079 size = 0 2080 DO h6b = 1,noab 2081 DO p7b = noab+1,noab+nvab 2082 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN 2083 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH 2084 &EN 2085 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1 2086 &).ne.4)) THEN 2087 addr = addr + 1 2088 int_mb(k_a_offset+addr) = p7b - noab - 1 + nvab * (h6b - 1) 2089 int_mb(k_a_offset+length+addr) = size 2090 size = size + int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1) 2091 END IF 2092 END IF 2093 END IF 2094 END DO 2095 END DO 2096 RETURN 2097 END 2098 SUBROUTINE cc2_x1_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 2099 &) 2100C $Id$ 2101C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2102C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2103C i1 ( h6 p7 )_vt + = 1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 h6 p3 p7 )_v 2104 IMPLICIT NONE 2105#include "global.fh" 2106#include "mafdecls.fh" 2107#include "sym.fh" 2108#include "errquit.fh" 2109#include "tce.fh" 2110 INTEGER d_a 2111 INTEGER k_a_offset 2112 INTEGER d_b 2113 INTEGER k_b_offset 2114 INTEGER d_c 2115 INTEGER k_c_offset 2116 INTEGER NXTASK 2117 INTEGER next 2118 INTEGER nprocs 2119 INTEGER count 2120 INTEGER h6b 2121 INTEGER p7b 2122 INTEGER dimc 2123 INTEGER l_c_sort 2124 INTEGER k_c_sort 2125 INTEGER p3b 2126 INTEGER h4b 2127 INTEGER p3b_1 2128 INTEGER h4b_1 2129 INTEGER h6b_2 2130 INTEGER h4b_2 2131 INTEGER p7b_2 2132 INTEGER p3b_2 2133 INTEGER dim_common 2134 INTEGER dima_sort 2135 INTEGER dima 2136 INTEGER dimb_sort 2137 INTEGER dimb 2138 INTEGER l_a_sort 2139 INTEGER k_a_sort 2140 INTEGER l_a 2141 INTEGER k_a 2142 INTEGER l_b_sort 2143 INTEGER k_b_sort 2144 INTEGER l_b 2145 INTEGER k_b 2146 INTEGER l_c 2147 INTEGER k_c 2148 EXTERNAL NXTASK 2149 nprocs = GA_NNODES() 2150 count = 0 2151 next = NXTASK(nprocs,1) 2152 DO h6b = 1,noab 2153 DO p7b = noab+1,noab+nvab 2154 IF (next.eq.count) THEN 2155 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1 2156 &).ne.4)) THEN 2157 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN 2158 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. ieor(irrep_ 2159 &v,irrep_t)) THEN 2160 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1) 2161 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2162 & ERRQUIT('cc2_x1_4_2',0,MA_ERR) 2163 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2164 DO p3b = noab+1,noab+nvab 2165 DO h4b = 1,noab 2166 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN 2167 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_t) TH 2168 &EN 2169 CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1) 2170 CALL TCE_RESTRICTED_4(h6b,h4b,p7b,p3b,h6b_2,h4b_2,p7b_2,p3b_2) 2171 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) 2172 dima_sort = 1 2173 dima = dim_common * dima_sort 2174 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1) 2175 dimb = dim_common * dimb_sort 2176 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2177 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2178 & ERRQUIT('cc2_x1_4_2',1,MA_ERR) 2179 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2180 &cc2_x1_4_2',2,MA_ERR) 2181 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 2182 &int_mb(k_a_offset),(h4b_1 2183 & - 1 + noab * (p3b_1 - noab - 1))) 2184 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2185 &,int_mb(k_range+h4b-1),2,1,1.0d0) 2186 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_4_2',3,MA_ERR) 2187 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2188 & ERRQUIT('cc2_x1_4_2',4,MA_ERR) 2189 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2190 &cc2_x1_4_2',5,MA_ERR) 2191 IF ((h4b .le. h6b) .and. (p3b .le. p7b)) THEN 2192 if(.not.intorb) then 2193 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 2194 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 2195 &+nvab) * (h4b_2 - 1))))) 2196 else 2197 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 2198 &(p7b_2 2199 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 2200 &+nvab) * (h4b_2 - 1)))),p7b_2,p3b_2,h6b_2,h4b_2) 2201 end if 2202 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 2203 &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1) 2204 &,4,2,1,3,1.0d0) 2205 END IF 2206 IF ((h4b .le. h6b) .and. (p7b .lt. p3b)) THEN 2207 if(.not.intorb) then 2208 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 2209 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 2210 &+nvab) * (h4b_2 - 1))))) 2211 else 2212 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 2213 &(p3b_2 2214 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 2215 &+nvab) * (h4b_2 - 1)))),p3b_2,p7b_2,h6b_2,h4b_2) 2216 end if 2217 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 2218 &,int_mb(k_range+h6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p3b-1) 2219 &,3,2,1,4,-1.0d0) 2220 END IF 2221 IF ((h6b .lt. h4b) .and. (p3b .le. p7b)) THEN 2222 if(.not.intorb) then 2223 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 2224 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 2225 &+nvab) * (h6b_2 - 1))))) 2226 else 2227 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 2228 &(p7b_2 2229 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 2230 &+nvab) * (h6b_2 - 1)))),p7b_2,p3b_2,h4b_2,h6b_2) 2231 end if 2232 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 2233 &,int_mb(k_range+h4b-1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1) 2234 &,4,1,2,3,-1.0d0) 2235 END IF 2236 IF ((h6b .lt. h4b) .and. (p7b .lt. p3b)) THEN 2237 if(.not.intorb) then 2238 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 2239 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 2240 &+nvab) * (h6b_2 - 1))))) 2241 else 2242 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 2243 &(p3b_2 2244 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 2245 &+nvab) * (h6b_2 - 1)))),p3b_2,p7b_2,h4b_2,h6b_2) 2246 end if 2247 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 2248 &,int_mb(k_range+h4b-1),int_mb(k_range+p7b-1),int_mb(k_range+p3b-1) 2249 &,3,1,2,4,1.0d0) 2250 END IF 2251 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_4_2',6,MA_ERR) 2252 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2253 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2254 &t),dima_sort) 2255 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_4_2',7,MA_ER 2256 &R) 2257 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_4_2',8,MA_ER 2258 &R) 2259 END IF 2260 END IF 2261 END IF 2262 END DO 2263 END DO 2264 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2265 &cc2_x1_4_2',9,MA_ERR) 2266 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p7b-1) 2267 &,int_mb(k_range+h6b-1),2,1,1.0d0) 2268 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b - 2269 & noab - 1 + nvab * (h6b - 1))) 2270 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_4_2',10,MA_ERR) 2271 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_4_2',11,MA_E 2272 &RR) 2273 END IF 2274 END IF 2275 END IF 2276 next = NXTASK(nprocs,1) 2277 END IF 2278 count = count + 1 2279 END DO 2280 END DO 2281 next = NXTASK(-nprocs,1) 2282 call GA_SYNC() 2283 RETURN 2284 END 2285 SUBROUTINE cc2_x1_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 2286C $Id$ 2287C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2288C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2289C i0 ( p2 h1 )_xv + = -1/2 * Sum ( p7 h6 h8 ) * x ( p2 p7 h6 h8 )_x * i1 ( h6 h8 h1 p7 )_v 2290 IMPLICIT NONE 2291#include "global.fh" 2292#include "mafdecls.fh" 2293#include "sym.fh" 2294#include "errquit.fh" 2295#include "tce.fh" 2296 INTEGER d_a 2297 INTEGER k_a_offset 2298 INTEGER d_b 2299 INTEGER k_b_offset 2300 INTEGER d_c 2301 INTEGER k_c_offset 2302 INTEGER NXTASK 2303 INTEGER next 2304 INTEGER nprocs 2305 INTEGER count 2306 INTEGER p2b 2307 INTEGER h1b 2308 INTEGER dimc 2309 INTEGER l_c_sort 2310 INTEGER k_c_sort 2311 INTEGER p7b 2312 INTEGER h6b 2313 INTEGER h8b 2314 INTEGER p2b_1 2315 INTEGER p7b_1 2316 INTEGER h6b_1 2317 INTEGER h8b_1 2318 INTEGER h6b_2 2319 INTEGER h8b_2 2320 INTEGER h1b_2 2321 INTEGER p7b_2 2322 INTEGER dim_common 2323 INTEGER dima_sort 2324 INTEGER dima 2325 INTEGER dimb_sort 2326 INTEGER dimb 2327 INTEGER l_a_sort 2328 INTEGER k_a_sort 2329 INTEGER l_a 2330 INTEGER k_a 2331 INTEGER l_b_sort 2332 INTEGER k_b_sort 2333 INTEGER l_b 2334 INTEGER k_b 2335 INTEGER nsubh(2) 2336 INTEGER isubh 2337 INTEGER l_c 2338 INTEGER k_c 2339 DOUBLE PRECISION FACTORIAL 2340 EXTERNAL NXTASK 2341 EXTERNAL FACTORIAL 2342 nprocs = GA_NNODES() 2343 count = 0 2344 next = NXTASK(nprocs,1) 2345 DO p2b = noab+1,noab+nvab 2346 DO h1b = 1,noab 2347 IF (next.eq.count) THEN 2348 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 2349 &).ne.4)) THEN 2350 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2351 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 2352 &x,irrep_v)) THEN 2353 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 2354 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2355 & ERRQUIT('cc2_x1_5',0,MA_ERR) 2356 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2357 DO p7b = noab+1,noab+nvab 2358 DO h6b = 1,noab 2359 DO h8b = h6b,noab 2360 IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h 2361 &6b-1)+int_mb(k_spin+h8b-1)) THEN 2362 IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb( 2363 &k_sym+h6b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_x) THEN 2364 CALL TCE_RESTRICTED_4(p2b,p7b,h6b,h8b,p2b_1,p7b_1,h6b_1,h8b_1) 2365 CALL TCE_RESTRICTED_4(h6b,h8b,h1b,p7b,h6b_2,h8b_2,h1b_2,p7b_2) 2366 dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+h6b-1) * int_m 2367 &b(k_range+h8b-1) 2368 dima_sort = int_mb(k_range+p2b-1) 2369 dima = dim_common * dima_sort 2370 dimb_sort = int_mb(k_range+h1b-1) 2371 dimb = dim_common * dimb_sort 2372 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2373 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2374 & ERRQUIT('cc2_x1_5',1,MA_ERR) 2375 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2376 &cc2_x1_5',2,MA_ERR) 2377 IF ((p7b .lt. p2b)) THEN 2378 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 2379 & - 1 + noab * (h6b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p7b_ 2380 &1 - noab - 1))))) 2381 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 2382 &,int_mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h8b-1) 2383 &,2,4,3,1,-1.0d0) 2384 END IF 2385 IF ((p2b .le. p7b)) THEN 2386 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 2387 & - 1 + noab * (h6b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p2b_ 2388 &1 - noab - 1))))) 2389 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 2390 &,int_mb(k_range+p7b-1),int_mb(k_range+h6b-1),int_mb(k_range+h8b-1) 2391 &,1,4,3,2,1.0d0) 2392 END IF 2393 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_5',3,MA_ERR) 2394 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2395 & ERRQUIT('cc2_x1_5',4,MA_ERR) 2396 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2397 &cc2_x1_5',5,MA_ERR) 2398 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 2399 & - noab - 1 + nvab * (h1b_2 - 1 + noab * (h8b_2 - 1 + noab * (h6b_ 2400 &2 - 1))))) 2401 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 2402 &,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),int_mb(k_range+p7b-1) 2403 &,3,2,1,4,1.0d0) 2404 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_5',6,MA_ERR) 2405 nsubh(1) = 1 2406 nsubh(2) = 1 2407 isubh = 1 2408 IF (h6b .eq. h8b) THEN 2409 nsubh(isubh) = nsubh(isubh) + 1 2410 ELSE 2411 isubh = isubh + 1 2412 END IF 2413 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 2414 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 2415 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 2416 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_5',7,MA_ERR) 2417 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_5',8,MA_ERR) 2418 END IF 2419 END IF 2420 END IF 2421 END DO 2422 END DO 2423 END DO 2424 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2425 &cc2_x1_5',9,MA_ERR) 2426 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 2427 &,int_mb(k_range+p2b-1),2,1,-1.0d0/2.0d0) 2428 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2429 & 1 + noab * (p2b - noab - 1))) 2430 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_5',10,MA_ERR) 2431 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_5',11,MA_ERR 2432 &) 2433 END IF 2434 END IF 2435 END IF 2436 next = NXTASK(nprocs,1) 2437 END IF 2438 count = count + 1 2439 END DO 2440 END DO 2441 next = NXTASK(-nprocs,1) 2442 call GA_SYNC() 2443 RETURN 2444 END 2445 SUBROUTINE cc2_x1_5_1(d_a,k_a_offset,d_c,k_c_offset) 2446C $Id$ 2447C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2448C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2449C i1 ( h6 h8 h1 p7 )_v + = 1 * v ( h6 h8 h1 p7 )_v 2450 IMPLICIT NONE 2451#include "global.fh" 2452#include "mafdecls.fh" 2453#include "sym.fh" 2454#include "errquit.fh" 2455#include "tce.fh" 2456 INTEGER d_a 2457 INTEGER k_a_offset 2458 INTEGER d_c 2459 INTEGER k_c_offset 2460 INTEGER NXTASK 2461 INTEGER next 2462 INTEGER nprocs 2463 INTEGER count 2464 INTEGER h6b 2465 INTEGER h8b 2466 INTEGER h1b 2467 INTEGER p7b 2468 INTEGER dimc 2469 INTEGER h6b_1 2470 INTEGER h8b_1 2471 INTEGER h1b_1 2472 INTEGER p7b_1 2473 INTEGER dim_common 2474 INTEGER dima_sort 2475 INTEGER dima 2476 INTEGER l_a_sort 2477 INTEGER k_a_sort 2478 INTEGER l_a 2479 INTEGER k_a 2480 INTEGER l_c 2481 INTEGER k_c 2482 EXTERNAL NXTASK 2483 nprocs = GA_NNODES() 2484 count = 0 2485 next = NXTASK(nprocs,1) 2486 DO h6b = 1,noab 2487 DO h8b = h6b,noab 2488 DO h1b = 1,noab 2489 DO p7b = noab+1,noab+nvab 2490 IF (next.eq.count) THEN 2491 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1 2492 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p7b-1).ne.8)) THEN 2493 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h 2494 &1b-1)+int_mb(k_spin+p7b-1)) THEN 2495 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb( 2496 &k_sym+h1b-1),int_mb(k_sym+p7b-1)))) .eq. irrep_v) THEN 2497 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h8b-1) * int_mb(k_ra 2498 &nge+h1b-1) * int_mb(k_range+p7b-1) 2499 CALL TCE_RESTRICTED_4(h6b,h8b,h1b,p7b,h6b_1,h8b_1,h1b_1,p7b_1) 2500 dim_common = 1 2501 dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h8b-1) * int_mb 2502 &(k_range+h1b-1) * int_mb(k_range+p7b-1) 2503 dima = dim_common * dima_sort 2504 IF (dima .gt. 0) THEN 2505 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2506 & ERRQUIT('cc2_x1_5_1',0,MA_ERR) 2507 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2508 &cc2_x1_5_1',1,MA_ERR) 2509 IF ((h1b .le. p7b)) THEN 2510 if(.not.intorb) then 2511 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p7b_1 2512 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h8b_1 - 1 + (noab 2513 &+nvab) * (h6b_1 - 1))))) 2514 else 2515 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset), 2516 &(p7b_1 2517 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h8b_1 - 1 + (noab 2518 &+nvab) * (h6b_1 - 1)))),p7b_1,h1b_1,h8b_1,h6b_1) 2519 end if 2520 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1) 2521 &,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),int_mb(k_range+p7b-1) 2522 &,4,3,2,1,1.0d0) 2523 END IF 2524 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_5_1',2,MA_ERR) 2525 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2526 &cc2_x1_5_1',3,MA_ERR) 2527 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p7b-1) 2528 &,int_mb(k_range+h1b-1),int_mb(k_range+h8b-1),int_mb(k_range+h6b-1) 2529 &,4,3,2,1,1.0d0) 2530 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b - 2531 & noab - 1 + nvab * (h1b - 1 + noab * (h8b - 1 + noab * (h6b - 1))) 2532 &)) 2533 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_5_1',4,MA_ERR) 2534 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_5_1',5,MA_ER 2535 &R) 2536 END IF 2537 END IF 2538 END IF 2539 END IF 2540 next = NXTASK(nprocs,1) 2541 END IF 2542 count = count + 1 2543 END DO 2544 END DO 2545 END DO 2546 END DO 2547 next = NXTASK(-nprocs,1) 2548 call GA_SYNC() 2549 RETURN 2550 END 2551 SUBROUTINE OFFSET_cc2_x1_5_1(l_a_offset,k_a_offset,size) 2552C $Id$ 2553C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2554C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2555C i1 ( h6 h8 h1 p7 )_v 2556 IMPLICIT NONE 2557#include "global.fh" 2558#include "mafdecls.fh" 2559#include "sym.fh" 2560#include "errquit.fh" 2561#include "tce.fh" 2562 INTEGER l_a_offset 2563 INTEGER k_a_offset 2564 INTEGER size 2565 INTEGER length 2566 INTEGER addr 2567 INTEGER h6b 2568 INTEGER h8b 2569 INTEGER h1b 2570 INTEGER p7b 2571 length = 0 2572 DO h6b = 1,noab 2573 DO h8b = h6b,noab 2574 DO h1b = 1,noab 2575 DO p7b = noab+1,noab+nvab 2576 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h 2577 &1b-1)+int_mb(k_spin+p7b-1)) THEN 2578 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb( 2579 &k_sym+h1b-1),int_mb(k_sym+p7b-1)))) .eq. irrep_v) THEN 2580 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1 2581 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p7b-1).ne.8)) THEN 2582 length = length + 1 2583 END IF 2584 END IF 2585 END IF 2586 END DO 2587 END DO 2588 END DO 2589 END DO 2590 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2591 &set)) CALL ERRQUIT('cc2_x1_5_1',0,MA_ERR) 2592 int_mb(k_a_offset) = length 2593 addr = 0 2594 size = 0 2595 DO h6b = 1,noab 2596 DO h8b = h6b,noab 2597 DO h1b = 1,noab 2598 DO p7b = noab+1,noab+nvab 2599 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h 2600 &1b-1)+int_mb(k_spin+p7b-1)) THEN 2601 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb( 2602 &k_sym+h1b-1),int_mb(k_sym+p7b-1)))) .eq. irrep_v) THEN 2603 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1 2604 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p7b-1).ne.8)) THEN 2605 addr = addr + 1 2606 int_mb(k_a_offset+addr) = p7b - noab - 1 + nvab * (h1b - 1 + noab 2607 &* (h8b - 1 + noab * (h6b - 1))) 2608 int_mb(k_a_offset+length+addr) = size 2609 size = size + int_mb(k_range+h6b-1) * int_mb(k_range+h8b-1) * int_ 2610 &mb(k_range+h1b-1) * int_mb(k_range+p7b-1) 2611 END IF 2612 END IF 2613 END IF 2614 END DO 2615 END DO 2616 END DO 2617 END DO 2618 RETURN 2619 END 2620 SUBROUTINE cc2_x1_5_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 2621 &) 2622C $Id$ 2623C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2624C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2625C i1 ( h6 h8 h1 p7 )_vt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * v ( h6 h8 p3 p7 )_v 2626 IMPLICIT NONE 2627#include "global.fh" 2628#include "mafdecls.fh" 2629#include "sym.fh" 2630#include "errquit.fh" 2631#include "tce.fh" 2632 INTEGER d_a 2633 INTEGER k_a_offset 2634 INTEGER d_b 2635 INTEGER k_b_offset 2636 INTEGER d_c 2637 INTEGER k_c_offset 2638 INTEGER NXTASK 2639 INTEGER next 2640 INTEGER nprocs 2641 INTEGER count 2642 INTEGER h6b 2643 INTEGER h8b 2644 INTEGER h1b 2645 INTEGER p7b 2646 INTEGER dimc 2647 INTEGER l_c_sort 2648 INTEGER k_c_sort 2649 INTEGER p3b 2650 INTEGER p3b_1 2651 INTEGER h1b_1 2652 INTEGER h6b_2 2653 INTEGER h8b_2 2654 INTEGER p7b_2 2655 INTEGER p3b_2 2656 INTEGER dim_common 2657 INTEGER dima_sort 2658 INTEGER dima 2659 INTEGER dimb_sort 2660 INTEGER dimb 2661 INTEGER l_a_sort 2662 INTEGER k_a_sort 2663 INTEGER l_a 2664 INTEGER k_a 2665 INTEGER l_b_sort 2666 INTEGER k_b_sort 2667 INTEGER l_b 2668 INTEGER k_b 2669 INTEGER l_c 2670 INTEGER k_c 2671 EXTERNAL NXTASK 2672 nprocs = GA_NNODES() 2673 count = 0 2674 next = NXTASK(nprocs,1) 2675 DO h6b = 1,noab 2676 DO h8b = h6b,noab 2677 DO h1b = 1,noab 2678 DO p7b = noab+1,noab+nvab 2679 IF (next.eq.count) THEN 2680 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1 2681 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p7b-1).ne.8)) THEN 2682 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h 2683 &1b-1)+int_mb(k_spin+p7b-1)) THEN 2684 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb( 2685 &k_sym+h1b-1),int_mb(k_sym+p7b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 2686 &EN 2687 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h8b-1) * int_mb(k_ra 2688 &nge+h1b-1) * int_mb(k_range+p7b-1) 2689 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2690 & ERRQUIT('cc2_x1_5_2',0,MA_ERR) 2691 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2692 DO p3b = noab+1,noab+nvab 2693 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2694 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 2695 &EN 2696 CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1) 2697 CALL TCE_RESTRICTED_4(h6b,h8b,p7b,p3b,h6b_2,h8b_2,p7b_2,p3b_2) 2698 dim_common = int_mb(k_range+p3b-1) 2699 dima_sort = int_mb(k_range+h1b-1) 2700 dima = dim_common * dima_sort 2701 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h8b-1) * int_mb 2702 &(k_range+p7b-1) 2703 dimb = dim_common * dimb_sort 2704 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2705 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2706 & ERRQUIT('cc2_x1_5_2',1,MA_ERR) 2707 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2708 &cc2_x1_5_2',2,MA_ERR) 2709 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 2710 &int_mb(k_a_offset),(h1b_1 2711 & - 1 + noab * (p3b_1 - noab - 1))) 2712 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2713 &,int_mb(k_range+h1b-1),2,1,1.0d0) 2714 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_5_2',3,MA_ERR) 2715 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2716 & ERRQUIT('cc2_x1_5_2',4,MA_ERR) 2717 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2718 &cc2_x1_5_2',5,MA_ERR) 2719 IF ((p3b .le. p7b)) THEN 2720 if(.not.intorb) then 2721 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 2722 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 2723 &+nvab) * (h6b_2 - 1))))) 2724 else 2725 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 2726 &(p7b_2 2727 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 2728 &+nvab) * (h6b_2 - 1)))),p7b_2,p3b_2,h8b_2,h6b_2) 2729 end if 2730 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 2731 &,int_mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1) 2732 &,4,2,1,3,1.0d0) 2733 END IF 2734 IF ((p7b .lt. p3b)) THEN 2735 if(.not.intorb) then 2736 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 2737 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 2738 &+nvab) * (h6b_2 - 1))))) 2739 else 2740 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 2741 &(p3b_2 2742 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 2743 &+nvab) * (h6b_2 - 1)))),p3b_2,p7b_2,h8b_2,h6b_2) 2744 end if 2745 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 2746 &,int_mb(k_range+h8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p3b-1) 2747 &,3,2,1,4,-1.0d0) 2748 END IF 2749 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_5_2',6,MA_ERR) 2750 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2751 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2752 &t),dima_sort) 2753 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_5_2',7,MA_ER 2754 &R) 2755 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_5_2',8,MA_ER 2756 &R) 2757 END IF 2758 END IF 2759 END IF 2760 END DO 2761 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2762 &cc2_x1_5_2',9,MA_ERR) 2763 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p7b-1) 2764 &,int_mb(k_range+h8b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 2765 &,3,2,4,1,1.0d0) 2766 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b - 2767 & noab - 1 + nvab * (h1b - 1 + noab * (h8b - 1 + noab * (h6b - 1))) 2768 &)) 2769 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_5_2',10,MA_ERR) 2770 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_5_2',11,MA_E 2771 &RR) 2772 END IF 2773 END IF 2774 END IF 2775 next = NXTASK(nprocs,1) 2776 END IF 2777 count = count + 1 2778 END DO 2779 END DO 2780 END DO 2781 END DO 2782 next = NXTASK(-nprocs,1) 2783 call GA_SYNC() 2784 RETURN 2785 END 2786 SUBROUTINE cc2_x1_6(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 2787C $Id$ 2788C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2789C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2790C i0 ( p2 h1 )_xv + = -1/2 * Sum ( p4 p5 h3 ) * x ( p4 p5 h1 h3 )_x * v ( h3 p2 p4 p5 )_v 2791 IMPLICIT NONE 2792#include "global.fh" 2793#include "mafdecls.fh" 2794#include "sym.fh" 2795#include "errquit.fh" 2796#include "tce.fh" 2797 INTEGER d_a 2798 INTEGER k_a_offset 2799 INTEGER d_b 2800 INTEGER k_b_offset 2801 INTEGER d_c 2802 INTEGER k_c_offset 2803 INTEGER NXTASK 2804 INTEGER next 2805 INTEGER nprocs 2806 INTEGER count 2807 INTEGER p2b 2808 INTEGER h1b 2809 INTEGER dimc 2810 INTEGER l_c_sort 2811 INTEGER k_c_sort 2812 INTEGER p4b 2813 INTEGER p5b 2814 INTEGER h3b 2815 INTEGER p4b_1 2816 INTEGER p5b_1 2817 INTEGER h1b_1 2818 INTEGER h3b_1 2819 INTEGER p2b_2 2820 INTEGER h3b_2 2821 INTEGER p4b_2 2822 INTEGER p5b_2 2823 INTEGER dim_common 2824 INTEGER dima_sort 2825 INTEGER dima 2826 INTEGER dimb_sort 2827 INTEGER dimb 2828 INTEGER l_a_sort 2829 INTEGER k_a_sort 2830 INTEGER l_a 2831 INTEGER k_a 2832 INTEGER l_b_sort 2833 INTEGER k_b_sort 2834 INTEGER l_b 2835 INTEGER k_b 2836 INTEGER nsuperp(2) 2837 INTEGER isuperp 2838 INTEGER l_c 2839 INTEGER k_c 2840 DOUBLE PRECISION FACTORIAL 2841 EXTERNAL NXTASK 2842 EXTERNAL FACTORIAL 2843 nprocs = GA_NNODES() 2844 count = 0 2845 next = NXTASK(nprocs,1) 2846 DO p2b = noab+1,noab+nvab 2847 DO h1b = 1,noab 2848 IF (next.eq.count) THEN 2849 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 2850 &).ne.4)) THEN 2851 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2852 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 2853 &x,irrep_v)) THEN 2854 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 2855 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2856 & ERRQUIT('cc2_x1_6',0,MA_ERR) 2857 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2858 DO p4b = noab+1,noab+nvab 2859 DO p5b = p4b,noab+nvab 2860 DO h3b = 1,noab 2861 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 2862 &1b-1)+int_mb(k_spin+h3b-1)) THEN 2863 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 2864 &k_sym+h1b-1),int_mb(k_sym+h3b-1)))) .eq. irrep_x) THEN 2865 CALL TCE_RESTRICTED_4(p4b,p5b,h1b,h3b,p4b_1,p5b_1,h1b_1,h3b_1) 2866 CALL TCE_RESTRICTED_4(p2b,h3b,p4b,p5b,p2b_2,h3b_2,p4b_2,p5b_2) 2867 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_m 2868 &b(k_range+h3b-1) 2869 dima_sort = int_mb(k_range+h1b-1) 2870 dima = dim_common * dima_sort 2871 dimb_sort = int_mb(k_range+p2b-1) 2872 dimb = dim_common * dimb_sort 2873 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2874 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2875 & ERRQUIT('cc2_x1_6',1,MA_ERR) 2876 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2877 &cc2_x1_6',2,MA_ERR) 2878 IF ((h3b .lt. h1b)) THEN 2879 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2880 & - 1 + noab * (h3b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_ 2881 &1 - noab - 1))))) 2882 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 2883 &,int_mb(k_range+p5b-1),int_mb(k_range+h3b-1),int_mb(k_range+h1b-1) 2884 &,4,3,2,1,-1.0d0) 2885 END IF 2886 IF ((h1b .le. h3b)) THEN 2887 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 2888 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_ 2889 &1 - noab - 1))))) 2890 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 2891 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h3b-1) 2892 &,3,4,2,1,1.0d0) 2893 END IF 2894 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_6',3,MA_ERR) 2895 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2896 & ERRQUIT('cc2_x1_6',4,MA_ERR) 2897 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2898 &cc2_x1_6',5,MA_ERR) 2899 IF ((h3b .le. p2b)) THEN 2900 if(.not.intorb) then 2901 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 2902 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 2903 &+nvab) * (h3b_2 - 1))))) 2904 else 2905 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 2906 &(p5b_2 2907 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 2908 &+nvab) * (h3b_2 - 1)))),p5b_2,p4b_2,p2b_2,h3b_2) 2909 end if 2910 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 2911 &,int_mb(k_range+p2b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1) 2912 &,2,1,4,3,1.0d0) 2913 END IF 2914 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_6',6,MA_ERR) 2915 nsuperp(1) = 1 2916 nsuperp(2) = 1 2917 isuperp = 1 2918 IF (p4b .eq. p5b) THEN 2919 nsuperp(isuperp) = nsuperp(isuperp) + 1 2920 ELSE 2921 isuperp = isuperp + 1 2922 END IF 2923 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 2924 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 2925 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 2926 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_6',7,MA_ERR) 2927 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_6',8,MA_ERR) 2928 END IF 2929 END IF 2930 END IF 2931 END DO 2932 END DO 2933 END DO 2934 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2935 &cc2_x1_6',9,MA_ERR) 2936 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1) 2937 &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0) 2938 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2939 & 1 + noab * (p2b - noab - 1))) 2940 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_6',10,MA_ERR) 2941 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_6',11,MA_ERR 2942 &) 2943 END IF 2944 END IF 2945 END IF 2946 next = NXTASK(nprocs,1) 2947 END IF 2948 count = count + 1 2949 END DO 2950 END DO 2951 next = NXTASK(-nprocs,1) 2952 call GA_SYNC() 2953 RETURN 2954 END 2955 SUBROUTINE cc2_x1_7(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 2956C $Id$ 2957C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2958C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2959C i0 ( p2 h1 )_fxt + = -1 * Sum ( h8 ) * t ( p2 h8 )_t * i1 ( h8 h1 )_fx 2960 IMPLICIT NONE 2961#include "global.fh" 2962#include "mafdecls.fh" 2963#include "sym.fh" 2964#include "errquit.fh" 2965#include "tce.fh" 2966 INTEGER d_a 2967 INTEGER k_a_offset 2968 INTEGER d_b 2969 INTEGER k_b_offset 2970 INTEGER d_c 2971 INTEGER k_c_offset 2972 INTEGER NXTASK 2973 INTEGER next 2974 INTEGER nprocs 2975 INTEGER count 2976 INTEGER p2b 2977 INTEGER h1b 2978 INTEGER dimc 2979 INTEGER l_c_sort 2980 INTEGER k_c_sort 2981 INTEGER h8b 2982 INTEGER p2b_1 2983 INTEGER h8b_1 2984 INTEGER h8b_2 2985 INTEGER h1b_2 2986 INTEGER dim_common 2987 INTEGER dima_sort 2988 INTEGER dima 2989 INTEGER dimb_sort 2990 INTEGER dimb 2991 INTEGER l_a_sort 2992 INTEGER k_a_sort 2993 INTEGER l_a 2994 INTEGER k_a 2995 INTEGER l_b_sort 2996 INTEGER k_b_sort 2997 INTEGER l_b 2998 INTEGER k_b 2999 INTEGER l_c 3000 INTEGER k_c 3001 EXTERNAL NXTASK 3002 nprocs = GA_NNODES() 3003 count = 0 3004 next = NXTASK(nprocs,1) 3005 DO p2b = noab+1,noab+nvab 3006 DO h1b = 1,noab 3007 IF (next.eq.count) THEN 3008 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 3009 &).ne.4)) THEN 3010 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3011 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 3012 &f,ieor(irrep_x,irrep_t))) THEN 3013 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 3014 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3015 & ERRQUIT('cc2_x1_7',0,MA_ERR) 3016 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3017 DO h8b = 1,noab 3018 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h8b-1)) THEN 3019 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h8b-1)) .eq. irrep_t) TH 3020 &EN 3021 CALL TCE_RESTRICTED_2(p2b,h8b,p2b_1,h8b_1) 3022 CALL TCE_RESTRICTED_2(h8b,h1b,h8b_2,h1b_2) 3023 dim_common = int_mb(k_range+h8b-1) 3024 dima_sort = int_mb(k_range+p2b-1) 3025 dima = dim_common * dima_sort 3026 dimb_sort = int_mb(k_range+h1b-1) 3027 dimb = dim_common * dimb_sort 3028 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3029 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3030 & ERRQUIT('cc2_x1_7',1,MA_ERR) 3031 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3032 &cc2_x1_7',2,MA_ERR) 3033 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 3034 &int_mb(k_a_offset),(h8b_1 3035 & - 1 + noab * (p2b_1 - noab - 1))) 3036 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 3037 &,int_mb(k_range+h8b-1),1,2,1.0d0) 3038 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7',3,MA_ERR) 3039 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3040 & ERRQUIT('cc2_x1_7',4,MA_ERR) 3041 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3042 &cc2_x1_7',5,MA_ERR) 3043 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 3044 & - 1 + noab * (h8b_2 - 1))) 3045 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 3046 &,int_mb(k_range+h1b-1),2,1,1.0d0) 3047 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7',6,MA_ERR) 3048 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3049 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3050 &t),dima_sort) 3051 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7',7,MA_ERR) 3052 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7',8,MA_ERR) 3053 END IF 3054 END IF 3055 END IF 3056 END DO 3057 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3058 &cc2_x1_7',9,MA_ERR) 3059 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 3060 &,int_mb(k_range+p2b-1),2,1,-1.0d0) 3061 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 3062 & 1 + noab * (p2b - noab - 1))) 3063 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7',10,MA_ERR) 3064 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7',11,MA_ERR 3065 &) 3066 END IF 3067 END IF 3068 END IF 3069 next = NXTASK(nprocs,1) 3070 END IF 3071 count = count + 1 3072 END DO 3073 END DO 3074 next = NXTASK(-nprocs,1) 3075 call GA_SYNC() 3076 RETURN 3077 END 3078 SUBROUTINE cc2_x1_7_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 3079 &) 3080C $Id$ 3081C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3082C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3083C i1 ( h8 h1 )_fx + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * i2 ( h8 p3 )_f 3084 IMPLICIT NONE 3085#include "global.fh" 3086#include "mafdecls.fh" 3087#include "sym.fh" 3088#include "errquit.fh" 3089#include "tce.fh" 3090 INTEGER d_a 3091 INTEGER k_a_offset 3092 INTEGER d_b 3093 INTEGER k_b_offset 3094 INTEGER d_c 3095 INTEGER k_c_offset 3096 INTEGER NXTASK 3097 INTEGER next 3098 INTEGER nprocs 3099 INTEGER count 3100 INTEGER h8b 3101 INTEGER h1b 3102 INTEGER dimc 3103 INTEGER l_c_sort 3104 INTEGER k_c_sort 3105 INTEGER p3b 3106 INTEGER p3b_1 3107 INTEGER h1b_1 3108 INTEGER h8b_2 3109 INTEGER p3b_2 3110 INTEGER dim_common 3111 INTEGER dima_sort 3112 INTEGER dima 3113 INTEGER dimb_sort 3114 INTEGER dimb 3115 INTEGER l_a_sort 3116 INTEGER k_a_sort 3117 INTEGER l_a 3118 INTEGER k_a 3119 INTEGER l_b_sort 3120 INTEGER k_b_sort 3121 INTEGER l_b 3122 INTEGER k_b 3123 INTEGER l_c 3124 INTEGER k_c 3125 EXTERNAL NXTASK 3126 nprocs = GA_NNODES() 3127 count = 0 3128 next = NXTASK(nprocs,1) 3129 DO h8b = 1,noab 3130 DO h1b = 1,noab 3131 IF (next.eq.count) THEN 3132 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 3133 &).ne.4)) THEN 3134 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3135 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 3136 &f,irrep_x)) THEN 3137 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 3138 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3139 & ERRQUIT('cc2_x1_7_1',0,MA_ERR) 3140 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3141 DO p3b = noab+1,noab+nvab 3142 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3143 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH 3144 &EN 3145 CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1) 3146 CALL TCE_RESTRICTED_2(h8b,p3b,h8b_2,p3b_2) 3147 dim_common = int_mb(k_range+p3b-1) 3148 dima_sort = int_mb(k_range+h1b-1) 3149 dima = dim_common * dima_sort 3150 dimb_sort = int_mb(k_range+h8b-1) 3151 dimb = dim_common * dimb_sort 3152 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3153 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3154 & ERRQUIT('cc2_x1_7_1',1,MA_ERR) 3155 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3156 &cc2_x1_7_1',2,MA_ERR) 3157 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 3158 &int_mb(k_a_offset),(h1b_1 3159 & - 1 + noab * (p3b_1 - noab - 1))) 3160 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 3161 &,int_mb(k_range+h1b-1),2,1,1.0d0) 3162 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_1',3,MA_ERR) 3163 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3164 & ERRQUIT('cc2_x1_7_1',4,MA_ERR) 3165 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3166 &cc2_x1_7_1',5,MA_ERR) 3167 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 3168 & - noab - 1 + nvab * (h8b_2 - 1))) 3169 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 3170 &,int_mb(k_range+p3b-1),1,2,1.0d0) 3171 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_1',6,MA_ERR) 3172 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3173 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3174 &t),dima_sort) 3175 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_1',7,MA_ER 3176 &R) 3177 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_1',8,MA_ER 3178 &R) 3179 END IF 3180 END IF 3181 END IF 3182 END DO 3183 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3184 &cc2_x1_7_1',9,MA_ERR) 3185 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1) 3186 &,int_mb(k_range+h1b-1),1,2,1.0d0) 3187 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 3188 & 1 + noab * (h8b - 1))) 3189 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_1',10,MA_ERR) 3190 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_1',11,MA_E 3191 &RR) 3192 END IF 3193 END IF 3194 END IF 3195 next = NXTASK(nprocs,1) 3196 END IF 3197 count = count + 1 3198 END DO 3199 END DO 3200 next = NXTASK(-nprocs,1) 3201 call GA_SYNC() 3202 RETURN 3203 END 3204 SUBROUTINE OFFSET_cc2_x1_7_1(l_a_offset,k_a_offset,size) 3205C $Id$ 3206C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3207C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3208C i1 ( h8 h1 )_fx 3209 IMPLICIT NONE 3210#include "global.fh" 3211#include "mafdecls.fh" 3212#include "sym.fh" 3213#include "errquit.fh" 3214#include "tce.fh" 3215 INTEGER l_a_offset 3216 INTEGER k_a_offset 3217 INTEGER size 3218 INTEGER length 3219 INTEGER addr 3220 INTEGER h8b 3221 INTEGER h1b 3222 length = 0 3223 DO h8b = 1,noab 3224 DO h1b = 1,noab 3225 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3226 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 3227 &f,irrep_x)) THEN 3228 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 3229 &).ne.4)) THEN 3230 length = length + 1 3231 END IF 3232 END IF 3233 END IF 3234 END DO 3235 END DO 3236 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 3237 &set)) CALL ERRQUIT('cc2_x1_7_1',0,MA_ERR) 3238 int_mb(k_a_offset) = length 3239 addr = 0 3240 size = 0 3241 DO h8b = 1,noab 3242 DO h1b = 1,noab 3243 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3244 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 3245 &f,irrep_x)) THEN 3246 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 3247 &).ne.4)) THEN 3248 addr = addr + 1 3249 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h8b - 1) 3250 int_mb(k_a_offset+length+addr) = size 3251 size = size + int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 3252 END IF 3253 END IF 3254 END IF 3255 END DO 3256 END DO 3257 RETURN 3258 END 3259 SUBROUTINE cc2_x1_7_1_1(d_a,k_a_offset,d_c,k_c_offset) 3260C $Id$ 3261C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3262C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3263C i2 ( h8 p3 )_f + = 1 * f ( h8 p3 )_f 3264 IMPLICIT NONE 3265#include "global.fh" 3266#include "mafdecls.fh" 3267#include "sym.fh" 3268#include "errquit.fh" 3269#include "tce.fh" 3270 INTEGER d_a 3271 INTEGER k_a_offset 3272 INTEGER d_c 3273 INTEGER k_c_offset 3274 INTEGER NXTASK 3275 INTEGER next 3276 INTEGER nprocs 3277 INTEGER count 3278 INTEGER h8b 3279 INTEGER p3b 3280 INTEGER dimc 3281 INTEGER h8b_1 3282 INTEGER p3b_1 3283 INTEGER dim_common 3284 INTEGER dima_sort 3285 INTEGER dima 3286 INTEGER l_a_sort 3287 INTEGER k_a_sort 3288 INTEGER l_a 3289 INTEGER k_a 3290 INTEGER l_c 3291 INTEGER k_c 3292 EXTERNAL NXTASK 3293 nprocs = GA_NNODES() 3294 count = 0 3295 next = NXTASK(nprocs,1) 3296 DO h8b = 1,noab 3297 DO p3b = noab+1,noab+nvab 3298 IF (next.eq.count) THEN 3299 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1 3300 &).ne.4)) THEN 3301 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN 3302 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. irrep_f) TH 3303 &EN 3304 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1) 3305 CALL TCE_RESTRICTED_2(h8b,p3b,h8b_1,p3b_1) 3306 dim_common = 1 3307 dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1) 3308 dima = dim_common * dima_sort 3309 IF (dima .gt. 0) THEN 3310 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3311 & ERRQUIT('cc2_x1_7_1_1',0,MA_ERR) 3312 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3313 &cc2_x1_7_1_1',1,MA_ERR) 3314 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p3b_1 3315 & - 1 + (noab+nvab) * (h8b_1 - 1))) 3316 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1) 3317 &,int_mb(k_range+p3b-1),2,1,1.0d0) 3318 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_1_1',2,MA_ERR) 3319 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3320 &cc2_x1_7_1_1',3,MA_ERR) 3321 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 3322 &,int_mb(k_range+h8b-1),2,1,1.0d0) 3323 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 3324 & noab - 1 + nvab * (h8b - 1))) 3325 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_1_1',4,MA_ERR) 3326 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_1_1',5,MA_ 3327 &ERR) 3328 END IF 3329 END IF 3330 END IF 3331 END IF 3332 next = NXTASK(nprocs,1) 3333 END IF 3334 count = count + 1 3335 END DO 3336 END DO 3337 next = NXTASK(-nprocs,1) 3338 call GA_SYNC() 3339 RETURN 3340 END 3341 SUBROUTINE OFFSET_cc2_x1_7_1_1(l_a_offset,k_a_offset,size) 3342C $Id$ 3343C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3344C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3345C i2 ( h8 p3 )_f 3346 IMPLICIT NONE 3347#include "global.fh" 3348#include "mafdecls.fh" 3349#include "sym.fh" 3350#include "errquit.fh" 3351#include "tce.fh" 3352 INTEGER l_a_offset 3353 INTEGER k_a_offset 3354 INTEGER size 3355 INTEGER length 3356 INTEGER addr 3357 INTEGER h8b 3358 INTEGER p3b 3359 length = 0 3360 DO h8b = 1,noab 3361 DO p3b = noab+1,noab+nvab 3362 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN 3363 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. irrep_f) TH 3364 &EN 3365 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1 3366 &).ne.4)) THEN 3367 length = length + 1 3368 END IF 3369 END IF 3370 END IF 3371 END DO 3372 END DO 3373 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 3374 &set)) CALL ERRQUIT('cc2_x1_7_1_1',0,MA_ERR) 3375 int_mb(k_a_offset) = length 3376 addr = 0 3377 size = 0 3378 DO h8b = 1,noab 3379 DO p3b = noab+1,noab+nvab 3380 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN 3381 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. irrep_f) TH 3382 &EN 3383 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1 3384 &).ne.4)) THEN 3385 addr = addr + 1 3386 int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h8b - 1) 3387 int_mb(k_a_offset+length+addr) = size 3388 size = size + int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1) 3389 END IF 3390 END IF 3391 END IF 3392 END DO 3393 END DO 3394 RETURN 3395 END 3396 SUBROUTINE cc2_x1_7_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offs 3397 &et) 3398C $Id$ 3399C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3400C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3401C i2 ( h8 p3 )_vt + = -1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 h8 p3 p4 )_v 3402 IMPLICIT NONE 3403#include "global.fh" 3404#include "mafdecls.fh" 3405#include "sym.fh" 3406#include "errquit.fh" 3407#include "tce.fh" 3408 INTEGER d_a 3409 INTEGER k_a_offset 3410 INTEGER d_b 3411 INTEGER k_b_offset 3412 INTEGER d_c 3413 INTEGER k_c_offset 3414 INTEGER NXTASK 3415 INTEGER next 3416 INTEGER nprocs 3417 INTEGER count 3418 INTEGER h8b 3419 INTEGER p3b 3420 INTEGER dimc 3421 INTEGER l_c_sort 3422 INTEGER k_c_sort 3423 INTEGER p4b 3424 INTEGER h5b 3425 INTEGER p4b_1 3426 INTEGER h5b_1 3427 INTEGER h8b_2 3428 INTEGER h5b_2 3429 INTEGER p3b_2 3430 INTEGER p4b_2 3431 INTEGER dim_common 3432 INTEGER dima_sort 3433 INTEGER dima 3434 INTEGER dimb_sort 3435 INTEGER dimb 3436 INTEGER l_a_sort 3437 INTEGER k_a_sort 3438 INTEGER l_a 3439 INTEGER k_a 3440 INTEGER l_b_sort 3441 INTEGER k_b_sort 3442 INTEGER l_b 3443 INTEGER k_b 3444 INTEGER l_c 3445 INTEGER k_c 3446 EXTERNAL NXTASK 3447 nprocs = GA_NNODES() 3448 count = 0 3449 next = NXTASK(nprocs,1) 3450 DO h8b = 1,noab 3451 DO p3b = noab+1,noab+nvab 3452 IF (next.eq.count) THEN 3453 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1 3454 &).ne.4)) THEN 3455 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN 3456 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 3457 &v,irrep_t)) THEN 3458 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1) 3459 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3460 & ERRQUIT('cc2_x1_7_1_2',0,MA_ERR) 3461 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3462 DO p4b = noab+1,noab+nvab 3463 DO h5b = 1,noab 3464 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h5b-1)) THEN 3465 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h5b-1)) .eq. irrep_t) TH 3466 &EN 3467 CALL TCE_RESTRICTED_2(p4b,h5b,p4b_1,h5b_1) 3468 CALL TCE_RESTRICTED_4(h8b,h5b,p3b,p4b,h8b_2,h5b_2,p3b_2,p4b_2) 3469 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h5b-1) 3470 dima_sort = 1 3471 dima = dim_common * dima_sort 3472 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1) 3473 dimb = dim_common * dimb_sort 3474 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3475 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3476 & ERRQUIT('cc2_x1_7_1_2',1,MA_ERR) 3477 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3478 &cc2_x1_7_1_2',2,MA_ERR) 3479 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 3480 &int_mb(k_a_offset),(h5b_1 3481 & - 1 + noab * (p4b_1 - noab - 1))) 3482 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 3483 &,int_mb(k_range+h5b-1),2,1,1.0d0) 3484 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_1_2',3,MA_ERR) 3485 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3486 & ERRQUIT('cc2_x1_7_1_2',4,MA_ERR) 3487 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3488 &cc2_x1_7_1_2',5,MA_ERR) 3489 IF ((h5b .le. h8b) .and. (p4b .lt. p3b)) THEN 3490 if(.not.intorb) then 3491 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 3492 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3493 &+nvab) * (h5b_2 - 1))))) 3494 else 3495 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3496 &(p3b_2 3497 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3498 &+nvab) * (h5b_2 - 1)))),p3b_2,p4b_2,h8b_2,h5b_2) 3499 end if 3500 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 3501 &,int_mb(k_range+h8b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 3502 &,4,2,1,3,-1.0d0) 3503 END IF 3504 IF ((h5b .le. h8b) .and. (p3b .le. p4b)) THEN 3505 if(.not.intorb) then 3506 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 3507 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3508 &+nvab) * (h5b_2 - 1))))) 3509 else 3510 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3511 &(p4b_2 3512 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3513 &+nvab) * (h5b_2 - 1)))),p4b_2,p3b_2,h8b_2,h5b_2) 3514 end if 3515 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 3516 &,int_mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 3517 &,3,2,1,4,1.0d0) 3518 END IF 3519 IF ((h8b .lt. h5b) .and. (p4b .lt. p3b)) THEN 3520 if(.not.intorb) then 3521 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 3522 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 3523 &+nvab) * (h8b_2 - 1))))) 3524 else 3525 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3526 &(p3b_2 3527 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 3528 &+nvab) * (h8b_2 - 1)))),p3b_2,p4b_2,h5b_2,h8b_2) 3529 end if 3530 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 3531 &,int_mb(k_range+h5b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 3532 &,4,1,2,3,1.0d0) 3533 END IF 3534 IF ((h8b .lt. h5b) .and. (p3b .le. p4b)) THEN 3535 if(.not.intorb) then 3536 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 3537 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 3538 &+nvab) * (h8b_2 - 1))))) 3539 else 3540 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3541 &(p4b_2 3542 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 3543 &+nvab) * (h8b_2 - 1)))),p4b_2,p3b_2,h5b_2,h8b_2) 3544 end if 3545 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 3546 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 3547 &,3,1,2,4,-1.0d0) 3548 END IF 3549 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_1_2',6,MA_ERR) 3550 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3551 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3552 &t),dima_sort) 3553 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_1_2',7,MA_ 3554 &ERR) 3555 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_1_2',8,MA_ 3556 &ERR) 3557 END IF 3558 END IF 3559 END IF 3560 END DO 3561 END DO 3562 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3563 &cc2_x1_7_1_2',9,MA_ERR) 3564 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 3565 &,int_mb(k_range+h8b-1),2,1,-1.0d0) 3566 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 3567 & noab - 1 + nvab * (h8b - 1))) 3568 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_1_2',10,MA_ERR) 3569 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_1_2',11,MA 3570 &_ERR) 3571 END IF 3572 END IF 3573 END IF 3574 next = NXTASK(nprocs,1) 3575 END IF 3576 count = count + 1 3577 END DO 3578 END DO 3579 next = NXTASK(-nprocs,1) 3580 call GA_SYNC() 3581 RETURN 3582 END 3583 SUBROUTINE cc2_x1_7_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 3584 &) 3585C $Id$ 3586C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3587C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3588C i1 ( h8 h1 )_vx + = -1 * Sum ( h4 p5 ) * x ( p5 h4 )_x * v ( h4 h8 h1 p5 )_v 3589 IMPLICIT NONE 3590#include "global.fh" 3591#include "mafdecls.fh" 3592#include "sym.fh" 3593#include "errquit.fh" 3594#include "tce.fh" 3595 INTEGER d_a 3596 INTEGER k_a_offset 3597 INTEGER d_b 3598 INTEGER k_b_offset 3599 INTEGER d_c 3600 INTEGER k_c_offset 3601 INTEGER NXTASK 3602 INTEGER next 3603 INTEGER nprocs 3604 INTEGER count 3605 INTEGER h8b 3606 INTEGER h1b 3607 INTEGER dimc 3608 INTEGER l_c_sort 3609 INTEGER k_c_sort 3610 INTEGER p5b 3611 INTEGER h4b 3612 INTEGER p5b_1 3613 INTEGER h4b_1 3614 INTEGER h8b_2 3615 INTEGER h4b_2 3616 INTEGER h1b_2 3617 INTEGER p5b_2 3618 INTEGER dim_common 3619 INTEGER dima_sort 3620 INTEGER dima 3621 INTEGER dimb_sort 3622 INTEGER dimb 3623 INTEGER l_a_sort 3624 INTEGER k_a_sort 3625 INTEGER l_a 3626 INTEGER k_a 3627 INTEGER l_b_sort 3628 INTEGER k_b_sort 3629 INTEGER l_b 3630 INTEGER k_b 3631 INTEGER l_c 3632 INTEGER k_c 3633 EXTERNAL NXTASK 3634 nprocs = GA_NNODES() 3635 count = 0 3636 next = NXTASK(nprocs,1) 3637 DO h8b = 1,noab 3638 DO h1b = 1,noab 3639 IF (next.eq.count) THEN 3640 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 3641 &).ne.4)) THEN 3642 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3643 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 3644 &v,irrep_x)) THEN 3645 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 3646 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3647 & ERRQUIT('cc2_x1_7_2',0,MA_ERR) 3648 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3649 DO p5b = noab+1,noab+nvab 3650 DO h4b = 1,noab 3651 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h4b-1)) THEN 3652 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h4b-1)) .eq. irrep_x) TH 3653 &EN 3654 CALL TCE_RESTRICTED_2(p5b,h4b,p5b_1,h4b_1) 3655 CALL TCE_RESTRICTED_4(h8b,h4b,h1b,p5b,h8b_2,h4b_2,h1b_2,p5b_2) 3656 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h4b-1) 3657 dima_sort = 1 3658 dima = dim_common * dima_sort 3659 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 3660 dimb = dim_common * dimb_sort 3661 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3662 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3663 & ERRQUIT('cc2_x1_7_2',1,MA_ERR) 3664 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3665 &cc2_x1_7_2',2,MA_ERR) 3666 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 3667 &int_mb(k_a_offset),(h4b_1 3668 & - 1 + noab * (p5b_1 - noab - 1))) 3669 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3670 &,int_mb(k_range+h4b-1),2,1,1.0d0) 3671 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_2',3,MA_ERR) 3672 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3673 & ERRQUIT('cc2_x1_7_2',4,MA_ERR) 3674 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3675 &cc2_x1_7_2',5,MA_ERR) 3676 IF ((h4b .le. h8b) .and. (h1b .le. p5b)) THEN 3677 if(.not.intorb) then 3678 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 3679 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3680 &+nvab) * (h4b_2 - 1))))) 3681 else 3682 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3683 &(p5b_2 3684 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3685 &+nvab) * (h4b_2 - 1)))),p5b_2,h1b_2,h8b_2,h4b_2) 3686 end if 3687 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 3688 &,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1) 3689 &,3,2,1,4,1.0d0) 3690 END IF 3691 IF ((h8b .lt. h4b) .and. (h1b .le. p5b)) THEN 3692 if(.not.intorb) then 3693 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 3694 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 3695 &+nvab) * (h8b_2 - 1))))) 3696 else 3697 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3698 &(p5b_2 3699 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 3700 &+nvab) * (h8b_2 - 1)))),p5b_2,h1b_2,h4b_2,h8b_2) 3701 end if 3702 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 3703 &,int_mb(k_range+h4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1) 3704 &,3,1,2,4,-1.0d0) 3705 END IF 3706 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_2',6,MA_ERR) 3707 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3708 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3709 &t),dima_sort) 3710 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_2',7,MA_ER 3711 &R) 3712 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_2',8,MA_ER 3713 &R) 3714 END IF 3715 END IF 3716 END IF 3717 END DO 3718 END DO 3719 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3720 &cc2_x1_7_2',9,MA_ERR) 3721 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 3722 &,int_mb(k_range+h8b-1),2,1,-1.0d0) 3723 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 3724 & 1 + noab * (h8b - 1))) 3725 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_2',10,MA_ERR) 3726 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_2',11,MA_E 3727 &RR) 3728 END IF 3729 END IF 3730 END IF 3731 next = NXTASK(nprocs,1) 3732 END IF 3733 count = count + 1 3734 END DO 3735 END DO 3736 next = NXTASK(-nprocs,1) 3737 call GA_SYNC() 3738 RETURN 3739 END 3740 SUBROUTINE cc2_x1_7_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 3741 &) 3742C $Id$ 3743C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3744C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3745C i1 ( h8 h1 )_vx + = -1/2 * Sum ( h4 p5 p6 ) * x ( p5 p6 h1 h4 )_x * v ( h4 h8 p5 p6 )_v 3746 IMPLICIT NONE 3747#include "global.fh" 3748#include "mafdecls.fh" 3749#include "sym.fh" 3750#include "errquit.fh" 3751#include "tce.fh" 3752 INTEGER d_a 3753 INTEGER k_a_offset 3754 INTEGER d_b 3755 INTEGER k_b_offset 3756 INTEGER d_c 3757 INTEGER k_c_offset 3758 INTEGER NXTASK 3759 INTEGER next 3760 INTEGER nprocs 3761 INTEGER count 3762 INTEGER h8b 3763 INTEGER h1b 3764 INTEGER dimc 3765 INTEGER l_c_sort 3766 INTEGER k_c_sort 3767 INTEGER p5b 3768 INTEGER p6b 3769 INTEGER h4b 3770 INTEGER p5b_1 3771 INTEGER p6b_1 3772 INTEGER h1b_1 3773 INTEGER h4b_1 3774 INTEGER h8b_2 3775 INTEGER h4b_2 3776 INTEGER p5b_2 3777 INTEGER p6b_2 3778 INTEGER dim_common 3779 INTEGER dima_sort 3780 INTEGER dima 3781 INTEGER dimb_sort 3782 INTEGER dimb 3783 INTEGER l_a_sort 3784 INTEGER k_a_sort 3785 INTEGER l_a 3786 INTEGER k_a 3787 INTEGER l_b_sort 3788 INTEGER k_b_sort 3789 INTEGER l_b 3790 INTEGER k_b 3791 INTEGER nsuperp(2) 3792 INTEGER isuperp 3793 INTEGER l_c 3794 INTEGER k_c 3795 DOUBLE PRECISION FACTORIAL 3796 EXTERNAL NXTASK 3797 EXTERNAL FACTORIAL 3798 nprocs = GA_NNODES() 3799 count = 0 3800 next = NXTASK(nprocs,1) 3801 DO h8b = 1,noab 3802 DO h1b = 1,noab 3803 IF (next.eq.count) THEN 3804 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 3805 &).ne.4)) THEN 3806 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3807 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 3808 &v,irrep_x)) THEN 3809 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 3810 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3811 & ERRQUIT('cc2_x1_7_3',0,MA_ERR) 3812 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3813 DO p5b = noab+1,noab+nvab 3814 DO p6b = p5b,noab+nvab 3815 DO h4b = 1,noab 3816 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 3817 &1b-1)+int_mb(k_spin+h4b-1)) THEN 3818 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 3819 &k_sym+h1b-1),int_mb(k_sym+h4b-1)))) .eq. irrep_x) THEN 3820 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h4b,p5b_1,p6b_1,h1b_1,h4b_1) 3821 CALL TCE_RESTRICTED_4(h8b,h4b,p5b,p6b,h8b_2,h4b_2,p5b_2,p6b_2) 3822 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_m 3823 &b(k_range+h4b-1) 3824 dima_sort = int_mb(k_range+h1b-1) 3825 dima = dim_common * dima_sort 3826 dimb_sort = int_mb(k_range+h8b-1) 3827 dimb = dim_common * dimb_sort 3828 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3829 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3830 & ERRQUIT('cc2_x1_7_3',1,MA_ERR) 3831 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3832 &cc2_x1_7_3',2,MA_ERR) 3833 IF ((h4b .lt. h1b)) THEN 3834 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 3835 & - 1 + noab * (h4b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 3836 &1 - noab - 1))))) 3837 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3838 &,int_mb(k_range+p6b-1),int_mb(k_range+h4b-1),int_mb(k_range+h1b-1) 3839 &,4,3,2,1,-1.0d0) 3840 END IF 3841 IF ((h1b .le. h4b)) THEN 3842 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 3843 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 3844 &1 - noab - 1))))) 3845 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3846 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h4b-1) 3847 &,3,4,2,1,1.0d0) 3848 END IF 3849 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_3',3,MA_ERR) 3850 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3851 & ERRQUIT('cc2_x1_7_3',4,MA_ERR) 3852 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3853 &cc2_x1_7_3',5,MA_ERR) 3854 IF ((h4b .le. h8b)) THEN 3855 if(.not.intorb) then 3856 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 3857 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3858 &+nvab) * (h4b_2 - 1))))) 3859 else 3860 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3861 &(p6b_2 3862 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3863 &+nvab) * (h4b_2 - 1)))),p6b_2,p5b_2,h8b_2,h4b_2) 3864 end if 3865 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 3866 &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 3867 &,2,1,4,3,1.0d0) 3868 END IF 3869 IF ((h8b .lt. h4b)) THEN 3870 if(.not.intorb) then 3871 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 3872 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 3873 &+nvab) * (h8b_2 - 1))))) 3874 else 3875 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3876 &(p6b_2 3877 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 3878 &+nvab) * (h8b_2 - 1)))),p6b_2,p5b_2,h4b_2,h8b_2) 3879 end if 3880 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 3881 &,int_mb(k_range+h4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 3882 &,1,2,4,3,-1.0d0) 3883 END IF 3884 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_3',6,MA_ERR) 3885 nsuperp(1) = 1 3886 nsuperp(2) = 1 3887 isuperp = 1 3888 IF (p5b .eq. p6b) THEN 3889 nsuperp(isuperp) = nsuperp(isuperp) + 1 3890 ELSE 3891 isuperp = isuperp + 1 3892 END IF 3893 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 3894 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 3895 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 3896 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_3',7,MA_ER 3897 &R) 3898 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_3',8,MA_ER 3899 &R) 3900 END IF 3901 END IF 3902 END IF 3903 END DO 3904 END DO 3905 END DO 3906 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3907 &cc2_x1_7_3',9,MA_ERR) 3908 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1) 3909 &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0) 3910 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 3911 & 1 + noab * (h8b - 1))) 3912 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_3',10,MA_ERR) 3913 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_3',11,MA_E 3914 &RR) 3915 END IF 3916 END IF 3917 END IF 3918 next = NXTASK(nprocs,1) 3919 END IF 3920 count = count + 1 3921 END DO 3922 END DO 3923 next = NXTASK(-nprocs,1) 3924 call GA_SYNC() 3925 RETURN 3926 END 3927 SUBROUTINE cc2_x1_7_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 3928 &) 3929C $Id$ 3930C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3931C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3932C i1 ( h8 h1 )_vxt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * i2 ( h8 p3 )_vx 3933 IMPLICIT NONE 3934#include "global.fh" 3935#include "mafdecls.fh" 3936#include "sym.fh" 3937#include "errquit.fh" 3938#include "tce.fh" 3939 INTEGER d_a 3940 INTEGER k_a_offset 3941 INTEGER d_b 3942 INTEGER k_b_offset 3943 INTEGER d_c 3944 INTEGER k_c_offset 3945 INTEGER NXTASK 3946 INTEGER next 3947 INTEGER nprocs 3948 INTEGER count 3949 INTEGER h8b 3950 INTEGER h1b 3951 INTEGER dimc 3952 INTEGER l_c_sort 3953 INTEGER k_c_sort 3954 INTEGER p3b 3955 INTEGER p3b_1 3956 INTEGER h1b_1 3957 INTEGER h8b_2 3958 INTEGER p3b_2 3959 INTEGER dim_common 3960 INTEGER dima_sort 3961 INTEGER dima 3962 INTEGER dimb_sort 3963 INTEGER dimb 3964 INTEGER l_a_sort 3965 INTEGER k_a_sort 3966 INTEGER l_a 3967 INTEGER k_a 3968 INTEGER l_b_sort 3969 INTEGER k_b_sort 3970 INTEGER l_b 3971 INTEGER k_b 3972 INTEGER l_c 3973 INTEGER k_c 3974 EXTERNAL NXTASK 3975 nprocs = GA_NNODES() 3976 count = 0 3977 next = NXTASK(nprocs,1) 3978 DO h8b = 1,noab 3979 DO h1b = 1,noab 3980 IF (next.eq.count) THEN 3981 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 3982 &).ne.4)) THEN 3983 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3984 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 3985 &v,ieor(irrep_x,irrep_t))) THEN 3986 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 3987 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3988 & ERRQUIT('cc2_x1_7_4',0,MA_ERR) 3989 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3990 DO p3b = noab+1,noab+nvab 3991 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3992 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 3993 &EN 3994 CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1) 3995 CALL TCE_RESTRICTED_2(h8b,p3b,h8b_2,p3b_2) 3996 dim_common = int_mb(k_range+p3b-1) 3997 dima_sort = int_mb(k_range+h1b-1) 3998 dima = dim_common * dima_sort 3999 dimb_sort = int_mb(k_range+h8b-1) 4000 dimb = dim_common * dimb_sort 4001 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4002 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4003 & ERRQUIT('cc2_x1_7_4',1,MA_ERR) 4004 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4005 &cc2_x1_7_4',2,MA_ERR) 4006 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 4007 &int_mb(k_a_offset),(h1b_1 4008 & - 1 + noab * (p3b_1 - noab - 1))) 4009 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4010 &,int_mb(k_range+h1b-1),2,1,1.0d0) 4011 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_4',3,MA_ERR) 4012 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4013 & ERRQUIT('cc2_x1_7_4',4,MA_ERR) 4014 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4015 &cc2_x1_7_4',5,MA_ERR) 4016 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4017 & - noab - 1 + nvab * (h8b_2 - 1))) 4018 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 4019 &,int_mb(k_range+p3b-1),1,2,1.0d0) 4020 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_4',6,MA_ERR) 4021 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4022 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4023 &t),dima_sort) 4024 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_4',7,MA_ER 4025 &R) 4026 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_4',8,MA_ER 4027 &R) 4028 END IF 4029 END IF 4030 END IF 4031 END DO 4032 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4033 &cc2_x1_7_4',9,MA_ERR) 4034 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1) 4035 &,int_mb(k_range+h1b-1),1,2,1.0d0) 4036 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 4037 & 1 + noab * (h8b - 1))) 4038 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_4',10,MA_ERR) 4039 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_4',11,MA_E 4040 &RR) 4041 END IF 4042 END IF 4043 END IF 4044 next = NXTASK(nprocs,1) 4045 END IF 4046 count = count + 1 4047 END DO 4048 END DO 4049 next = NXTASK(-nprocs,1) 4050 call GA_SYNC() 4051 RETURN 4052 END 4053 SUBROUTINE cc2_x1_7_4_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offs 4054 &et) 4055C $Id$ 4056C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4057C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4058C i2 ( h8 p3 )_vx + = -1 * Sum ( h5 p6 ) * x ( p6 h5 )_x * v ( h5 h8 p3 p6 )_v 4059 IMPLICIT NONE 4060#include "global.fh" 4061#include "mafdecls.fh" 4062#include "sym.fh" 4063#include "errquit.fh" 4064#include "tce.fh" 4065 INTEGER d_a 4066 INTEGER k_a_offset 4067 INTEGER d_b 4068 INTEGER k_b_offset 4069 INTEGER d_c 4070 INTEGER k_c_offset 4071 INTEGER NXTASK 4072 INTEGER next 4073 INTEGER nprocs 4074 INTEGER count 4075 INTEGER h8b 4076 INTEGER p3b 4077 INTEGER dimc 4078 INTEGER l_c_sort 4079 INTEGER k_c_sort 4080 INTEGER p6b 4081 INTEGER h5b 4082 INTEGER p6b_1 4083 INTEGER h5b_1 4084 INTEGER h8b_2 4085 INTEGER h5b_2 4086 INTEGER p3b_2 4087 INTEGER p6b_2 4088 INTEGER dim_common 4089 INTEGER dima_sort 4090 INTEGER dima 4091 INTEGER dimb_sort 4092 INTEGER dimb 4093 INTEGER l_a_sort 4094 INTEGER k_a_sort 4095 INTEGER l_a 4096 INTEGER k_a 4097 INTEGER l_b_sort 4098 INTEGER k_b_sort 4099 INTEGER l_b 4100 INTEGER k_b 4101 INTEGER l_c 4102 INTEGER k_c 4103 EXTERNAL NXTASK 4104 nprocs = GA_NNODES() 4105 count = 0 4106 next = NXTASK(nprocs,1) 4107 DO h8b = 1,noab 4108 DO p3b = noab+1,noab+nvab 4109 IF (next.eq.count) THEN 4110 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1 4111 &).ne.4)) THEN 4112 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4113 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4114 &v,irrep_x)) THEN 4115 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1) 4116 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4117 & ERRQUIT('cc2_x1_7_4_1',0,MA_ERR) 4118 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4119 DO p6b = noab+1,noab+nvab 4120 DO h5b = 1,noab 4121 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h5b-1)) THEN 4122 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h5b-1)) .eq. irrep_x) TH 4123 &EN 4124 CALL TCE_RESTRICTED_2(p6b,h5b,p6b_1,h5b_1) 4125 CALL TCE_RESTRICTED_4(h8b,h5b,p3b,p6b,h8b_2,h5b_2,p3b_2,p6b_2) 4126 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h5b-1) 4127 dima_sort = 1 4128 dima = dim_common * dima_sort 4129 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1) 4130 dimb = dim_common * dimb_sort 4131 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4132 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4133 & ERRQUIT('cc2_x1_7_4_1',1,MA_ERR) 4134 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4135 &cc2_x1_7_4_1',2,MA_ERR) 4136 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 4137 &int_mb(k_a_offset),(h5b_1 4138 & - 1 + noab * (p6b_1 - noab - 1))) 4139 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 4140 &,int_mb(k_range+h5b-1),2,1,1.0d0) 4141 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_4_1',3,MA_ERR) 4142 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4143 & ERRQUIT('cc2_x1_7_4_1',4,MA_ERR) 4144 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4145 &cc2_x1_7_4_1',5,MA_ERR) 4146 IF ((h5b .le. h8b) .and. (p6b .lt. p3b)) THEN 4147 if(.not.intorb) then 4148 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4149 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 4150 &+nvab) * (h5b_2 - 1))))) 4151 else 4152 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4153 &(p3b_2 4154 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 4155 &+nvab) * (h5b_2 - 1)))),p3b_2,p6b_2,h8b_2,h5b_2) 4156 end if 4157 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 4158 &,int_mb(k_range+h8b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1) 4159 &,4,2,1,3,-1.0d0) 4160 END IF 4161 IF ((h5b .le. h8b) .and. (p3b .le. p6b)) THEN 4162 if(.not.intorb) then 4163 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 4164 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 4165 &+nvab) * (h5b_2 - 1))))) 4166 else 4167 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4168 &(p6b_2 4169 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 4170 &+nvab) * (h5b_2 - 1)))),p6b_2,p3b_2,h8b_2,h5b_2) 4171 end if 4172 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 4173 &,int_mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1) 4174 &,3,2,1,4,1.0d0) 4175 END IF 4176 IF ((h8b .lt. h5b) .and. (p6b .lt. p3b)) THEN 4177 if(.not.intorb) then 4178 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4179 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 4180 &+nvab) * (h8b_2 - 1))))) 4181 else 4182 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4183 &(p3b_2 4184 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 4185 &+nvab) * (h8b_2 - 1)))),p3b_2,p6b_2,h5b_2,h8b_2) 4186 end if 4187 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 4188 &,int_mb(k_range+h5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1) 4189 &,4,1,2,3,1.0d0) 4190 END IF 4191 IF ((h8b .lt. h5b) .and. (p3b .le. p6b)) THEN 4192 if(.not.intorb) then 4193 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 4194 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 4195 &+nvab) * (h8b_2 - 1))))) 4196 else 4197 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4198 &(p6b_2 4199 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 4200 &+nvab) * (h8b_2 - 1)))),p6b_2,p3b_2,h5b_2,h8b_2) 4201 end if 4202 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 4203 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1) 4204 &,3,1,2,4,-1.0d0) 4205 END IF 4206 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_4_1',6,MA_ERR) 4207 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4208 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4209 &t),dima_sort) 4210 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_4_1',7,MA_ 4211 &ERR) 4212 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_4_1',8,MA_ 4213 &ERR) 4214 END IF 4215 END IF 4216 END IF 4217 END DO 4218 END DO 4219 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4220 &cc2_x1_7_4_1',9,MA_ERR) 4221 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 4222 &,int_mb(k_range+h8b-1),2,1,-1.0d0) 4223 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 4224 & noab - 1 + nvab * (h8b - 1))) 4225 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_4_1',10,MA_ERR) 4226 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_4_1',11,MA 4227 &_ERR) 4228 END IF 4229 END IF 4230 END IF 4231 next = NXTASK(nprocs,1) 4232 END IF 4233 count = count + 1 4234 END DO 4235 END DO 4236 next = NXTASK(-nprocs,1) 4237 call GA_SYNC() 4238 RETURN 4239 END 4240 SUBROUTINE OFFSET_cc2_x1_7_4_1(l_a_offset,k_a_offset,size) 4241C $Id$ 4242C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4243C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4244C i2 ( h8 p3 )_vx 4245 IMPLICIT NONE 4246#include "global.fh" 4247#include "mafdecls.fh" 4248#include "sym.fh" 4249#include "errquit.fh" 4250#include "tce.fh" 4251 INTEGER l_a_offset 4252 INTEGER k_a_offset 4253 INTEGER size 4254 INTEGER length 4255 INTEGER addr 4256 INTEGER h8b 4257 INTEGER p3b 4258 length = 0 4259 DO h8b = 1,noab 4260 DO p3b = noab+1,noab+nvab 4261 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4262 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4263 &v,irrep_x)) THEN 4264 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1 4265 &).ne.4)) THEN 4266 length = length + 1 4267 END IF 4268 END IF 4269 END IF 4270 END DO 4271 END DO 4272 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 4273 &set)) CALL ERRQUIT('cc2_x1_7_4_1',0,MA_ERR) 4274 int_mb(k_a_offset) = length 4275 addr = 0 4276 size = 0 4277 DO h8b = 1,noab 4278 DO p3b = noab+1,noab+nvab 4279 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4280 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4281 &v,irrep_x)) THEN 4282 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1 4283 &).ne.4)) THEN 4284 addr = addr + 1 4285 int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h8b - 1) 4286 int_mb(k_a_offset+length+addr) = size 4287 size = size + int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1) 4288 END IF 4289 END IF 4290 END IF 4291 END DO 4292 END DO 4293 RETURN 4294 END 4295 SUBROUTINE cc2_x1_8(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 4296C $Id$ 4297C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4298C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4299C i0 ( p2 h1 )_vxt + = -1 * Sum ( p3 ) * t ( p3 h1 )_t * i1 ( p2 p3 )_vx 4300 IMPLICIT NONE 4301#include "global.fh" 4302#include "mafdecls.fh" 4303#include "sym.fh" 4304#include "errquit.fh" 4305#include "tce.fh" 4306 INTEGER d_a 4307 INTEGER k_a_offset 4308 INTEGER d_b 4309 INTEGER k_b_offset 4310 INTEGER d_c 4311 INTEGER k_c_offset 4312 INTEGER NXTASK 4313 INTEGER next 4314 INTEGER nprocs 4315 INTEGER count 4316 INTEGER p2b 4317 INTEGER h1b 4318 INTEGER dimc 4319 INTEGER l_c_sort 4320 INTEGER k_c_sort 4321 INTEGER p3b 4322 INTEGER p3b_1 4323 INTEGER h1b_1 4324 INTEGER p2b_2 4325 INTEGER p3b_2 4326 INTEGER dim_common 4327 INTEGER dima_sort 4328 INTEGER dima 4329 INTEGER dimb_sort 4330 INTEGER dimb 4331 INTEGER l_a_sort 4332 INTEGER k_a_sort 4333 INTEGER l_a 4334 INTEGER k_a 4335 INTEGER l_b_sort 4336 INTEGER k_b_sort 4337 INTEGER l_b 4338 INTEGER k_b 4339 INTEGER l_c 4340 INTEGER k_c 4341 EXTERNAL NXTASK 4342 nprocs = GA_NNODES() 4343 count = 0 4344 next = NXTASK(nprocs,1) 4345 DO p2b = noab+1,noab+nvab 4346 DO h1b = 1,noab 4347 IF (next.eq.count) THEN 4348 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 4349 &).ne.4)) THEN 4350 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4351 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 4352 &v,ieor(irrep_x,irrep_t))) THEN 4353 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 4354 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4355 & ERRQUIT('cc2_x1_8',0,MA_ERR) 4356 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4357 DO p3b = noab+1,noab+nvab 4358 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4359 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 4360 &EN 4361 CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1) 4362 CALL TCE_RESTRICTED_2(p2b,p3b,p2b_2,p3b_2) 4363 dim_common = int_mb(k_range+p3b-1) 4364 dima_sort = int_mb(k_range+h1b-1) 4365 dima = dim_common * dima_sort 4366 dimb_sort = int_mb(k_range+p2b-1) 4367 dimb = dim_common * dimb_sort 4368 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4369 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4370 & ERRQUIT('cc2_x1_8',1,MA_ERR) 4371 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4372 &cc2_x1_8',2,MA_ERR) 4373 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 4374 &int_mb(k_a_offset),(h1b_1 4375 & - 1 + noab * (p3b_1 - noab - 1))) 4376 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4377 &,int_mb(k_range+h1b-1),2,1,1.0d0) 4378 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_8',3,MA_ERR) 4379 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4380 & ERRQUIT('cc2_x1_8',4,MA_ERR) 4381 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4382 &cc2_x1_8',5,MA_ERR) 4383 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4384 & - noab - 1 + nvab * (p2b_2 - noab - 1))) 4385 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1) 4386 &,int_mb(k_range+p3b-1),1,2,1.0d0) 4387 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_8',6,MA_ERR) 4388 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4389 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4390 &t),dima_sort) 4391 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_8',7,MA_ERR) 4392 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_8',8,MA_ERR) 4393 END IF 4394 END IF 4395 END IF 4396 END DO 4397 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4398 &cc2_x1_8',9,MA_ERR) 4399 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1) 4400 &,int_mb(k_range+h1b-1),1,2,-1.0d0) 4401 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 4402 & 1 + noab * (p2b - noab - 1))) 4403 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_8',10,MA_ERR) 4404 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_8',11,MA_ERR 4405 &) 4406 END IF 4407 END IF 4408 END IF 4409 next = NXTASK(nprocs,1) 4410 END IF 4411 count = count + 1 4412 END DO 4413 END DO 4414 next = NXTASK(-nprocs,1) 4415 call GA_SYNC() 4416 RETURN 4417 END 4418 SUBROUTINE cc2_x1_8_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 4419 &) 4420C $Id$ 4421C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4422C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4423C i1 ( p2 p3 )_vx + = 1 * Sum ( h4 p5 ) * x ( p5 h4 )_x * v ( h4 p2 p3 p5 )_v 4424 IMPLICIT NONE 4425#include "global.fh" 4426#include "mafdecls.fh" 4427#include "sym.fh" 4428#include "errquit.fh" 4429#include "tce.fh" 4430 INTEGER d_a 4431 INTEGER k_a_offset 4432 INTEGER d_b 4433 INTEGER k_b_offset 4434 INTEGER d_c 4435 INTEGER k_c_offset 4436 INTEGER NXTASK 4437 INTEGER next 4438 INTEGER nprocs 4439 INTEGER count 4440 INTEGER p2b 4441 INTEGER p3b 4442 INTEGER dimc 4443 INTEGER l_c_sort 4444 INTEGER k_c_sort 4445 INTEGER p5b 4446 INTEGER h4b 4447 INTEGER p5b_1 4448 INTEGER h4b_1 4449 INTEGER p2b_2 4450 INTEGER h4b_2 4451 INTEGER p3b_2 4452 INTEGER p5b_2 4453 INTEGER dim_common 4454 INTEGER dima_sort 4455 INTEGER dima 4456 INTEGER dimb_sort 4457 INTEGER dimb 4458 INTEGER l_a_sort 4459 INTEGER k_a_sort 4460 INTEGER l_a 4461 INTEGER k_a 4462 INTEGER l_b_sort 4463 INTEGER k_b_sort 4464 INTEGER l_b 4465 INTEGER k_b 4466 INTEGER l_c 4467 INTEGER k_c 4468 EXTERNAL NXTASK 4469 nprocs = GA_NNODES() 4470 count = 0 4471 next = NXTASK(nprocs,1) 4472 DO p2b = noab+1,noab+nvab 4473 DO p3b = noab+1,noab+nvab 4474 IF (next.eq.count) THEN 4475 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1 4476 &).ne.4)) THEN 4477 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4478 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4479 &v,irrep_x)) THEN 4480 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1) 4481 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4482 & ERRQUIT('cc2_x1_8_1',0,MA_ERR) 4483 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4484 DO p5b = noab+1,noab+nvab 4485 DO h4b = 1,noab 4486 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h4b-1)) THEN 4487 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h4b-1)) .eq. irrep_x) TH 4488 &EN 4489 CALL TCE_RESTRICTED_2(p5b,h4b,p5b_1,h4b_1) 4490 CALL TCE_RESTRICTED_4(p2b,h4b,p3b,p5b,p2b_2,h4b_2,p3b_2,p5b_2) 4491 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h4b-1) 4492 dima_sort = 1 4493 dima = dim_common * dima_sort 4494 dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1) 4495 dimb = dim_common * dimb_sort 4496 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4497 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4498 & ERRQUIT('cc2_x1_8_1',1,MA_ERR) 4499 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4500 &cc2_x1_8_1',2,MA_ERR) 4501 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 4502 &int_mb(k_a_offset),(h4b_1 4503 & - 1 + noab * (p5b_1 - noab - 1))) 4504 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 4505 &,int_mb(k_range+h4b-1),2,1,1.0d0) 4506 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_8_1',3,MA_ERR) 4507 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4508 & ERRQUIT('cc2_x1_8_1',4,MA_ERR) 4509 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4510 &cc2_x1_8_1',5,MA_ERR) 4511 IF ((h4b .le. p2b) .and. (p5b .lt. p3b)) THEN 4512 if(.not.intorb) then 4513 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4514 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 4515 &+nvab) * (h4b_2 - 1))))) 4516 else 4517 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4518 &(p3b_2 4519 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 4520 &+nvab) * (h4b_2 - 1)))),p3b_2,p5b_2,p2b_2,h4b_2) 4521 end if 4522 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 4523 &,int_mb(k_range+p2b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1) 4524 &,4,2,1,3,-1.0d0) 4525 END IF 4526 IF ((h4b .le. p2b) .and. (p3b .le. p5b)) THEN 4527 if(.not.intorb) then 4528 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 4529 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 4530 &+nvab) * (h4b_2 - 1))))) 4531 else 4532 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4533 &(p5b_2 4534 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 4535 &+nvab) * (h4b_2 - 1)))),p5b_2,p3b_2,p2b_2,h4b_2) 4536 end if 4537 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 4538 &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1) 4539 &,3,2,1,4,1.0d0) 4540 END IF 4541 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_8_1',6,MA_ERR) 4542 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4543 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4544 &t),dima_sort) 4545 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_8_1',7,MA_ER 4546 &R) 4547 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_8_1',8,MA_ER 4548 &R) 4549 END IF 4550 END IF 4551 END IF 4552 END DO 4553 END DO 4554 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4555 &cc2_x1_8_1',9,MA_ERR) 4556 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 4557 &,int_mb(k_range+p2b-1),2,1,1.0d0) 4558 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 4559 & noab - 1 + nvab * (p2b - noab - 1))) 4560 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_8_1',10,MA_ERR) 4561 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_8_1',11,MA_E 4562 &RR) 4563 END IF 4564 END IF 4565 END IF 4566 next = NXTASK(nprocs,1) 4567 END IF 4568 count = count + 1 4569 END DO 4570 END DO 4571 next = NXTASK(-nprocs,1) 4572 call GA_SYNC() 4573 RETURN 4574 END 4575 SUBROUTINE OFFSET_cc2_x1_8_1(l_a_offset,k_a_offset,size) 4576C $Id$ 4577C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4578C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4579C i1 ( p2 p3 )_vx 4580 IMPLICIT NONE 4581#include "global.fh" 4582#include "mafdecls.fh" 4583#include "sym.fh" 4584#include "errquit.fh" 4585#include "tce.fh" 4586 INTEGER l_a_offset 4587 INTEGER k_a_offset 4588 INTEGER size 4589 INTEGER length 4590 INTEGER addr 4591 INTEGER p2b 4592 INTEGER p3b 4593 length = 0 4594 DO p2b = noab+1,noab+nvab 4595 DO p3b = noab+1,noab+nvab 4596 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4597 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4598 &v,irrep_x)) THEN 4599 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1 4600 &).ne.4)) THEN 4601 length = length + 1 4602 END IF 4603 END IF 4604 END IF 4605 END DO 4606 END DO 4607 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 4608 &set)) CALL ERRQUIT('cc2_x1_8_1',0,MA_ERR) 4609 int_mb(k_a_offset) = length 4610 addr = 0 4611 size = 0 4612 DO p2b = noab+1,noab+nvab 4613 DO p3b = noab+1,noab+nvab 4614 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4615 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4616 &v,irrep_x)) THEN 4617 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1 4618 &).ne.4)) THEN 4619 addr = addr + 1 4620 int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (p2b - noab - 1) 4621 int_mb(k_a_offset+length+addr) = size 4622 size = size + int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1) 4623 END IF 4624 END IF 4625 END IF 4626 END DO 4627 END DO 4628 RETURN 4629 END 4630 SUBROUTINE cc2_x1_9(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 4631C $Id$ 4632C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4633C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4634C i0 ( p2 h1 )_vxt + = 1 * Sum ( h4 p3 ) * t ( p2 p3 h1 h4 )_t * i1 ( h4 p3 )_vx 4635 IMPLICIT NONE 4636#include "global.fh" 4637#include "mafdecls.fh" 4638#include "sym.fh" 4639#include "errquit.fh" 4640#include "tce.fh" 4641 INTEGER d_a 4642 INTEGER k_a_offset 4643 INTEGER d_b 4644 INTEGER k_b_offset 4645 INTEGER d_c 4646 INTEGER k_c_offset 4647 INTEGER NXTASK 4648 INTEGER next 4649 INTEGER nprocs 4650 INTEGER count 4651 INTEGER p2b 4652 INTEGER h1b 4653 INTEGER dimc 4654 INTEGER l_c_sort 4655 INTEGER k_c_sort 4656 INTEGER p3b 4657 INTEGER h4b 4658 INTEGER p2b_1 4659 INTEGER p3b_1 4660 INTEGER h1b_1 4661 INTEGER h4b_1 4662 INTEGER h4b_2 4663 INTEGER p3b_2 4664 INTEGER dim_common 4665 INTEGER dima_sort 4666 INTEGER dima 4667 INTEGER dimb_sort 4668 INTEGER dimb 4669 INTEGER l_a_sort 4670 INTEGER k_a_sort 4671 INTEGER l_a 4672 INTEGER k_a 4673 INTEGER l_b_sort 4674 INTEGER k_b_sort 4675 INTEGER l_b 4676 INTEGER k_b 4677 INTEGER l_c 4678 INTEGER k_c 4679 EXTERNAL NXTASK 4680 nprocs = GA_NNODES() 4681 count = 0 4682 next = NXTASK(nprocs,1) 4683 DO p2b = noab+1,noab+nvab 4684 DO h1b = 1,noab 4685 IF (next.eq.count) THEN 4686 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 4687 &).ne.4)) THEN 4688 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4689 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 4690 &v,ieor(irrep_x,irrep_t))) THEN 4691 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 4692 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4693 & ERRQUIT('cc2_x1_9',0,MA_ERR) 4694 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4695 DO p3b = noab+1,noab+nvab 4696 DO h4b = 1,noab 4697 IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 4698 &1b-1)+int_mb(k_spin+h4b-1)) THEN 4699 IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 4700 &k_sym+h1b-1),int_mb(k_sym+h4b-1)))) .eq. irrep_t) THEN 4701 CALL TCE_RESTRICTED_4(p2b,p3b,h1b,h4b,p2b_1,p3b_1,h1b_1,h4b_1) 4702 CALL TCE_RESTRICTED_2(h4b,p3b,h4b_2,p3b_2) 4703 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) 4704 dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 4705 dima = dim_common * dima_sort 4706 dimb_sort = 1 4707 dimb = dim_common * dimb_sort 4708 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4709 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4710 & ERRQUIT('cc2_x1_9',1,MA_ERR) 4711 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4712 &cc2_x1_9',2,MA_ERR) 4713 IF ((p3b .lt. p2b) .and. (h4b .lt. h1b)) THEN 4714 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 4715 & - 1 + noab * (h4b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p3b_ 4716 &1 - noab - 1))))) 4717 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4718 &,int_mb(k_range+p2b-1),int_mb(k_range+h4b-1),int_mb(k_range+h1b-1) 4719 &,4,2,3,1,1.0d0) 4720 END IF 4721 IF ((p3b .lt. p2b) .and. (h1b .le. h4b)) THEN 4722 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 4723 & - 1 + noab * (h1b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p3b_ 4724 &1 - noab - 1))))) 4725 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4726 &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+h4b-1) 4727 &,3,2,4,1,-1.0d0) 4728 END IF 4729 IF ((p2b .le. p3b) .and. (h4b .lt. h1b)) THEN 4730 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 4731 & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p2b_ 4732 &1 - noab - 1))))) 4733 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 4734 &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h1b-1) 4735 &,4,1,3,2,-1.0d0) 4736 END IF 4737 IF ((p2b .le. p3b) .and. (h1b .le. h4b)) THEN 4738 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 4739 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p2b_ 4740 &1 - noab - 1))))) 4741 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 4742 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h4b-1) 4743 &,3,1,4,2,1.0d0) 4744 END IF 4745 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_9',3,MA_ERR) 4746 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4747 & ERRQUIT('cc2_x1_9',4,MA_ERR) 4748 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4749 &cc2_x1_9',5,MA_ERR) 4750 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4751 & - noab - 1 + nvab * (h4b_2 - 1))) 4752 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 4753 &,int_mb(k_range+p3b-1),1,2,1.0d0) 4754 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_9',6,MA_ERR) 4755 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4756 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4757 &t),dima_sort) 4758 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_9',7,MA_ERR) 4759 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_9',8,MA_ERR) 4760 END IF 4761 END IF 4762 END IF 4763 END DO 4764 END DO 4765 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4766 &cc2_x1_9',9,MA_ERR) 4767 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 4768 &,int_mb(k_range+p2b-1),2,1,1.0d0) 4769 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 4770 & 1 + noab * (p2b - noab - 1))) 4771 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_9',10,MA_ERR) 4772 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_9',11,MA_ERR 4773 &) 4774 END IF 4775 END IF 4776 END IF 4777 next = NXTASK(nprocs,1) 4778 END IF 4779 count = count + 1 4780 END DO 4781 END DO 4782 next = NXTASK(-nprocs,1) 4783 call GA_SYNC() 4784 RETURN 4785 END 4786 SUBROUTINE cc2_x1_9_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset 4787 &) 4788C $Id$ 4789C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4790C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4791C i1 ( h4 p3 )_vx + = 1 * Sum ( h5 p6 ) * x ( p6 h5 )_x * v ( h4 h5 p3 p6 )_v 4792 IMPLICIT NONE 4793#include "global.fh" 4794#include "mafdecls.fh" 4795#include "sym.fh" 4796#include "errquit.fh" 4797#include "tce.fh" 4798 INTEGER d_a 4799 INTEGER k_a_offset 4800 INTEGER d_b 4801 INTEGER k_b_offset 4802 INTEGER d_c 4803 INTEGER k_c_offset 4804 INTEGER NXTASK 4805 INTEGER next 4806 INTEGER nprocs 4807 INTEGER count 4808 INTEGER h4b 4809 INTEGER p3b 4810 INTEGER dimc 4811 INTEGER l_c_sort 4812 INTEGER k_c_sort 4813 INTEGER p6b 4814 INTEGER h5b 4815 INTEGER p6b_1 4816 INTEGER h5b_1 4817 INTEGER h4b_2 4818 INTEGER h5b_2 4819 INTEGER p3b_2 4820 INTEGER p6b_2 4821 INTEGER dim_common 4822 INTEGER dima_sort 4823 INTEGER dima 4824 INTEGER dimb_sort 4825 INTEGER dimb 4826 INTEGER l_a_sort 4827 INTEGER k_a_sort 4828 INTEGER l_a 4829 INTEGER k_a 4830 INTEGER l_b_sort 4831 INTEGER k_b_sort 4832 INTEGER l_b 4833 INTEGER k_b 4834 INTEGER l_c 4835 INTEGER k_c 4836 EXTERNAL NXTASK 4837 nprocs = GA_NNODES() 4838 count = 0 4839 next = NXTASK(nprocs,1) 4840 DO h4b = 1,noab 4841 DO p3b = noab+1,noab+nvab 4842 IF (next.eq.count) THEN 4843 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1 4844 &).ne.4)) THEN 4845 IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4846 IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4847 &v,irrep_x)) THEN 4848 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1) 4849 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4850 & ERRQUIT('cc2_x1_9_1',0,MA_ERR) 4851 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4852 DO p6b = noab+1,noab+nvab 4853 DO h5b = 1,noab 4854 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h5b-1)) THEN 4855 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h5b-1)) .eq. irrep_x) TH 4856 &EN 4857 CALL TCE_RESTRICTED_2(p6b,h5b,p6b_1,h5b_1) 4858 CALL TCE_RESTRICTED_4(h4b,h5b,p3b,p6b,h4b_2,h5b_2,p3b_2,p6b_2) 4859 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h5b-1) 4860 dima_sort = 1 4861 dima = dim_common * dima_sort 4862 dimb_sort = int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1) 4863 dimb = dim_common * dimb_sort 4864 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4865 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4866 & ERRQUIT('cc2_x1_9_1',1,MA_ERR) 4867 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4868 &cc2_x1_9_1',2,MA_ERR) 4869 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 4870 &int_mb(k_a_offset),(h5b_1 4871 & - 1 + noab * (p6b_1 - noab - 1))) 4872 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 4873 &,int_mb(k_range+h5b-1),2,1,1.0d0) 4874 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_9_1',3,MA_ERR) 4875 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4876 & ERRQUIT('cc2_x1_9_1',4,MA_ERR) 4877 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4878 &cc2_x1_9_1',5,MA_ERR) 4879 IF ((h5b .lt. h4b) .and. (p6b .lt. p3b)) THEN 4880 if(.not.intorb) then 4881 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4882 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 4883 &+nvab) * (h5b_2 - 1))))) 4884 else 4885 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4886 &(p3b_2 4887 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 4888 &+nvab) * (h5b_2 - 1)))),p3b_2,p6b_2,h4b_2,h5b_2) 4889 end if 4890 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 4891 &,int_mb(k_range+h4b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1) 4892 &,4,2,1,3,1.0d0) 4893 END IF 4894 IF ((h5b .lt. h4b) .and. (p3b .le. p6b)) THEN 4895 if(.not.intorb) then 4896 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 4897 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 4898 &+nvab) * (h5b_2 - 1))))) 4899 else 4900 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4901 &(p6b_2 4902 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 4903 &+nvab) * (h5b_2 - 1)))),p6b_2,p3b_2,h4b_2,h5b_2) 4904 end if 4905 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 4906 &,int_mb(k_range+h4b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1) 4907 &,3,2,1,4,-1.0d0) 4908 END IF 4909 IF ((h4b .le. h5b) .and. (p6b .lt. p3b)) THEN 4910 if(.not.intorb) then 4911 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4912 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 4913 &+nvab) * (h4b_2 - 1))))) 4914 else 4915 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4916 &(p3b_2 4917 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 4918 &+nvab) * (h4b_2 - 1)))),p3b_2,p6b_2,h5b_2,h4b_2) 4919 end if 4920 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 4921 &,int_mb(k_range+h5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1) 4922 &,4,1,2,3,-1.0d0) 4923 END IF 4924 IF ((h4b .le. h5b) .and. (p3b .le. p6b)) THEN 4925 if(.not.intorb) then 4926 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 4927 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 4928 &+nvab) * (h4b_2 - 1))))) 4929 else 4930 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4931 &(p6b_2 4932 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 4933 &+nvab) * (h4b_2 - 1)))),p6b_2,p3b_2,h5b_2,h4b_2) 4934 end if 4935 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 4936 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1) 4937 &,3,1,2,4,1.0d0) 4938 END IF 4939 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_9_1',6,MA_ERR) 4940 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4941 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4942 &t),dima_sort) 4943 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_9_1',7,MA_ER 4944 &R) 4945 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_9_1',8,MA_ER 4946 &R) 4947 END IF 4948 END IF 4949 END IF 4950 END DO 4951 END DO 4952 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4953 &cc2_x1_9_1',9,MA_ERR) 4954 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 4955 &,int_mb(k_range+h4b-1),2,1,1.0d0) 4956 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 4957 & noab - 1 + nvab * (h4b - 1))) 4958 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_9_1',10,MA_ERR) 4959 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_9_1',11,MA_E 4960 &RR) 4961 END IF 4962 END IF 4963 END IF 4964 next = NXTASK(nprocs,1) 4965 END IF 4966 count = count + 1 4967 END DO 4968 END DO 4969 next = NXTASK(-nprocs,1) 4970 call GA_SYNC() 4971 RETURN 4972 END 4973 SUBROUTINE OFFSET_cc2_x1_9_1(l_a_offset,k_a_offset,size) 4974C $Id$ 4975C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4976C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4977C i1 ( h4 p3 )_vx 4978 IMPLICIT NONE 4979#include "global.fh" 4980#include "mafdecls.fh" 4981#include "sym.fh" 4982#include "errquit.fh" 4983#include "tce.fh" 4984 INTEGER l_a_offset 4985 INTEGER k_a_offset 4986 INTEGER size 4987 INTEGER length 4988 INTEGER addr 4989 INTEGER h4b 4990 INTEGER p3b 4991 length = 0 4992 DO h4b = 1,noab 4993 DO p3b = noab+1,noab+nvab 4994 IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4995 IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4996 &v,irrep_x)) THEN 4997 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1 4998 &).ne.4)) THEN 4999 length = length + 1 5000 END IF 5001 END IF 5002 END IF 5003 END DO 5004 END DO 5005 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 5006 &set)) CALL ERRQUIT('cc2_x1_9_1',0,MA_ERR) 5007 int_mb(k_a_offset) = length 5008 addr = 0 5009 size = 0 5010 DO h4b = 1,noab 5011 DO p3b = noab+1,noab+nvab 5012 IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p3b-1)) THEN 5013 IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 5014 &v,irrep_x)) THEN 5015 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1 5016 &).ne.4)) THEN 5017 addr = addr + 1 5018 int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h4b - 1) 5019 int_mb(k_a_offset+length+addr) = size 5020 size = size + int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1) 5021 END IF 5022 END IF 5023 END IF 5024 END DO 5025 END DO 5026 RETURN 5027 END 5028 SUBROUTINE cc2_x1_10(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 5029C $Id$ 5030C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5031C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5032C i0 ( p2 h1 )_vxt + = 1/2 * Sum ( h4 h5 p3 ) * t ( p2 p3 h4 h5 )_t * i1 ( h4 h5 h1 p3 )_vx 5033 IMPLICIT NONE 5034#include "global.fh" 5035#include "mafdecls.fh" 5036#include "sym.fh" 5037#include "errquit.fh" 5038#include "tce.fh" 5039 INTEGER d_a 5040 INTEGER k_a_offset 5041 INTEGER d_b 5042 INTEGER k_b_offset 5043 INTEGER d_c 5044 INTEGER k_c_offset 5045 INTEGER NXTASK 5046 INTEGER next 5047 INTEGER nprocs 5048 INTEGER count 5049 INTEGER p2b 5050 INTEGER h1b 5051 INTEGER dimc 5052 INTEGER l_c_sort 5053 INTEGER k_c_sort 5054 INTEGER p3b 5055 INTEGER h4b 5056 INTEGER h5b 5057 INTEGER p2b_1 5058 INTEGER p3b_1 5059 INTEGER h4b_1 5060 INTEGER h5b_1 5061 INTEGER h4b_2 5062 INTEGER h5b_2 5063 INTEGER h1b_2 5064 INTEGER p3b_2 5065 INTEGER dim_common 5066 INTEGER dima_sort 5067 INTEGER dima 5068 INTEGER dimb_sort 5069 INTEGER dimb 5070 INTEGER l_a_sort 5071 INTEGER k_a_sort 5072 INTEGER l_a 5073 INTEGER k_a 5074 INTEGER l_b_sort 5075 INTEGER k_b_sort 5076 INTEGER l_b 5077 INTEGER k_b 5078 INTEGER nsubh(2) 5079 INTEGER isubh 5080 INTEGER l_c 5081 INTEGER k_c 5082 DOUBLE PRECISION FACTORIAL 5083 EXTERNAL NXTASK 5084 EXTERNAL FACTORIAL 5085 nprocs = GA_NNODES() 5086 count = 0 5087 next = NXTASK(nprocs,1) 5088 DO p2b = noab+1,noab+nvab 5089 DO h1b = 1,noab 5090 IF (next.eq.count) THEN 5091 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 5092 &).ne.4)) THEN 5093 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 5094 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 5095 &v,ieor(irrep_x,irrep_t))) THEN 5096 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 5097 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5098 & ERRQUIT('cc2_x1_10',0,MA_ERR) 5099 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5100 DO p3b = noab+1,noab+nvab 5101 DO h4b = 1,noab 5102 DO h5b = h4b,noab 5103 IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 5104 &4b-1)+int_mb(k_spin+h5b-1)) THEN 5105 IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 5106 &k_sym+h4b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN 5107 CALL TCE_RESTRICTED_4(p2b,p3b,h4b,h5b,p2b_1,p3b_1,h4b_1,h5b_1) 5108 CALL TCE_RESTRICTED_4(h4b,h5b,h1b,p3b,h4b_2,h5b_2,h1b_2,p3b_2) 5109 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) * int_m 5110 &b(k_range+h5b-1) 5111 dima_sort = int_mb(k_range+p2b-1) 5112 dima = dim_common * dima_sort 5113 dimb_sort = int_mb(k_range+h1b-1) 5114 dimb = dim_common * dimb_sort 5115 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5116 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5117 & ERRQUIT('cc2_x1_10',1,MA_ERR) 5118 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5119 &cc2_x1_10',2,MA_ERR) 5120 IF ((p3b .lt. p2b)) THEN 5121 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 5122 & - 1 + noab * (h4b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p3b_ 5123 &1 - noab - 1))))) 5124 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5125 &,int_mb(k_range+p2b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1) 5126 &,2,4,3,1,-1.0d0) 5127 END IF 5128 IF ((p2b .le. p3b)) THEN 5129 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 5130 & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p2b_ 5131 &1 - noab - 1))))) 5132 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 5133 &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1) 5134 &,1,4,3,2,1.0d0) 5135 END IF 5136 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_10',3,MA_ERR) 5137 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5138 & ERRQUIT('cc2_x1_10',4,MA_ERR) 5139 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5140 &cc2_x1_10',5,MA_ERR) 5141 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 5142 & - noab - 1 + nvab * (h1b_2 - 1 + noab * (h5b_2 - 1 + noab * (h4b_ 5143 &2 - 1))))) 5144 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 5145 &,int_mb(k_range+h5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 5146 &,3,2,1,4,1.0d0) 5147 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_10',6,MA_ERR) 5148 nsubh(1) = 1 5149 nsubh(2) = 1 5150 isubh = 1 5151 IF (h4b .eq. h5b) THEN 5152 nsubh(isubh) = nsubh(isubh) + 1 5153 ELSE 5154 isubh = isubh + 1 5155 END IF 5156 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 5157 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 5158 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 5159 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_10',7,MA_ERR 5160 &) 5161 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_10',8,MA_ERR 5162 &) 5163 END IF 5164 END IF 5165 END IF 5166 END DO 5167 END DO 5168 END DO 5169 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5170 &cc2_x1_10',9,MA_ERR) 5171 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 5172 &,int_mb(k_range+p2b-1),2,1,1.0d0/2.0d0) 5173 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 5174 & 1 + noab * (p2b - noab - 1))) 5175 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_10',10,MA_ERR) 5176 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_10',11,MA_ER 5177 &R) 5178 END IF 5179 END IF 5180 END IF 5181 next = NXTASK(nprocs,1) 5182 END IF 5183 count = count + 1 5184 END DO 5185 END DO 5186 next = NXTASK(-nprocs,1) 5187 call GA_SYNC() 5188 RETURN 5189 END 5190 SUBROUTINE cc2_x1_10_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 5191 &t) 5192C $Id$ 5193C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5194C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5195C i1 ( h4 h5 h1 p3 )_vx + = 1 * Sum ( p6 ) * x ( p6 h1 )_x * v ( h4 h5 p3 p6 )_v 5196 IMPLICIT NONE 5197#include "global.fh" 5198#include "mafdecls.fh" 5199#include "sym.fh" 5200#include "errquit.fh" 5201#include "tce.fh" 5202 INTEGER d_a 5203 INTEGER k_a_offset 5204 INTEGER d_b 5205 INTEGER k_b_offset 5206 INTEGER d_c 5207 INTEGER k_c_offset 5208 INTEGER NXTASK 5209 INTEGER next 5210 INTEGER nprocs 5211 INTEGER count 5212 INTEGER h4b 5213 INTEGER h5b 5214 INTEGER h1b 5215 INTEGER p3b 5216 INTEGER dimc 5217 INTEGER l_c_sort 5218 INTEGER k_c_sort 5219 INTEGER p6b 5220 INTEGER p6b_1 5221 INTEGER h1b_1 5222 INTEGER h4b_2 5223 INTEGER h5b_2 5224 INTEGER p3b_2 5225 INTEGER p6b_2 5226 INTEGER dim_common 5227 INTEGER dima_sort 5228 INTEGER dima 5229 INTEGER dimb_sort 5230 INTEGER dimb 5231 INTEGER l_a_sort 5232 INTEGER k_a_sort 5233 INTEGER l_a 5234 INTEGER k_a 5235 INTEGER l_b_sort 5236 INTEGER k_b_sort 5237 INTEGER l_b 5238 INTEGER k_b 5239 INTEGER l_c 5240 INTEGER k_c 5241 EXTERNAL NXTASK 5242 nprocs = GA_NNODES() 5243 count = 0 5244 next = NXTASK(nprocs,1) 5245 DO h4b = 1,noab 5246 DO h5b = h4b,noab 5247 DO h1b = 1,noab 5248 DO p3b = noab+1,noab+nvab 5249 IF (next.eq.count) THEN 5250 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 5251 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN 5252 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h 5253 &1b-1)+int_mb(k_spin+p3b-1)) THEN 5254 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 5255 &k_sym+h1b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 5256 &EN 5257 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra 5258 &nge+h1b-1) * int_mb(k_range+p3b-1) 5259 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5260 & ERRQUIT('cc2_x1_10_1',0,MA_ERR) 5261 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5262 DO p6b = noab+1,noab+nvab 5263 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 5264 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH 5265 &EN 5266 CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1) 5267 CALL TCE_RESTRICTED_4(h4b,h5b,p3b,p6b,h4b_2,h5b_2,p3b_2,p6b_2) 5268 dim_common = int_mb(k_range+p6b-1) 5269 dima_sort = int_mb(k_range+h1b-1) 5270 dima = dim_common * dima_sort 5271 dimb_sort = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb 5272 &(k_range+p3b-1) 5273 dimb = dim_common * dimb_sort 5274 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5275 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5276 & ERRQUIT('cc2_x1_10_1',1,MA_ERR) 5277 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5278 &cc2_x1_10_1',2,MA_ERR) 5279 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, 5280 &int_mb(k_a_offset),(h1b_1 5281 & - 1 + noab * (p6b_1 - noab - 1))) 5282 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 5283 &,int_mb(k_range+h1b-1),2,1,1.0d0) 5284 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_10_1',3,MA_ERR) 5285 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5286 & ERRQUIT('cc2_x1_10_1',4,MA_ERR) 5287 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5288 &cc2_x1_10_1',5,MA_ERR) 5289 IF ((p6b .lt. p3b)) THEN 5290 if(.not.intorb) then 5291 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 5292 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 5293 &+nvab) * (h4b_2 - 1))))) 5294 else 5295 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 5296 &(p3b_2 5297 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 5298 &+nvab) * (h4b_2 - 1)))),p3b_2,p6b_2,h5b_2,h4b_2) 5299 end if 5300 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 5301 &,int_mb(k_range+h5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1) 5302 &,4,2,1,3,-1.0d0) 5303 END IF 5304 IF ((p3b .le. p6b)) THEN 5305 if(.not.intorb) then 5306 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 5307 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 5308 &+nvab) * (h4b_2 - 1))))) 5309 else 5310 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 5311 &(p6b_2 5312 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 5313 &+nvab) * (h4b_2 - 1)))),p6b_2,p3b_2,h5b_2,h4b_2) 5314 end if 5315 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 5316 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1) 5317 &,3,2,1,4,1.0d0) 5318 END IF 5319 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_10_1',6,MA_ERR) 5320 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 5321 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 5322 &t),dima_sort) 5323 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_10_1',7,MA_E 5324 &RR) 5325 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_10_1',8,MA_E 5326 &RR) 5327 END IF 5328 END IF 5329 END IF 5330 END DO 5331 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5332 &cc2_x1_10_1',9,MA_ERR) 5333 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 5334 &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),int_mb(k_range+h1b-1) 5335 &,3,2,4,1,1.0d0) 5336 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 5337 & noab - 1 + nvab * (h1b - 1 + noab * (h5b - 1 + noab * (h4b - 1))) 5338 &)) 5339 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_10_1',10,MA_ERR) 5340 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_10_1',11,MA_ 5341 &ERR) 5342 END IF 5343 END IF 5344 END IF 5345 next = NXTASK(nprocs,1) 5346 END IF 5347 count = count + 1 5348 END DO 5349 END DO 5350 END DO 5351 END DO 5352 next = NXTASK(-nprocs,1) 5353 call GA_SYNC() 5354 RETURN 5355 END 5356 SUBROUTINE OFFSET_cc2_x1_10_1(l_a_offset,k_a_offset,size) 5357C $Id$ 5358C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5359C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5360C i1 ( h4 h5 h1 p3 )_vx 5361 IMPLICIT NONE 5362#include "global.fh" 5363#include "mafdecls.fh" 5364#include "sym.fh" 5365#include "errquit.fh" 5366#include "tce.fh" 5367 INTEGER l_a_offset 5368 INTEGER k_a_offset 5369 INTEGER size 5370 INTEGER length 5371 INTEGER addr 5372 INTEGER h4b 5373 INTEGER h5b 5374 INTEGER h1b 5375 INTEGER p3b 5376 length = 0 5377 DO h4b = 1,noab 5378 DO h5b = h4b,noab 5379 DO h1b = 1,noab 5380 DO p3b = noab+1,noab+nvab 5381 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h 5382 &1b-1)+int_mb(k_spin+p3b-1)) THEN 5383 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 5384 &k_sym+h1b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 5385 &EN 5386 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 5387 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN 5388 length = length + 1 5389 END IF 5390 END IF 5391 END IF 5392 END DO 5393 END DO 5394 END DO 5395 END DO 5396 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 5397 &set)) CALL ERRQUIT('cc2_x1_10_1',0,MA_ERR) 5398 int_mb(k_a_offset) = length 5399 addr = 0 5400 size = 0 5401 DO h4b = 1,noab 5402 DO h5b = h4b,noab 5403 DO h1b = 1,noab 5404 DO p3b = noab+1,noab+nvab 5405 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h 5406 &1b-1)+int_mb(k_spin+p3b-1)) THEN 5407 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 5408 &k_sym+h1b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 5409 &EN 5410 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 5411 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN 5412 addr = addr + 1 5413 int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h1b - 1 + noab 5414 &* (h5b - 1 + noab * (h4b - 1))) 5415 int_mb(k_a_offset+length+addr) = size 5416 size = size + int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_ 5417 &mb(k_range+h1b-1) * int_mb(k_range+p3b-1) 5418 END IF 5419 END IF 5420 END IF 5421 END DO 5422 END DO 5423 END DO 5424 END DO 5425 RETURN 5426 END 5427