1 SUBROUTINE ccsdt_t2a(d_f1,d_i0,d_t1,d_t2,d_t3,d_v2,k_f1_offset, 2 &k_i0_offset,k_t1_offset,k_t2_offset,k_t3_offset,k_v2_offset) 3C $Id$ 4C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6C i0 ( p3 p4 h1 h2 )_v + = 1 * v ( p3 p4 h1 h2 )_v 7C i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( h10 ) * t ( p3 h10 )_t * i1 ( h10 p4 h1 h2 )_v 8C i1 ( h10 p3 h1 h2 )_v + = 1 * v ( h10 p3 h1 h2 )_v 9C i1 ( h10 p3 h1 h2 )_vt + = 1/2 * Sum ( h11 ) * t ( p3 h11 )_t * i2 ( h10 h11 h1 h2 )_v 10C i2 ( h10 h11 h1 h2 )_v + = -1 * v ( h10 h11 h1 h2 )_v 11C i2 ( h10 h11 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i3 ( h10 h11 h2 p5 )_v 12C i3 ( h10 h11 h1 p5 )_v + = 1 * v ( h10 h11 h1 p5 )_v 13C i3 ( h10 h11 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h10 h11 p5 p6 )_v 14C i2 ( h10 h11 h1 h2 )_vt + = -1/2 * Sum ( p7 p8 ) * t ( p7 p8 h1 h2 )_t * v ( h10 h11 p7 p8 )_v 15C i1 ( h10 p3 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h10 p3 h2 p5 )_v 16C i2 ( h10 p3 h1 p5 )_v + = 1 * v ( h10 p3 h1 p5 )_v 17C i2 ( h10 p3 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h10 p3 p5 p6 )_v 18C i1 ( h10 p3 h1 h2 )_ft + = -1 * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i2 ( h10 p5 )_f 19C i2 ( h10 p5 )_f + = 1 * f ( h10 p5 )_f 20C i2 ( h10 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h10 p5 p6 )_v 21C i1 ( h10 p3 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( h7 p9 ) * t ( p3 p9 h1 h7 )_t * i2 ( h7 h10 h2 p9 )_v 22C i2 ( h7 h10 h1 p9 )_v + = 1 * v ( h7 h10 h1 p9 )_v 23C i2 ( h7 h10 h1 p9 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h7 h10 p5 p9 )_v 24C i1 ( h10 p3 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h10 p3 p5 p6 )_v 25C i1 ( h10 p3 h1 h2 )_vt + = 1/2 * Sum ( h7 p5 p6 ) * t ( p3 p5 p6 h1 h2 h7 )_t * v ( h7 h10 p5 p6 )_v 26C i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i1 ( p3 p4 h2 p5 )_v 27C i1 ( p3 p4 h1 p5 )_v + = 1 * v ( p3 p4 h1 p5 )_v 28C i1 ( p3 p4 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( p3 p4 p5 p6 )_v 29C i0 ( p3 p4 h1 h2 )_tf + = -1 * P( 2 ) * Sum ( h9 ) * t ( p3 p4 h1 h9 )_t * i1 ( h9 h2 )_f 30C i1 ( h9 h1 )_f + = 1 * f ( h9 h1 )_f 31C i1 ( h9 h1 )_ft + = 1 * Sum ( p8 ) * t ( p8 h1 )_t * i2 ( h9 p8 )_f 32C i2 ( h9 p8 )_f + = 1 * f ( h9 p8 )_f 33C i2 ( h9 p8 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 p6 p8 )_v 34C i1 ( h9 h1 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 h1 p6 )_v 35C i1 ( h9 h1 )_vt + = -1/2 * Sum ( h8 p6 p7 ) * t ( p6 p7 h1 h8 )_t * v ( h8 h9 p6 p7 )_v 36C i0 ( p3 p4 h1 h2 )_tf + = 1 * P( 2 ) * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i1 ( p4 p5 )_f 37C i1 ( p3 p5 )_f + = 1 * f ( p3 p5 )_f 38C i1 ( p3 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 p3 p5 p6 )_v 39C i1 ( p3 p5 )_vt + = -1/2 * Sum ( h7 h8 p6 ) * t ( p3 p6 h7 h8 )_t * v ( h7 h8 p5 p6 )_v 40C i0 ( p3 p4 h1 h2 )_vt + = -1/2 * Sum ( h11 h9 ) * t ( p3 p4 h9 h11 )_t * i1 ( h9 h11 h1 h2 )_v 41C i1 ( h9 h11 h1 h2 )_v + = -1 * v ( h9 h11 h1 h2 )_v 42C i1 ( h9 h11 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( p8 ) * t ( p8 h1 )_t * i2 ( h9 h11 h2 p8 )_v 43C i2 ( h9 h11 h1 p8 )_v + = 1 * v ( h9 h11 h1 p8 )_v 44C i2 ( h9 h11 h1 p8 )_vt + = 1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 h11 p6 p8 )_v 45C i1 ( h9 h11 h1 h2 )_vt + = -1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 h11 p5 p6 )_v 46C i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 4 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i1 ( h6 p4 h2 p5 )_v 47C i1 ( h6 p3 h1 p5 )_v + = 1 * v ( h6 p3 h1 p5 )_v 48C i1 ( h6 p3 h1 p5 )_vt + = -1 * Sum ( p7 ) * t ( p7 h1 )_t * v ( h6 p3 p5 p7 )_v 49C i1 ( h6 p3 h1 p5 )_vt + = -1/2 * Sum ( h8 p7 ) * t ( p3 p7 h1 h8 )_t * v ( h6 h8 p5 p7 )_v 50C i0 ( p3 p4 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( p3 p4 p5 p6 )_v 51C i0 ( p3 p4 h1 h2 )_tf + = 1 * Sum ( p9 h10 ) * t ( p3 p4 p9 h1 h2 h10 )_t * i1 ( h10 p9 )_f 52C i1 ( h10 p9 )_f + = 1 * f ( h10 p9 )_f 53C i1 ( h10 p9 )_vt + = 1 * Sum ( h8 p7 ) * t ( p7 h8 )_t * v ( h8 h10 p7 p9 )_v 54C i0 ( p3 p4 h1 h2 )_vt + = -1/2 * P( 2 ) * Sum ( h6 h7 p5 ) * t ( p3 p4 p5 h1 h6 h7 )_t * i1 ( h6 h7 h2 p5 )_v 55C i1 ( h6 h7 h1 p5 )_v + = 1 * v ( h6 h7 h1 p5 )_v 56C i1 ( h6 h7 h1 p5 )_vt + = -1 * Sum ( p8 ) * t ( p8 h1 )_t * v ( h6 h7 p5 p8 )_v 57C i0 ( p3 p4 h1 h2 )_vt + = -1/2 * P( 2 ) * Sum ( h7 p5 p6 ) * t ( p3 p5 p6 h1 h2 h7 )_t * v ( h7 p4 p5 p6 )_v 58 IMPLICIT NONE 59#include "global.fh" 60#include "mafdecls.fh" 61#include "util.fh" 62#include "errquit.fh" 63#include "tce.fh" 64 INTEGER d_i0 65 INTEGER k_i0_offset 66 INTEGER d_v2 67 INTEGER k_v2_offset 68 INTEGER d_t1 69 INTEGER k_t1_offset 70 INTEGER d_i1 71 INTEGER k_i1_offset 72 INTEGER d_t2 73 INTEGER k_t2_offset 74 INTEGER d_t3 75 INTEGER k_t3_offset 76 INTEGER l_i1_offset 77 INTEGER size_i1 78 INTEGER d_i2 79 INTEGER k_i2_offset 80 INTEGER l_i2_offset 81 INTEGER size_i2 82 INTEGER d_i3 83 INTEGER k_i3_offset 84 INTEGER l_i3_offset 85 INTEGER size_i3 86 INTEGER d_f1 87 INTEGER k_f1_offset 88 CHARACTER*255 filename 89 CALL ccsdt_t2a_1(d_v2,k_v2_offset,d_i0,k_i0_offset) 90 CALL OFFSET_ccsdt_t2a_2_1(l_i1_offset,k_i1_offset,size_i1) 91 CALL TCE_FILENAME('ccsdt_t2_2_1_i1',filename) 92 CALL CREATEFILE(filename,d_i1,size_i1) 93 CALL ccsdt_t2a_2_1(d_v2,k_v2_offset,d_i1,k_i1_offset) 94 CALL OFFSET_ccsdt_t2a_2_2_1(l_i2_offset,k_i2_offset,size_i2) 95 CALL TCE_FILENAME('ccsdt_t2_2_2_1_i2',filename) 96 CALL CREATEFILE(filename,d_i2,size_i2) 97 CALL ccsdt_t2a_2_2_1(d_v2,k_v2_offset,d_i2,k_i2_offset) 98 CALL OFFSET_ccsdt_t2a_2_2_2_1(l_i3_offset,k_i3_offset,size_i3) 99 CALL TCE_FILENAME('ccsdt_t2_2_2_2_1_i3',filename) 100 CALL CREATEFILE(filename,d_i3,size_i3) 101 CALL ccsdt_t2a_2_2_2_1(d_v2,k_v2_offset,d_i3,k_i3_offset) 102 CALL ccsdt_t2a_2_2_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i3, 103 &k_i3_offset) 104 CALL RECONCILEFILE(d_i3,size_i3) 105 CALL ccsdt_t2a_2_2_2(d_t1,k_t1_offset,d_i3,k_i3_offset,d_i2, 106 &k_i2_offset) 107 CALL DELETEFILE(d_i3) 108 IF (.not.MA_POP_STACK(l_i3_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 109 &ERR) 110 CALL ccsdt_t2a_2_2_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i2, 111 &k_i2_offset) 112 CALL RECONCILEFILE(d_i2,size_i2) 113 CALL ccsdt_t2a_2_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1, 114 &k_i1_offset) 115 CALL DELETEFILE(d_i2) 116 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 117 &ERR) 118 CALL OFFSET_ccsdt_t2a_2_3_1(l_i2_offset,k_i2_offset,size_i2) 119 CALL TCE_FILENAME('ccsdt_t2_2_3_1_i2',filename) 120 CALL CREATEFILE(filename,d_i2,size_i2) 121 CALL ccsdt_t2a_2_3_1(d_v2,k_v2_offset,d_i2,k_i2_offset) 122 CALL ccsdt_t2a_2_3_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2, 123 &k_i2_offset) 124 CALL RECONCILEFILE(d_i2,size_i2) 125 CALL ccsdt_t2a_2_3(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1, 126 &k_i1_offset) 127 CALL DELETEFILE(d_i2) 128 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 129 &ERR) 130 CALL OFFSET_ccsdt_t2a_2_4_1(l_i2_offset,k_i2_offset,size_i2) 131 CALL TCE_FILENAME('ccsdt_t2_2_4_1_i2',filename) 132 CALL CREATEFILE(filename,d_i2,size_i2) 133 CALL ccsdt_t2a_2_4_1(d_f1,k_f1_offset,d_i2,k_i2_offset) 134 CALL ccsdt_t2a_2_4_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2, 135 &k_i2_offset) 136 CALL RECONCILEFILE(d_i2,size_i2) 137 CALL ccsdt_t2a_2_4(d_t2,k_t2_offset,d_i2,k_i2_offset,d_i1, 138 &k_i1_offset) 139 CALL DELETEFILE(d_i2) 140 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 141 &ERR) 142 CALL OFFSET_ccsdt_t2a_2_5_1(l_i2_offset,k_i2_offset,size_i2) 143 CALL TCE_FILENAME('ccsdt_t2_2_5_1_i2',filename) 144 CALL CREATEFILE(filename,d_i2,size_i2) 145 CALL ccsdt_t2a_2_5_1(d_v2,k_v2_offset,d_i2,k_i2_offset) 146 CALL ccsdt_t2a_2_5_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2, 147 &k_i2_offset) 148 CALL RECONCILEFILE(d_i2,size_i2) 149 CALL ccsdt_t2a_2_5(d_t2,k_t2_offset,d_i2,k_i2_offset,d_i1, 150 &k_i1_offset) 151 CALL DELETEFILE(d_i2) 152 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 153 &ERR) 154 CALL ccsdt_t2a_2_6(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1, 155 &k_i1_offset) 156 CALL ccsdt_t2a_2_7(d_t3,k_t3_offset,d_v2,k_v2_offset,d_i1, 157 &k_i1_offset) 158 CALL RECONCILEFILE(d_i1,size_i1) 159 CALL ccsdt_t2a_2(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0, 160 &k_i0_offset) 161 CALL DELETEFILE(d_i1) 162 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 163 &ERR) 164 CALL OFFSET_ccsdt_t2a_3_1(l_i1_offset,k_i1_offset,size_i1) 165 CALL TCE_FILENAME('ccsdt_t2_3_1_i1',filename) 166 CALL CREATEFILE(filename,d_i1,size_i1) 167 CALL ccsdt_t2a_3_1(d_v2,k_v2_offset,d_i1,k_i1_offset) 168 CALL ccsdt_t2a_3_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1, 169 &k_i1_offset) 170 CALL RECONCILEFILE(d_i1,size_i1) 171 CALL ccsdt_t2a_3(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0, 172 &k_i0_offset) 173 CALL DELETEFILE(d_i1) 174 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 175 &ERR) 176 CALL OFFSET_ccsdt_t2a_4_1(l_i1_offset,k_i1_offset,size_i1) 177 CALL TCE_FILENAME('ccsdt_t2_4_1_i1',filename) 178 CALL CREATEFILE(filename,d_i1,size_i1) 179 CALL ccsdt_t2a_4_1(d_f1,k_f1_offset,d_i1,k_i1_offset) 180 CALL OFFSET_ccsdt_t2a_4_2_1(l_i2_offset,k_i2_offset,size_i2) 181 CALL TCE_FILENAME('ccsdt_t2_4_2_1_i2',filename) 182 CALL CREATEFILE(filename,d_i2,size_i2) 183 CALL ccsdt_t2a_4_2_1(d_f1,k_f1_offset,d_i2,k_i2_offset) 184 CALL ccsdt_t2a_4_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2, 185 &k_i2_offset) 186 CALL RECONCILEFILE(d_i2,size_i2) 187 CALL ccsdt_t2a_4_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1, 188 &k_i1_offset) 189 CALL DELETEFILE(d_i2) 190 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 191 &ERR) 192 CALL ccsdt_t2a_4_3(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1, 193 &k_i1_offset) 194 CALL ccsdt_t2a_4_4(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1, 195 &k_i1_offset) 196 CALL RECONCILEFILE(d_i1,size_i1) 197 CALL ccsdt_t2a_4(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0, 198 &k_i0_offset) 199 CALL DELETEFILE(d_i1) 200 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 201 &ERR) 202 CALL OFFSET_ccsdt_t2a_5_1(l_i1_offset,k_i1_offset,size_i1) 203 CALL TCE_FILENAME('ccsdt_t2_5_1_i1',filename) 204 CALL CREATEFILE(filename,d_i1,size_i1) 205 CALL ccsdt_t2a_5_1(d_f1,k_f1_offset,d_i1,k_i1_offset) 206 CALL ccsdt_t2a_5_2(d_t1,k_t1_offset,d_v2,k_v2_offset, 207 &d_i1,k_i1_offset) 208 CALL ccsdt_t2a_5_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1, 209 &k_i1_offset) 210 CALL RECONCILEFILE(d_i1,size_i1) 211 CALL ccsdt_t2a_5(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0, 212 &k_i0_offset) 213 CALL DELETEFILE(d_i1) 214 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 215 &ERR) 216 CALL OFFSET_ccsdt_t2a_6_1(l_i1_offset,k_i1_offset,size_i1) 217 CALL TCE_FILENAME('ccsdt_t2_6_1_i1',filename) 218 CALL CREATEFILE(filename,d_i1,size_i1) 219 CALL ccsdt_t2a_6_1(d_v2,k_v2_offset,d_i1,k_i1_offset) 220 CALL OFFSET_ccsdt_t2a_6_2_1(l_i2_offset,k_i2_offset,size_i2) 221 CALL TCE_FILENAME('ccsdt_t2_6_2_1_i2',filename) 222 CALL CREATEFILE(filename,d_i2,size_i2) 223 CALL ccsdt_t2a_6_2_1(d_v2,k_v2_offset,d_i2,k_i2_offset) 224 CALL ccsdt_t2a_6_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2, 225 &k_i2_offset) 226 CALL RECONCILEFILE(d_i2,size_i2) 227 CALL ccsdt_t2a_6_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1, 228 &k_i1_offset) 229 CALL DELETEFILE(d_i2) 230 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 231 &ERR) 232 CALL ccsdt_t2a_6_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1, 233 &k_i1_offset) 234 CALL RECONCILEFILE(d_i1,size_i1) 235 CALL ccsdt_t2a_6(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0, 236 &k_i0_offset) 237 CALL DELETEFILE(d_i1) 238 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 239 &ERR) 240 CALL OFFSET_ccsdt_t2a_7_1(l_i1_offset,k_i1_offset,size_i1) 241 CALL TCE_FILENAME('ccsdt_t2_7_1_i1',filename) 242 CALL CREATEFILE(filename,d_i1,size_i1) 243 CALL ccsdt_t2a_7_1(d_v2,k_v2_offset,d_i1,k_i1_offset) 244 CALL ccsdt_t2a_7_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1, 245 &k_i1_offset) 246 CALL ccsdt_t2a_7_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1, 247 &k_i1_offset) 248 CALL RECONCILEFILE(d_i1,size_i1) 249 CALL ccsdt_t2a_7(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0, 250 &k_i0_offset) 251 CALL DELETEFILE(d_i1) 252 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 253 &ERR) 254 CALL ccsdt_t2a_8(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i0, 255 &k_i0_offset) 256 CALL OFFSET_ccsdt_t2a_9_1(l_i1_offset,k_i1_offset,size_i1) 257 CALL TCE_FILENAME('ccsdt_t2_9_1_i1',filename) 258 CALL CREATEFILE(filename,d_i1,size_i1) 259 CALL ccsdt_t2a_9_1(d_f1,k_f1_offset,d_i1,k_i1_offset) 260 CALL ccsdt_t2a_9_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1, 261 &k_i1_offset) 262 CALL RECONCILEFILE(d_i1,size_i1) 263 CALL ccsdt_t2a_9(d_t3,k_t3_offset,d_i1,k_i1_offset,d_i0, 264 &k_i0_offset) 265 CALL DELETEFILE(d_i1) 266 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 267 &ERR) 268 CALL OFFSET_ccsdt_t2a_10_1(l_i1_offset,k_i1_offset,size_i1) 269 CALL TCE_FILENAME('ccsdt_t2_10_1_i1',filename) 270 CALL CREATEFILE(filename,d_i1,size_i1) 271 CALL ccsdt_t2a_10_1(d_v2,k_v2_offset,d_i1,k_i1_offset) 272 CALL ccsdt_t2a_10_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1, 273 &k_i1_offset) 274 CALL RECONCILEFILE(d_i1,size_i1) 275 CALL ccsdt_t2a_10(d_t3,k_t3_offset,d_i1,k_i1_offset,d_i0, 276 &k_i0_offset) 277 CALL DELETEFILE(d_i1) 278 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdt_t2',-1,MA_ 279 &ERR) 280 CALL ccsdt_t2a_11(d_t3,k_t3_offset,d_v2,k_v2_offset,d_i0, 281 &k_i0_offset) 282 RETURN 283 END 284 SUBROUTINE ccsdt_t2a_1(d_a,k_a_offset,d_c,k_c_offset) 285C $Id$ 286C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 287C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 288C i0 ( p3 p4 h1 h2 )_v + = 1 * v ( p3 p4 h1 h2 )_v 289 IMPLICIT NONE 290#include "global.fh" 291#include "mafdecls.fh" 292#include "sym.fh" 293#include "errquit.fh" 294#include "tce.fh" 295 INTEGER d_a 296 INTEGER k_a_offset 297 INTEGER d_c 298 INTEGER k_c_offset 299 INTEGER NXTASK 300 INTEGER next 301 INTEGER nprocs 302 INTEGER count 303 INTEGER p3b 304 INTEGER p4b 305 INTEGER h1b 306 INTEGER h2b 307 INTEGER dimc 308 INTEGER p3b_1 309 INTEGER p4b_1 310 INTEGER h1b_1 311 INTEGER h2b_1 312 INTEGER dim_common 313 INTEGER dima_sort 314 INTEGER dima 315 INTEGER l_a_sort 316 INTEGER k_a_sort 317 INTEGER l_a 318 INTEGER k_a 319 INTEGER l_c 320 INTEGER k_c 321 EXTERNAL NXTASK 322 nprocs = GA_NNODES() 323 count = 0 324 next = NXTASK(nprocs,1) 325 DO p3b = noab+1,noab+nvab 326 DO p4b = p3b,noab+nvab 327 DO h1b = 1,noab 328 DO h2b = h1b,noab 329 IF (next.eq.count) THEN 330 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 331 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 332 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 333 &1b-1)+int_mb(k_spin+h2b-1)) THEN 334 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 335 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 336 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 337 &nge+h1b-1) * int_mb(k_range+h2b-1) 338 CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h2b,p3b_1,p4b_1,h1b_1,h2b_1) 339 dim_common = 1 340 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb 341 &(k_range+h1b-1) * int_mb(k_range+h2b-1) 342 dima = dim_common * dima_sort 343 IF (dima .gt. 0) THEN 344 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 345 & ERRQUIT('ccsdt_t2_1',0,MA_ERR) 346 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 347 &ccsdt_t2_1',1,MA_ERR) 348 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 349 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p4b_1 - 1 + (noab 350 &+nvab) * (p3b_1 - 1))))) 351 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 352 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 353 &,4,3,2,1,1.0d0) 354 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_1',2,MA_ERR) 355 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 356 &ccsdt_t2_1',3,MA_ERR) 357 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 358 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 359 &,4,3,2,1,1.0d0) 360 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 361 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 362 & - 1))))) 363 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_1',4,MA_ERR) 364 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_1',5,MA_ER 365 &R) 366 END IF 367 END IF 368 END IF 369 END IF 370 next = NXTASK(nprocs,1) 371 END IF 372 count = count + 1 373 END DO 374 END DO 375 END DO 376 END DO 377 next = NXTASK(-nprocs,1) 378 call GA_SYNC() 379 RETURN 380 END 381 SUBROUTINE ccsdt_t2a_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 382 &k_c_offset) 383C $Id$ 384C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 385C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 386C i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( h10 ) * t ( p3 h10 )_t * i1 ( h10 p4 h1 h2 )_v 387 IMPLICIT NONE 388#include "global.fh" 389#include "mafdecls.fh" 390#include "sym.fh" 391#include "errquit.fh" 392#include "tce.fh" 393 INTEGER d_a 394 INTEGER k_a_offset 395 INTEGER d_b 396 INTEGER k_b_offset 397 INTEGER d_c 398 INTEGER k_c_offset 399 INTEGER NXTASK 400 INTEGER next 401 INTEGER nprocs 402 INTEGER count 403 INTEGER p3b 404 INTEGER p4b 405 INTEGER h1b 406 INTEGER h2b 407 INTEGER dimc 408 INTEGER l_c_sort 409 INTEGER k_c_sort 410 INTEGER h10b 411 INTEGER p3b_1 412 INTEGER h10b_1 413 INTEGER p4b_2 414 INTEGER h10b_2 415 INTEGER h1b_2 416 INTEGER h2b_2 417 INTEGER dim_common 418 INTEGER dima_sort 419 INTEGER dima 420 INTEGER dimb_sort 421 INTEGER dimb 422 INTEGER l_a_sort 423 INTEGER k_a_sort 424 INTEGER l_a 425 INTEGER k_a 426 INTEGER l_b_sort 427 INTEGER k_b_sort 428 INTEGER l_b 429 INTEGER k_b 430 INTEGER l_c 431 INTEGER k_c 432 EXTERNAL NXTASK 433 nprocs = GA_NNODES() 434 count = 0 435 next = NXTASK(nprocs,1) 436 DO p3b = noab+1,noab+nvab 437 DO p4b = noab+1,noab+nvab 438 DO h1b = 1,noab 439 DO h2b = h1b,noab 440 IF (next.eq.count) THEN 441 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 442 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 443 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 444 &1b-1)+int_mb(k_spin+h2b-1)) THEN 445 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 446 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 447 &EN 448 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 449 &nge+h1b-1) * int_mb(k_range+h2b-1) 450 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 451 & ERRQUIT('ccsdt_t2_2',0,MA_ERR) 452 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 453 DO h10b = 1,noab 454 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h10b-1)) THEN 455 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h10b-1)) .eq. irrep_t) T 456 &HEN 457 CALL TCE_RESTRICTED_2(p3b,h10b,p3b_1,h10b_1) 458 CALL TCE_RESTRICTED_4(p4b,h10b,h1b,h2b,p4b_2,h10b_2,h1b_2,h2b_2) 459 dim_common = int_mb(k_range+h10b-1) 460 dima_sort = int_mb(k_range+p3b-1) 461 dima = dim_common * dima_sort 462 dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1) * int_mb 463 &(k_range+h2b-1) 464 dimb = dim_common * dimb_sort 465 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 466 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 467 & ERRQUIT('ccsdt_t2_2',1,MA_ERR) 468 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 469 &ccsdt_t2_2',2,MA_ERR) 470 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_ 471 &1 - 1 + noab * (p3b_1 - noab - 1))) 472 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 473 &,int_mb(k_range+h10b-1),1,2,1.0d0) 474 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2',3,MA_ERR) 475 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 476 & ERRQUIT('ccsdt_t2_2',4,MA_ERR) 477 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 478 &ccsdt_t2_2',5,MA_ERR) 479 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 480 & - 1 + noab * (h1b_2 - 1 + noab * (h10b_2 - 1 + noab * (p4b_2 - no 481 &ab - 1))))) 482 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 483 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 484 &),4,3,1,2,1.0d0) 485 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2',6,MA_ERR) 486 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 487 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 488 &t),dima_sort) 489 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2',7,MA_ER 490 &R) 491 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2',8,MA_ER 492 &R) 493 END IF 494 END IF 495 END IF 496 END DO 497 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 498 &ccsdt_t2_2',9,MA_ERR) 499 IF ((p3b .le. p4b)) THEN 500 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 501 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 502 &,4,3,2,1,-1.0d0) 503 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 504 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 505 & - 1))))) 506 END IF 507 IF ((p4b .le. p3b)) THEN 508 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 509 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 510 &,3,4,2,1,1.0d0) 511 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 512 & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 513 & - 1))))) 514 END IF 515 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2',10,MA_ERR) 516 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2',11,MA_E 517 &RR) 518 END IF 519 END IF 520 END IF 521 next = NXTASK(nprocs,1) 522 END IF 523 count = count + 1 524 END DO 525 END DO 526 END DO 527 END DO 528 next = NXTASK(-nprocs,1) 529 call GA_SYNC() 530 RETURN 531 END 532 SUBROUTINE ccsdt_t2a_2_1(d_a,k_a_offset,d_c,k_c_offset) 533C $Id$ 534C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 535C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 536C i1 ( h10 p3 h1 h2 )_v + = 1 * v ( h10 p3 h1 h2 )_v 537 IMPLICIT NONE 538#include "global.fh" 539#include "mafdecls.fh" 540#include "sym.fh" 541#include "errquit.fh" 542#include "tce.fh" 543 INTEGER d_a 544 INTEGER k_a_offset 545 INTEGER d_c 546 INTEGER k_c_offset 547 INTEGER NXTASK 548 INTEGER next 549 INTEGER nprocs 550 INTEGER count 551 INTEGER p3b 552 INTEGER h10b 553 INTEGER h1b 554 INTEGER h2b 555 INTEGER dimc 556 INTEGER p3b_1 557 INTEGER h10b_1 558 INTEGER h1b_1 559 INTEGER h2b_1 560 INTEGER dim_common 561 INTEGER dima_sort 562 INTEGER dima 563 INTEGER l_a_sort 564 INTEGER k_a_sort 565 INTEGER l_a 566 INTEGER k_a 567 INTEGER l_c 568 INTEGER k_c 569 EXTERNAL NXTASK 570 nprocs = GA_NNODES() 571 count = 0 572 next = NXTASK(nprocs,1) 573 DO p3b = noab+1,noab+nvab 574 DO h10b = 1,noab 575 DO h1b = 1,noab 576 DO h2b = h1b,noab 577 IF (next.eq.count) THEN 578 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 579 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 580 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 581 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 582 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 583 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 584 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 585 &ange+h1b-1) * int_mb(k_range+h2b-1) 586 CALL TCE_RESTRICTED_4(p3b,h10b,h1b,h2b,p3b_1,h10b_1,h1b_1,h2b_1) 587 dim_common = 1 588 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_m 589 &b(k_range+h1b-1) * int_mb(k_range+h2b-1) 590 dima = dim_common * dima_sort 591 IF (dima .gt. 0) THEN 592 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 593 & ERRQUIT('ccsdt_t2_2_1',0,MA_ERR) 594 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 595 &ccsdt_t2_2_1',1,MA_ERR) 596 IF ((h10b .le. p3b)) THEN 597 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 598 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab 599 &+nvab) * (h10b_1 - 1))))) 600 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1 601 &),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 602 &),4,3,1,2,1.0d0) 603 END IF 604 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_1',2,MA_ERR) 605 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 606 &ccsdt_t2_2_1',3,MA_ERR) 607 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 608 &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+p3b-1 609 &),4,3,2,1,1.0d0) 610 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 611 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 612 &))) 613 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_1',4,MA_ERR) 614 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_1',5,MA_ 615 &ERR) 616 END IF 617 END IF 618 END IF 619 END IF 620 next = NXTASK(nprocs,1) 621 END IF 622 count = count + 1 623 END DO 624 END DO 625 END DO 626 END DO 627 next = NXTASK(-nprocs,1) 628 call GA_SYNC() 629 RETURN 630 END 631 SUBROUTINE OFFSET_ccsdt_t2a_2_1(l_a_offset,k_a_offset,size) 632C $Id$ 633C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 634C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 635C i1 ( h10 p3 h1 h2 )_v 636 IMPLICIT NONE 637#include "global.fh" 638#include "mafdecls.fh" 639#include "sym.fh" 640#include "errquit.fh" 641#include "tce.fh" 642 INTEGER l_a_offset 643 INTEGER k_a_offset 644 INTEGER size 645 INTEGER length 646 INTEGER addr 647 INTEGER p3b 648 INTEGER h10b 649 INTEGER h1b 650 INTEGER h2b 651 length = 0 652 DO p3b = noab+1,noab+nvab 653 DO h10b = 1,noab 654 DO h1b = 1,noab 655 DO h2b = h1b,noab 656 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+ 657 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 658 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb 659 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 660 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b- 661 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 662 length = length + 1 663 END IF 664 END IF 665 END IF 666 END DO 667 END DO 668 END DO 669 END DO 670 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 671 &set)) CALL ERRQUIT('ccsdt_t2_2_1',0,MA_ERR) 672 int_mb(k_a_offset) = length 673 addr = 0 674 size = 0 675 DO p3b = noab+1,noab+nvab 676 DO h10b = 1,noab 677 DO h1b = 1,noab 678 DO h2b = h1b,noab 679 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+ 680 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 681 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb 682 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 683 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b- 684 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 685 addr = addr + 1 686 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h10b 687 & - 1 + noab * (p3b - noab - 1))) 688 int_mb(k_a_offset+length+addr) = size 689 size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int 690 &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 691 END IF 692 END IF 693 END IF 694 END DO 695 END DO 696 END DO 697 END DO 698 RETURN 699 END 700 SUBROUTINE ccsdt_t2a_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 701 &k_c_offset) 702C $Id$ 703C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 704C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 705C i1 ( h10 p3 h1 h2 )_vt + = 1/2 * Sum ( h11 ) * t ( p3 h11 )_t * i2 ( h10 h11 h1 h2 )_v 706 IMPLICIT NONE 707#include "global.fh" 708#include "mafdecls.fh" 709#include "sym.fh" 710#include "errquit.fh" 711#include "tce.fh" 712 INTEGER d_a 713 INTEGER k_a_offset 714 INTEGER d_b 715 INTEGER k_b_offset 716 INTEGER d_c 717 INTEGER k_c_offset 718 INTEGER NXTASK 719 INTEGER next 720 INTEGER nprocs 721 INTEGER count 722 INTEGER p3b 723 INTEGER h10b 724 INTEGER h1b 725 INTEGER h2b 726 INTEGER dimc 727 INTEGER l_c_sort 728 INTEGER k_c_sort 729 INTEGER h11b 730 INTEGER p3b_1 731 INTEGER h11b_1 732 INTEGER h10b_2 733 INTEGER h11b_2 734 INTEGER h1b_2 735 INTEGER h2b_2 736 INTEGER dim_common 737 INTEGER dima_sort 738 INTEGER dima 739 INTEGER dimb_sort 740 INTEGER dimb 741 INTEGER l_a_sort 742 INTEGER k_a_sort 743 INTEGER l_a 744 INTEGER k_a 745 INTEGER l_b_sort 746 INTEGER k_b_sort 747 INTEGER l_b 748 INTEGER k_b 749 INTEGER l_c 750 INTEGER k_c 751 EXTERNAL NXTASK 752 nprocs = GA_NNODES() 753 count = 0 754 next = NXTASK(nprocs,1) 755 DO p3b = noab+1,noab+nvab 756 DO h10b = 1,noab 757 DO h1b = 1,noab 758 DO h2b = h1b,noab 759 IF (next.eq.count) THEN 760 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 761 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 762 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 763 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 764 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 765 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 766 &HEN 767 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 768 &ange+h1b-1) * int_mb(k_range+h2b-1) 769 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 770 & ERRQUIT('ccsdt_t2_2_2',0,MA_ERR) 771 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 772 DO h11b = 1,noab 773 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h11b-1)) THEN 774 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h11b-1)) .eq. irrep_t) T 775 &HEN 776 CALL TCE_RESTRICTED_2(p3b,h11b,p3b_1,h11b_1) 777 CALL TCE_RESTRICTED_4(h10b,h11b,h1b,h2b,h10b_2,h11b_2,h1b_2,h2b_2) 778 dim_common = int_mb(k_range+h11b-1) 779 dima_sort = int_mb(k_range+p3b-1) 780 dima = dim_common * dima_sort 781 dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h1b-1) * int_m 782 &b(k_range+h2b-1) 783 dimb = dim_common * dimb_sort 784 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 785 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 786 & ERRQUIT('ccsdt_t2_2_2',1,MA_ERR) 787 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 788 &ccsdt_t2_2_2',2,MA_ERR) 789 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h11b_ 790 &1 - 1 + noab * (p3b_1 - noab - 1))) 791 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 792 &,int_mb(k_range+h11b-1),1,2,1.0d0) 793 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_2',3,MA_ERR) 794 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 795 & ERRQUIT('ccsdt_t2_2_2',4,MA_ERR) 796 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 797 &ccsdt_t2_2_2',5,MA_ERR) 798 IF ((h11b .lt. h10b)) THEN 799 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 800 & - 1 + noab * (h1b_2 - 1 + noab * (h10b_2 - 1 + noab * (h11b_2 - 1 801 &))))) 802 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h11b-1 803 &),int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b- 804 &1),4,3,2,1,-1.0d0) 805 END IF 806 IF ((h10b .le. h11b)) THEN 807 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 808 & - 1 + noab * (h1b_2 - 1 + noab * (h11b_2 - 1 + noab * (h10b_2 - 1 809 &))))) 810 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 811 &),int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b- 812 &1),4,3,1,2,1.0d0) 813 END IF 814 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_2',6,MA_ERR) 815 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 816 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 817 &t),dima_sort) 818 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_2',7,MA_ 819 &ERR) 820 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_2',8,MA_ 821 &ERR) 822 END IF 823 END IF 824 END IF 825 END DO 826 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 827 &ccsdt_t2_2_2',9,MA_ERR) 828 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 829 &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+p3b-1 830 &),4,3,2,1,1.0d0/2.0d0) 831 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 832 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 833 &))) 834 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_2',10,MA_ERR) 835 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_2',11,MA 836 &_ERR) 837 END IF 838 END IF 839 END IF 840 next = NXTASK(nprocs,1) 841 END IF 842 count = count + 1 843 END DO 844 END DO 845 END DO 846 END DO 847 next = NXTASK(-nprocs,1) 848 call GA_SYNC() 849 RETURN 850 END 851 SUBROUTINE ccsdt_t2a_2_2_1(d_a,k_a_offset,d_c,k_c_offset) 852C $Id$ 853C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 854C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 855C i2 ( h10 h11 h1 h2 )_v + = -1 * v ( h10 h11 h1 h2 )_v 856 IMPLICIT NONE 857#include "global.fh" 858#include "mafdecls.fh" 859#include "sym.fh" 860#include "errquit.fh" 861#include "tce.fh" 862 INTEGER d_a 863 INTEGER k_a_offset 864 INTEGER d_c 865 INTEGER k_c_offset 866 INTEGER NXTASK 867 INTEGER next 868 INTEGER nprocs 869 INTEGER count 870 INTEGER h10b 871 INTEGER h11b 872 INTEGER h1b 873 INTEGER h2b 874 INTEGER dimc 875 INTEGER h10b_1 876 INTEGER h11b_1 877 INTEGER h1b_1 878 INTEGER h2b_1 879 INTEGER dim_common 880 INTEGER dima_sort 881 INTEGER dima 882 INTEGER l_a_sort 883 INTEGER k_a_sort 884 INTEGER l_a 885 INTEGER k_a 886 INTEGER l_c 887 INTEGER k_c 888 EXTERNAL NXTASK 889 nprocs = GA_NNODES() 890 count = 0 891 next = NXTASK(nprocs,1) 892 DO h10b = 1,noab 893 DO h11b = h10b,noab 894 DO h1b = 1,noab 895 DO h2b = h1b,noab 896 IF (next.eq.count) THEN 897 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b 898 &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 899 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin 900 &+h1b-1)+int_mb(k_spin+h2b-1)) THEN 901 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m 902 &b(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 903 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_mb(k_ 904 &range+h1b-1) * int_mb(k_range+h2b-1) 905 CALL TCE_RESTRICTED_4(h10b,h11b,h1b,h2b,h10b_1,h11b_1,h1b_1,h2b_1) 906 dim_common = 1 907 dima_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_ 908 &mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 909 dima = dim_common * dima_sort 910 IF (dima .gt. 0) THEN 911 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 912 & ERRQUIT('ccsdt_t2_2_2_1',0,MA_ERR) 913 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 914 &ccsdt_t2_2_2_1',1,MA_ERR) 915 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 916 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa 917 &b+nvab) * (h10b_1 - 1))))) 918 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1 919 &),int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b- 920 &1),4,3,2,1,1.0d0) 921 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_2_1',2,MA_ERR 922 &) 923 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 924 &ccsdt_t2_2_2_1',3,MA_ERR) 925 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 926 &,int_mb(k_range+h1b-1),int_mb(k_range+h11b-1),int_mb(k_range+h10b- 927 &1),4,3,2,1,-1.0d0) 928 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 929 & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h10b - 1))))) 930 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_2_1',4,MA_ERR 931 &) 932 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_2_1',5,M 933 &A_ERR) 934 END IF 935 END IF 936 END IF 937 END IF 938 next = NXTASK(nprocs,1) 939 END IF 940 count = count + 1 941 END DO 942 END DO 943 END DO 944 END DO 945 next = NXTASK(-nprocs,1) 946 call GA_SYNC() 947 RETURN 948 END 949 SUBROUTINE OFFSET_ccsdt_t2a_2_2_1(l_a_offset,k_a_offset,size) 950C $Id$ 951C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 952C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 953C i2 ( h10 h11 h1 h2 )_v 954 IMPLICIT NONE 955#include "global.fh" 956#include "mafdecls.fh" 957#include "sym.fh" 958#include "errquit.fh" 959#include "tce.fh" 960 INTEGER l_a_offset 961 INTEGER k_a_offset 962 INTEGER size 963 INTEGER length 964 INTEGER addr 965 INTEGER h10b 966 INTEGER h11b 967 INTEGER h1b 968 INTEGER h2b 969 length = 0 970 DO h10b = 1,noab 971 DO h11b = h10b,noab 972 DO h1b = 1,noab 973 DO h2b = h1b,noab 974 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin 975 &+h1b-1)+int_mb(k_spin+h2b-1)) THEN 976 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m 977 &b(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 978 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b 979 &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 980 length = length + 1 981 END IF 982 END IF 983 END IF 984 END DO 985 END DO 986 END DO 987 END DO 988 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 989 &set)) CALL ERRQUIT('ccsdt_t2_2_2_1',0,MA_ERR) 990 int_mb(k_a_offset) = length 991 addr = 0 992 size = 0 993 DO h10b = 1,noab 994 DO h11b = h10b,noab 995 DO h1b = 1,noab 996 DO h2b = h1b,noab 997 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin 998 &+h1b-1)+int_mb(k_spin+h2b-1)) THEN 999 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m 1000 &b(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 1001 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b 1002 &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1003 addr = addr + 1 1004 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h11b 1005 & - 1 + noab * (h10b - 1))) 1006 int_mb(k_a_offset+length+addr) = size 1007 size = size + int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * in 1008 &t_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 1009 END IF 1010 END IF 1011 END IF 1012 END DO 1013 END DO 1014 END DO 1015 END DO 1016 RETURN 1017 END 1018 SUBROUTINE ccsdt_t2a_2_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 1019 &k_c_offset) 1020C $Id$ 1021C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1022C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1023C i2 ( h10 h11 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i3 ( h10 h11 h2 p5 )_v 1024 IMPLICIT NONE 1025#include "global.fh" 1026#include "mafdecls.fh" 1027#include "sym.fh" 1028#include "errquit.fh" 1029#include "tce.fh" 1030 INTEGER d_a 1031 INTEGER k_a_offset 1032 INTEGER d_b 1033 INTEGER k_b_offset 1034 INTEGER d_c 1035 INTEGER k_c_offset 1036 INTEGER NXTASK 1037 INTEGER next 1038 INTEGER nprocs 1039 INTEGER count 1040 INTEGER h10b 1041 INTEGER h11b 1042 INTEGER h1b 1043 INTEGER h2b 1044 INTEGER dimc 1045 INTEGER l_c_sort 1046 INTEGER k_c_sort 1047 INTEGER p5b 1048 INTEGER p5b_1 1049 INTEGER h1b_1 1050 INTEGER h10b_2 1051 INTEGER h11b_2 1052 INTEGER h2b_2 1053 INTEGER p5b_2 1054 INTEGER dim_common 1055 INTEGER dima_sort 1056 INTEGER dima 1057 INTEGER dimb_sort 1058 INTEGER dimb 1059 INTEGER l_a_sort 1060 INTEGER k_a_sort 1061 INTEGER l_a 1062 INTEGER k_a 1063 INTEGER l_b_sort 1064 INTEGER k_b_sort 1065 INTEGER l_b 1066 INTEGER k_b 1067 INTEGER l_c 1068 INTEGER k_c 1069 EXTERNAL NXTASK 1070 nprocs = GA_NNODES() 1071 count = 0 1072 next = NXTASK(nprocs,1) 1073 DO h10b = 1,noab 1074 DO h11b = h10b,noab 1075 DO h1b = 1,noab 1076 DO h2b = 1,noab 1077 IF (next.eq.count) THEN 1078 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b 1079 &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1080 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin 1081 &+h1b-1)+int_mb(k_spin+h2b-1)) THEN 1082 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m 1083 &b(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) 1084 &THEN 1085 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_mb(k_ 1086 &range+h1b-1) * int_mb(k_range+h2b-1) 1087 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1088 & ERRQUIT('ccsdt_t2_2_2_2',0,MA_ERR) 1089 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1090 DO p5b = noab+1,noab+nvab 1091 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1092 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 1093 &EN 1094 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 1095 CALL TCE_RESTRICTED_4(h10b,h11b,h2b,p5b,h10b_2,h11b_2,h2b_2,p5b_2) 1096 dim_common = int_mb(k_range+p5b-1) 1097 dima_sort = int_mb(k_range+h1b-1) 1098 dima = dim_common * dima_sort 1099 dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_ 1100 &mb(k_range+h2b-1) 1101 dimb = dim_common * dimb_sort 1102 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1103 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1104 & ERRQUIT('ccsdt_t2_2_2_2',1,MA_ERR) 1105 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1106 &ccsdt_t2_2_2_2',2,MA_ERR) 1107 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1108 & - 1 + noab * (p5b_1 - noab - 1))) 1109 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1110 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1111 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_2_2',3,MA_ERR 1112 &) 1113 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1114 & ERRQUIT('ccsdt_t2_2_2_2',4,MA_ERR) 1115 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1116 &ccsdt_t2_2_2_2',5,MA_ERR) 1117 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1118 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h11b_2 - 1 + noab * (h10 1119 &b_2 - 1))))) 1120 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 1121 &),int_mb(k_range+h11b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b- 1122 &1),3,2,1,4,1.0d0) 1123 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_2_2',6,MA_ERR 1124 &) 1125 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1126 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1127 &t),dima_sort) 1128 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_2_2',7,M 1129 &A_ERR) 1130 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_2_2',8,M 1131 &A_ERR) 1132 END IF 1133 END IF 1134 END IF 1135 END DO 1136 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1137 &ccsdt_t2_2_2_2',9,MA_ERR) 1138 IF ((h1b .le. h2b)) THEN 1139 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 1140 &,int_mb(k_range+h11b-1),int_mb(k_range+h10b-1),int_mb(k_range+h1b- 1141 &1),3,2,4,1,1.0d0) 1142 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1143 & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h10b - 1))))) 1144 END IF 1145 IF ((h2b .le. h1b)) THEN 1146 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 1147 &,int_mb(k_range+h11b-1),int_mb(k_range+h10b-1),int_mb(k_range+h1b- 1148 &1),3,2,1,4,-1.0d0) 1149 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1150 & 1 + noab * (h2b - 1 + noab * (h11b - 1 + noab * (h10b - 1))))) 1151 END IF 1152 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_2_2',10,MA_ER 1153 &R) 1154 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_2_2',11, 1155 &MA_ERR) 1156 END IF 1157 END IF 1158 END IF 1159 next = NXTASK(nprocs,1) 1160 END IF 1161 count = count + 1 1162 END DO 1163 END DO 1164 END DO 1165 END DO 1166 next = NXTASK(-nprocs,1) 1167 call GA_SYNC() 1168 RETURN 1169 END 1170 SUBROUTINE ccsdt_t2a_2_2_2_1(d_a,k_a_offset,d_c,k_c_offset) 1171C $Id$ 1172C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1173C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1174C i3 ( h10 h11 h1 p5 )_v + = 1 * v ( h10 h11 h1 p5 )_v 1175 IMPLICIT NONE 1176#include "global.fh" 1177#include "mafdecls.fh" 1178#include "sym.fh" 1179#include "errquit.fh" 1180#include "tce.fh" 1181 INTEGER d_a 1182 INTEGER k_a_offset 1183 INTEGER d_c 1184 INTEGER k_c_offset 1185 INTEGER NXTASK 1186 INTEGER next 1187 INTEGER nprocs 1188 INTEGER count 1189 INTEGER h10b 1190 INTEGER h11b 1191 INTEGER h1b 1192 INTEGER p5b 1193 INTEGER dimc 1194 INTEGER h10b_1 1195 INTEGER h11b_1 1196 INTEGER h1b_1 1197 INTEGER p5b_1 1198 INTEGER dim_common 1199 INTEGER dima_sort 1200 INTEGER dima 1201 INTEGER l_a_sort 1202 INTEGER k_a_sort 1203 INTEGER l_a 1204 INTEGER k_a 1205 INTEGER l_c 1206 INTEGER k_c 1207 EXTERNAL NXTASK 1208 nprocs = GA_NNODES() 1209 count = 0 1210 next = NXTASK(nprocs,1) 1211 DO h10b = 1,noab 1212 DO h11b = h10b,noab 1213 DO h1b = 1,noab 1214 DO p5b = noab+1,noab+nvab 1215 IF (next.eq.count) THEN 1216 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b 1217 &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1218 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin 1219 &+h1b-1)+int_mb(k_spin+p5b-1)) THEN 1220 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m 1221 &b(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 1222 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_mb(k_ 1223 &range+h1b-1) * int_mb(k_range+p5b-1) 1224 CALL TCE_RESTRICTED_4(h10b,h11b,h1b,p5b,h10b_1,h11b_1,h1b_1,p5b_1) 1225 dim_common = 1 1226 dima_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_ 1227 &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 1228 dima = dim_common * dima_sort 1229 IF (dima .gt. 0) THEN 1230 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1231 & ERRQUIT('ccsdt_t2_2_2_2_1',0,MA_ERR) 1232 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1233 &ccsdt_t2_2_2_2_1',1,MA_ERR) 1234 IF ((h1b .le. p5b)) THEN 1235 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 1236 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa 1237 &b+nvab) * (h10b_1 - 1))))) 1238 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1 1239 &),int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b- 1240 &1),4,3,2,1,1.0d0) 1241 END IF 1242 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_2_2_1',2,MA_E 1243 &RR) 1244 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1245 &ccsdt_t2_2_2_2_1',3,MA_ERR) 1246 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 1247 &,int_mb(k_range+h1b-1),int_mb(k_range+h11b-1),int_mb(k_range+h10b- 1248 &1),4,3,2,1,1.0d0) 1249 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 1250 & noab - 1 + nvab * (h1b - 1 + noab * (h11b - 1 + noab * (h10b - 1) 1251 &)))) 1252 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_2_2_1',4,MA_E 1253 &RR) 1254 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_2_2_1',5 1255 &,MA_ERR) 1256 END IF 1257 END IF 1258 END IF 1259 END IF 1260 next = NXTASK(nprocs,1) 1261 END IF 1262 count = count + 1 1263 END DO 1264 END DO 1265 END DO 1266 END DO 1267 next = NXTASK(-nprocs,1) 1268 call GA_SYNC() 1269 RETURN 1270 END 1271 SUBROUTINE OFFSET_ccsdt_t2a_2_2_2_1(l_a_offset,k_a_offset,size) 1272C $Id$ 1273C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1274C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1275C i3 ( h10 h11 h1 p5 )_v 1276 IMPLICIT NONE 1277#include "global.fh" 1278#include "mafdecls.fh" 1279#include "sym.fh" 1280#include "errquit.fh" 1281#include "tce.fh" 1282 INTEGER l_a_offset 1283 INTEGER k_a_offset 1284 INTEGER size 1285 INTEGER length 1286 INTEGER addr 1287 INTEGER h10b 1288 INTEGER h11b 1289 INTEGER h1b 1290 INTEGER p5b 1291 length = 0 1292 DO h10b = 1,noab 1293 DO h11b = h10b,noab 1294 DO h1b = 1,noab 1295 DO p5b = noab+1,noab+nvab 1296 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin 1297 &+h1b-1)+int_mb(k_spin+p5b-1)) THEN 1298 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m 1299 &b(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 1300 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b 1301 &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1302 length = length + 1 1303 END IF 1304 END IF 1305 END IF 1306 END DO 1307 END DO 1308 END DO 1309 END DO 1310 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1311 &set)) CALL ERRQUIT('ccsdt_t2_2_2_2_1',0,MA_ERR) 1312 int_mb(k_a_offset) = length 1313 addr = 0 1314 size = 0 1315 DO h10b = 1,noab 1316 DO h11b = h10b,noab 1317 DO h1b = 1,noab 1318 DO p5b = noab+1,noab+nvab 1319 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin 1320 &+h1b-1)+int_mb(k_spin+p5b-1)) THEN 1321 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m 1322 &b(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 1323 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b 1324 &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1325 addr = addr + 1 1326 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 1327 &* (h11b - 1 + noab * (h10b - 1))) 1328 int_mb(k_a_offset+length+addr) = size 1329 size = size + int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * in 1330 &t_mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 1331 END IF 1332 END IF 1333 END IF 1334 END DO 1335 END DO 1336 END DO 1337 END DO 1338 RETURN 1339 END 1340 SUBROUTINE ccsdt_t2a_2_2_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 1341 &k_c_offset) 1342C $Id$ 1343C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1344C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1345C i3 ( h10 h11 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h10 h11 p5 p6 )_v 1346 IMPLICIT NONE 1347#include "global.fh" 1348#include "mafdecls.fh" 1349#include "sym.fh" 1350#include "errquit.fh" 1351#include "tce.fh" 1352 INTEGER d_a 1353 INTEGER k_a_offset 1354 INTEGER d_b 1355 INTEGER k_b_offset 1356 INTEGER d_c 1357 INTEGER k_c_offset 1358 INTEGER NXTASK 1359 INTEGER next 1360 INTEGER nprocs 1361 INTEGER count 1362 INTEGER h10b 1363 INTEGER h11b 1364 INTEGER h1b 1365 INTEGER p5b 1366 INTEGER dimc 1367 INTEGER l_c_sort 1368 INTEGER k_c_sort 1369 INTEGER p6b 1370 INTEGER p6b_1 1371 INTEGER h1b_1 1372 INTEGER h10b_2 1373 INTEGER h11b_2 1374 INTEGER p5b_2 1375 INTEGER p6b_2 1376 INTEGER dim_common 1377 INTEGER dima_sort 1378 INTEGER dima 1379 INTEGER dimb_sort 1380 INTEGER dimb 1381 INTEGER l_a_sort 1382 INTEGER k_a_sort 1383 INTEGER l_a 1384 INTEGER k_a 1385 INTEGER l_b_sort 1386 INTEGER k_b_sort 1387 INTEGER l_b 1388 INTEGER k_b 1389 INTEGER l_c 1390 INTEGER k_c 1391 EXTERNAL NXTASK 1392 nprocs = GA_NNODES() 1393 count = 0 1394 next = NXTASK(nprocs,1) 1395 DO h10b = 1,noab 1396 DO h11b = h10b,noab 1397 DO h1b = 1,noab 1398 DO p5b = noab+1,noab+nvab 1399 IF (next.eq.count) THEN 1400 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b 1401 &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1402 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin 1403 &+h1b-1)+int_mb(k_spin+p5b-1)) THEN 1404 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m 1405 &b(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) 1406 &THEN 1407 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_mb(k_ 1408 &range+h1b-1) * int_mb(k_range+p5b-1) 1409 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1410 & ERRQUIT('ccsdt_t2_2_2_2_2',0,MA_ERR) 1411 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1412 DO p6b = noab+1,noab+nvab 1413 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1414 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 1415 &EN 1416 CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1) 1417 CALL TCE_RESTRICTED_4(h10b,h11b,p5b,p6b,h10b_2,h11b_2,p5b_2,p6b_2) 1418 dim_common = int_mb(k_range+p6b-1) 1419 dima_sort = int_mb(k_range+h1b-1) 1420 dima = dim_common * dima_sort 1421 dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_ 1422 &mb(k_range+p5b-1) 1423 dimb = dim_common * dimb_sort 1424 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1425 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1426 & ERRQUIT('ccsdt_t2_2_2_2_2',1,MA_ERR) 1427 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1428 &ccsdt_t2_2_2_2_2',2,MA_ERR) 1429 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1430 & - 1 + noab * (p6b_1 - noab - 1))) 1431 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 1432 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1433 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_2_2_2',3,MA_E 1434 &RR) 1435 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1436 & ERRQUIT('ccsdt_t2_2_2_2_2',4,MA_ERR) 1437 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1438 &ccsdt_t2_2_2_2_2',5,MA_ERR) 1439 IF ((p6b .lt. p5b)) THEN 1440 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1441 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa 1442 &b+nvab) * (h10b_2 - 1))))) 1443 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 1444 &),int_mb(k_range+h11b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b- 1445 &1),4,2,1,3,-1.0d0) 1446 END IF 1447 IF ((p5b .le. p6b)) THEN 1448 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 1449 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa 1450 &b+nvab) * (h10b_2 - 1))))) 1451 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 1452 &),int_mb(k_range+h11b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b- 1453 &1),3,2,1,4,1.0d0) 1454 END IF 1455 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_2_2_2',6,MA_E 1456 &RR) 1457 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1458 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1459 &t),dima_sort) 1460 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_2_2_2',7 1461 &,MA_ERR) 1462 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_2_2_2',8 1463 &,MA_ERR) 1464 END IF 1465 END IF 1466 END IF 1467 END DO 1468 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1469 &ccsdt_t2_2_2_2_2',9,MA_ERR) 1470 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 1471 &,int_mb(k_range+h11b-1),int_mb(k_range+h10b-1),int_mb(k_range+h1b- 1472 &1),3,2,4,1,-1.0d0/2.0d0) 1473 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 1474 & noab - 1 + nvab * (h1b - 1 + noab * (h11b - 1 + noab * (h10b - 1) 1475 &)))) 1476 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_2_2_2',10,MA_ 1477 &ERR) 1478 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_2_2_2',1 1479 &1,MA_ERR) 1480 END IF 1481 END IF 1482 END IF 1483 next = NXTASK(nprocs,1) 1484 END IF 1485 count = count + 1 1486 END DO 1487 END DO 1488 END DO 1489 END DO 1490 next = NXTASK(-nprocs,1) 1491 call GA_SYNC() 1492 RETURN 1493 END 1494 SUBROUTINE ccsdt_t2a_2_2_3(d_a,k_a_offset,d_b,k_b_offset,d_c, 1495 &k_c_offset) 1496C $Id$ 1497C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1498C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1499C i2 ( h10 h11 h1 h2 )_vt + = -1/2 * Sum ( p7 p8 ) * t ( p7 p8 h1 h2 )_t * v ( h10 h11 p7 p8 )_v 1500 IMPLICIT NONE 1501#include "global.fh" 1502#include "mafdecls.fh" 1503#include "sym.fh" 1504#include "errquit.fh" 1505#include "tce.fh" 1506 INTEGER d_a 1507 INTEGER k_a_offset 1508 INTEGER d_b 1509 INTEGER k_b_offset 1510 INTEGER d_c 1511 INTEGER k_c_offset 1512 INTEGER NXTASK 1513 INTEGER next 1514 INTEGER nprocs 1515 INTEGER count 1516 INTEGER h10b 1517 INTEGER h11b 1518 INTEGER h1b 1519 INTEGER h2b 1520 INTEGER dimc 1521 INTEGER l_c_sort 1522 INTEGER k_c_sort 1523 INTEGER p7b 1524 INTEGER p8b 1525 INTEGER p7b_1 1526 INTEGER p8b_1 1527 INTEGER h1b_1 1528 INTEGER h2b_1 1529 INTEGER h10b_2 1530 INTEGER h11b_2 1531 INTEGER p7b_2 1532 INTEGER p8b_2 1533 INTEGER dim_common 1534 INTEGER dima_sort 1535 INTEGER dima 1536 INTEGER dimb_sort 1537 INTEGER dimb 1538 INTEGER l_a_sort 1539 INTEGER k_a_sort 1540 INTEGER l_a 1541 INTEGER k_a 1542 INTEGER l_b_sort 1543 INTEGER k_b_sort 1544 INTEGER l_b 1545 INTEGER k_b 1546 INTEGER nsuperp(2) 1547 INTEGER isuperp 1548 INTEGER l_c 1549 INTEGER k_c 1550 DOUBLE PRECISION FACTORIAL 1551 EXTERNAL NXTASK 1552 EXTERNAL FACTORIAL 1553 nprocs = GA_NNODES() 1554 count = 0 1555 next = NXTASK(nprocs,1) 1556 DO h10b = 1,noab 1557 DO h11b = h10b,noab 1558 DO h1b = 1,noab 1559 DO h2b = h1b,noab 1560 IF (next.eq.count) THEN 1561 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b 1562 &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1563 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin 1564 &+h1b-1)+int_mb(k_spin+h2b-1)) THEN 1565 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m 1566 &b(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) 1567 &THEN 1568 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_mb(k_ 1569 &range+h1b-1) * int_mb(k_range+h2b-1) 1570 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1571 & ERRQUIT('ccsdt_t2_2_2_3',0,MA_ERR) 1572 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1573 DO p7b = noab+1,noab+nvab 1574 DO p8b = p7b,noab+nvab 1575 IF (int_mb(k_spin+p7b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h 1576 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1577 IF (ieor(int_mb(k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb( 1578 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 1579 CALL TCE_RESTRICTED_4(p7b,p8b,h1b,h2b,p7b_1,p8b_1,h1b_1,h2b_1) 1580 CALL TCE_RESTRICTED_4(h10b,h11b,p7b,p8b,h10b_2,h11b_2,p7b_2,p8b_2) 1581 dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+p8b-1) 1582 dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 1583 dima = dim_common * dima_sort 1584 dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) 1585 dimb = dim_common * dimb_sort 1586 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1587 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1588 & ERRQUIT('ccsdt_t2_2_2_3',1,MA_ERR) 1589 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1590 &ccsdt_t2_2_2_3',2,MA_ERR) 1591 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 1592 & - 1 + noab * (h1b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p7b_ 1593 &1 - noab - 1))))) 1594 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 1595 &,int_mb(k_range+p8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 1596 &,4,3,2,1,1.0d0) 1597 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_2_3',3,MA_ERR 1598 &) 1599 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1600 & ERRQUIT('ccsdt_t2_2_2_3',4,MA_ERR) 1601 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1602 &ccsdt_t2_2_2_3',5,MA_ERR) 1603 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 1604 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa 1605 &b+nvab) * (h10b_2 - 1))))) 1606 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 1607 &),int_mb(k_range+h11b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b- 1608 &1),2,1,4,3,1.0d0) 1609 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_2_3',6,MA_ERR 1610 &) 1611 nsuperp(1) = 1 1612 nsuperp(2) = 1 1613 isuperp = 1 1614 IF (p7b .eq. p8b) THEN 1615 nsuperp(isuperp) = nsuperp(isuperp) + 1 1616 ELSE 1617 isuperp = isuperp + 1 1618 END IF 1619 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 1620 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 1621 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 1622 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_2_3',7,M 1623 &A_ERR) 1624 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_2_3',8,M 1625 &A_ERR) 1626 END IF 1627 END IF 1628 END IF 1629 END DO 1630 END DO 1631 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1632 &ccsdt_t2_2_2_3',9,MA_ERR) 1633 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h11b-1 1634 &),int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b- 1635 &1),2,1,4,3,-1.0d0/2.0d0) 1636 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1637 & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h10b - 1))))) 1638 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_2_3',10,MA_ER 1639 &R) 1640 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_2_3',11, 1641 &MA_ERR) 1642 END IF 1643 END IF 1644 END IF 1645 next = NXTASK(nprocs,1) 1646 END IF 1647 count = count + 1 1648 END DO 1649 END DO 1650 END DO 1651 END DO 1652 next = NXTASK(-nprocs,1) 1653 call GA_SYNC() 1654 RETURN 1655 END 1656 SUBROUTINE ccsdt_t2a_2_3(d_a,k_a_offset,d_b,k_b_offset,d_c, 1657 &k_c_offset) 1658C $Id$ 1659C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1660C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1661C i1 ( h10 p3 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h10 p3 h2 p5 )_v 1662 IMPLICIT NONE 1663#include "global.fh" 1664#include "mafdecls.fh" 1665#include "sym.fh" 1666#include "errquit.fh" 1667#include "tce.fh" 1668 INTEGER d_a 1669 INTEGER k_a_offset 1670 INTEGER d_b 1671 INTEGER k_b_offset 1672 INTEGER d_c 1673 INTEGER k_c_offset 1674 INTEGER NXTASK 1675 INTEGER next 1676 INTEGER nprocs 1677 INTEGER count 1678 INTEGER p3b 1679 INTEGER h10b 1680 INTEGER h1b 1681 INTEGER h2b 1682 INTEGER dimc 1683 INTEGER l_c_sort 1684 INTEGER k_c_sort 1685 INTEGER p5b 1686 INTEGER p5b_1 1687 INTEGER h1b_1 1688 INTEGER p3b_2 1689 INTEGER h10b_2 1690 INTEGER h2b_2 1691 INTEGER p5b_2 1692 INTEGER dim_common 1693 INTEGER dima_sort 1694 INTEGER dima 1695 INTEGER dimb_sort 1696 INTEGER dimb 1697 INTEGER l_a_sort 1698 INTEGER k_a_sort 1699 INTEGER l_a 1700 INTEGER k_a 1701 INTEGER l_b_sort 1702 INTEGER k_b_sort 1703 INTEGER l_b 1704 INTEGER k_b 1705 INTEGER l_c 1706 INTEGER k_c 1707 EXTERNAL NXTASK 1708 nprocs = GA_NNODES() 1709 count = 0 1710 next = NXTASK(nprocs,1) 1711 DO p3b = noab+1,noab+nvab 1712 DO h10b = 1,noab 1713 DO h1b = 1,noab 1714 DO h2b = 1,noab 1715 IF (next.eq.count) THEN 1716 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 1717 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1718 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 1719 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 1720 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 1721 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 1722 &HEN 1723 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 1724 &ange+h1b-1) * int_mb(k_range+h2b-1) 1725 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1726 & ERRQUIT('ccsdt_t2_2_3',0,MA_ERR) 1727 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1728 DO p5b = noab+1,noab+nvab 1729 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1730 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 1731 &EN 1732 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 1733 CALL TCE_RESTRICTED_4(p3b,h10b,h2b,p5b,p3b_2,h10b_2,h2b_2,p5b_2) 1734 dim_common = int_mb(k_range+p5b-1) 1735 dima_sort = int_mb(k_range+h1b-1) 1736 dima = dim_common * dima_sort 1737 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_m 1738 &b(k_range+h2b-1) 1739 dimb = dim_common * dimb_sort 1740 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1741 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1742 & ERRQUIT('ccsdt_t2_2_3',1,MA_ERR) 1743 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1744 &ccsdt_t2_2_3',2,MA_ERR) 1745 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1746 & - 1 + noab * (p5b_1 - noab - 1))) 1747 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1748 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1749 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_3',3,MA_ERR) 1750 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1751 & ERRQUIT('ccsdt_t2_2_3',4,MA_ERR) 1752 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1753 &ccsdt_t2_2_3',5,MA_ERR) 1754 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1755 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h10b_2 - 1 + noab * (p3b 1756 &_2 - noab - 1))))) 1757 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1) 1758 &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1 1759 &),3,2,1,4,1.0d0) 1760 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_3',6,MA_ERR) 1761 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1762 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1763 &t),dima_sort) 1764 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_3',7,MA_ 1765 &ERR) 1766 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_3',8,MA_ 1767 &ERR) 1768 END IF 1769 END IF 1770 END IF 1771 END DO 1772 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1773 &ccsdt_t2_2_3',9,MA_ERR) 1774 IF ((h1b .le. h2b)) THEN 1775 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 1776 &,int_mb(k_range+h10b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1 1777 &),3,2,4,1,-1.0d0) 1778 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1779 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 1780 &))) 1781 END IF 1782 IF ((h2b .le. h1b)) THEN 1783 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 1784 &,int_mb(k_range+h10b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1 1785 &),3,2,1,4,1.0d0) 1786 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1787 & 1 + noab * (h2b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 1788 &))) 1789 END IF 1790 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_3',10,MA_ERR) 1791 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_3',11,MA 1792 &_ERR) 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 END DO 1802 END DO 1803 next = NXTASK(-nprocs,1) 1804 call GA_SYNC() 1805 RETURN 1806 END 1807 SUBROUTINE ccsdt_t2a_2_3_1(d_a,k_a_offset,d_c,k_c_offset) 1808C $Id$ 1809C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1810C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1811C i2 ( h10 p3 h1 p5 )_v + = 1 * v ( h10 p3 h1 p5 )_v 1812 IMPLICIT NONE 1813#include "global.fh" 1814#include "mafdecls.fh" 1815#include "sym.fh" 1816#include "errquit.fh" 1817#include "tce.fh" 1818 INTEGER d_a 1819 INTEGER k_a_offset 1820 INTEGER d_c 1821 INTEGER k_c_offset 1822 INTEGER NXTASK 1823 INTEGER next 1824 INTEGER nprocs 1825 INTEGER count 1826 INTEGER p3b 1827 INTEGER h10b 1828 INTEGER h1b 1829 INTEGER p5b 1830 INTEGER dimc 1831 INTEGER p3b_1 1832 INTEGER h10b_1 1833 INTEGER h1b_1 1834 INTEGER p5b_1 1835 INTEGER dim_common 1836 INTEGER dima_sort 1837 INTEGER dima 1838 INTEGER l_a_sort 1839 INTEGER k_a_sort 1840 INTEGER l_a 1841 INTEGER k_a 1842 INTEGER l_c 1843 INTEGER k_c 1844 EXTERNAL NXTASK 1845 nprocs = GA_NNODES() 1846 count = 0 1847 next = NXTASK(nprocs,1) 1848 DO p3b = noab+1,noab+nvab 1849 DO h10b = 1,noab 1850 DO h1b = 1,noab 1851 DO p5b = noab+1,noab+nvab 1852 IF (next.eq.count) THEN 1853 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 1854 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1855 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 1856 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 1857 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 1858 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 1859 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 1860 &ange+h1b-1) * int_mb(k_range+p5b-1) 1861 CALL TCE_RESTRICTED_4(p3b,h10b,h1b,p5b,p3b_1,h10b_1,h1b_1,p5b_1) 1862 dim_common = 1 1863 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_m 1864 &b(k_range+h1b-1) * int_mb(k_range+p5b-1) 1865 dima = dim_common * dima_sort 1866 IF (dima .gt. 0) THEN 1867 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1868 & ERRQUIT('ccsdt_t2_2_3_1',0,MA_ERR) 1869 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1870 &ccsdt_t2_2_3_1',1,MA_ERR) 1871 IF ((h10b .le. p3b) .and. (h1b .le. p5b)) THEN 1872 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 1873 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab 1874 &+nvab) * (h10b_1 - 1))))) 1875 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1 1876 &),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1 1877 &),4,3,1,2,1.0d0) 1878 END IF 1879 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_3_1',2,MA_ERR 1880 &) 1881 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1882 &ccsdt_t2_2_3_1',3,MA_ERR) 1883 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 1884 &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+p3b-1 1885 &),4,3,2,1,1.0d0) 1886 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 1887 & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noa 1888 &b - 1))))) 1889 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_3_1',4,MA_ERR 1890 &) 1891 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_3_1',5,M 1892 &A_ERR) 1893 END IF 1894 END IF 1895 END IF 1896 END IF 1897 next = NXTASK(nprocs,1) 1898 END IF 1899 count = count + 1 1900 END DO 1901 END DO 1902 END DO 1903 END DO 1904 next = NXTASK(-nprocs,1) 1905 call GA_SYNC() 1906 RETURN 1907 END 1908 SUBROUTINE OFFSET_ccsdt_t2a_2_3_1(l_a_offset,k_a_offset,size) 1909C $Id$ 1910C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1911C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1912C i2 ( h10 p3 h1 p5 )_v 1913 IMPLICIT NONE 1914#include "global.fh" 1915#include "mafdecls.fh" 1916#include "sym.fh" 1917#include "errquit.fh" 1918#include "tce.fh" 1919 INTEGER l_a_offset 1920 INTEGER k_a_offset 1921 INTEGER size 1922 INTEGER length 1923 INTEGER addr 1924 INTEGER p3b 1925 INTEGER h10b 1926 INTEGER h1b 1927 INTEGER p5b 1928 length = 0 1929 DO p3b = noab+1,noab+nvab 1930 DO h10b = 1,noab 1931 DO h1b = 1,noab 1932 DO p5b = noab+1,noab+nvab 1933 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+ 1934 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 1935 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb 1936 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 1937 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b- 1938 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1939 length = length + 1 1940 END IF 1941 END IF 1942 END IF 1943 END DO 1944 END DO 1945 END DO 1946 END DO 1947 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1948 &set)) CALL ERRQUIT('ccsdt_t2_2_3_1',0,MA_ERR) 1949 int_mb(k_a_offset) = length 1950 addr = 0 1951 size = 0 1952 DO p3b = noab+1,noab+nvab 1953 DO h10b = 1,noab 1954 DO h1b = 1,noab 1955 DO p5b = noab+1,noab+nvab 1956 IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+ 1957 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 1958 IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb 1959 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 1960 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b- 1961 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1962 addr = addr + 1 1963 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 1964 &* (h10b - 1 + noab * (p3b - noab - 1))) 1965 int_mb(k_a_offset+length+addr) = size 1966 size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int 1967 &_mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 1968 END IF 1969 END IF 1970 END IF 1971 END DO 1972 END DO 1973 END DO 1974 END DO 1975 RETURN 1976 END 1977 SUBROUTINE ccsdt_t2a_2_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 1978 &k_c_offset) 1979C $Id$ 1980C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1981C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1982C i2 ( h10 p3 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h10 p3 p5 p6 )_v 1983 IMPLICIT NONE 1984#include "global.fh" 1985#include "mafdecls.fh" 1986#include "sym.fh" 1987#include "errquit.fh" 1988#include "tce.fh" 1989 INTEGER d_a 1990 INTEGER k_a_offset 1991 INTEGER d_b 1992 INTEGER k_b_offset 1993 INTEGER d_c 1994 INTEGER k_c_offset 1995 INTEGER NXTASK 1996 INTEGER next 1997 INTEGER nprocs 1998 INTEGER count 1999 INTEGER p3b 2000 INTEGER h10b 2001 INTEGER h1b 2002 INTEGER p5b 2003 INTEGER dimc 2004 INTEGER l_c_sort 2005 INTEGER k_c_sort 2006 INTEGER p6b 2007 INTEGER p6b_1 2008 INTEGER h1b_1 2009 INTEGER p3b_2 2010 INTEGER h10b_2 2011 INTEGER p5b_2 2012 INTEGER p6b_2 2013 INTEGER dim_common 2014 INTEGER dima_sort 2015 INTEGER dima 2016 INTEGER dimb_sort 2017 INTEGER dimb 2018 INTEGER l_a_sort 2019 INTEGER k_a_sort 2020 INTEGER l_a 2021 INTEGER k_a 2022 INTEGER l_b_sort 2023 INTEGER k_b_sort 2024 INTEGER l_b 2025 INTEGER k_b 2026 INTEGER l_c 2027 INTEGER k_c 2028 EXTERNAL NXTASK 2029 nprocs = GA_NNODES() 2030 count = 0 2031 next = NXTASK(nprocs,1) 2032 DO p3b = noab+1,noab+nvab 2033 DO h10b = 1,noab 2034 DO h1b = 1,noab 2035 DO p5b = noab+1,noab+nvab 2036 IF (next.eq.count) THEN 2037 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 2038 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 2039 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 2040 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 2041 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 2042 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) T 2043 &HEN 2044 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 2045 &ange+h1b-1) * int_mb(k_range+p5b-1) 2046 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2047 & ERRQUIT('ccsdt_t2_2_3_2',0,MA_ERR) 2048 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2049 DO p6b = noab+1,noab+nvab 2050 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2051 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 2052 &EN 2053 CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1) 2054 CALL TCE_RESTRICTED_4(p3b,h10b,p5b,p6b,p3b_2,h10b_2,p5b_2,p6b_2) 2055 dim_common = int_mb(k_range+p6b-1) 2056 dima_sort = int_mb(k_range+h1b-1) 2057 dima = dim_common * dima_sort 2058 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_m 2059 &b(k_range+p5b-1) 2060 dimb = dim_common * dimb_sort 2061 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2062 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2063 & ERRQUIT('ccsdt_t2_2_3_2',1,MA_ERR) 2064 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2065 &ccsdt_t2_2_3_2',2,MA_ERR) 2066 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2067 & - 1 + noab * (p6b_1 - noab - 1))) 2068 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 2069 &,int_mb(k_range+h1b-1),2,1,1.0d0) 2070 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_3_2',3,MA_ERR 2071 &) 2072 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2073 & ERRQUIT('ccsdt_t2_2_3_2',4,MA_ERR) 2074 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2075 &ccsdt_t2_2_3_2',5,MA_ERR) 2076 IF ((h10b .le. p3b) .and. (p6b .lt. p5b)) THEN 2077 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 2078 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 2079 &+nvab) * (h10b_2 - 1))))) 2080 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 2081 &),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1 2082 &),4,1,2,3,-1.0d0) 2083 END IF 2084 IF ((h10b .le. p3b) .and. (p5b .le. p6b)) THEN 2085 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 2086 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 2087 &+nvab) * (h10b_2 - 1))))) 2088 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 2089 &),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 2090 &),3,1,2,4,1.0d0) 2091 END IF 2092 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_3_2',6,MA_ERR 2093 &) 2094 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2095 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2096 &t),dima_sort) 2097 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_3_2',7,M 2098 &A_ERR) 2099 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_3_2',8,M 2100 &A_ERR) 2101 END IF 2102 END IF 2103 END IF 2104 END DO 2105 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2106 &ccsdt_t2_2_3_2',9,MA_ERR) 2107 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 2108 &,int_mb(k_range+h10b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1 2109 &),3,2,4,1,-1.0d0/2.0d0) 2110 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 2111 & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noa 2112 &b - 1))))) 2113 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_3_2',10,MA_ER 2114 &R) 2115 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_3_2',11, 2116 &MA_ERR) 2117 END IF 2118 END IF 2119 END IF 2120 next = NXTASK(nprocs,1) 2121 END IF 2122 count = count + 1 2123 END DO 2124 END DO 2125 END DO 2126 END DO 2127 next = NXTASK(-nprocs,1) 2128 call GA_SYNC() 2129 RETURN 2130 END 2131 SUBROUTINE ccsdt_t2a_2_4(d_a,k_a_offset,d_b,k_b_offset,d_c, 2132 &k_c_offset) 2133C $Id$ 2134C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2135C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2136C i1 ( h10 p3 h1 h2 )_ft + = -1 * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i2 ( h10 p5 )_f 2137 IMPLICIT NONE 2138#include "global.fh" 2139#include "mafdecls.fh" 2140#include "sym.fh" 2141#include "errquit.fh" 2142#include "tce.fh" 2143 INTEGER d_a 2144 INTEGER k_a_offset 2145 INTEGER d_b 2146 INTEGER k_b_offset 2147 INTEGER d_c 2148 INTEGER k_c_offset 2149 INTEGER NXTASK 2150 INTEGER next 2151 INTEGER nprocs 2152 INTEGER count 2153 INTEGER p3b 2154 INTEGER h10b 2155 INTEGER h1b 2156 INTEGER h2b 2157 INTEGER dimc 2158 INTEGER l_c_sort 2159 INTEGER k_c_sort 2160 INTEGER p5b 2161 INTEGER p3b_1 2162 INTEGER p5b_1 2163 INTEGER h1b_1 2164 INTEGER h2b_1 2165 INTEGER h10b_2 2166 INTEGER p5b_2 2167 INTEGER dim_common 2168 INTEGER dima_sort 2169 INTEGER dima 2170 INTEGER dimb_sort 2171 INTEGER dimb 2172 INTEGER l_a_sort 2173 INTEGER k_a_sort 2174 INTEGER l_a 2175 INTEGER k_a 2176 INTEGER l_b_sort 2177 INTEGER k_b_sort 2178 INTEGER l_b 2179 INTEGER k_b 2180 INTEGER l_c 2181 INTEGER k_c 2182 EXTERNAL NXTASK 2183 nprocs = GA_NNODES() 2184 count = 0 2185 next = NXTASK(nprocs,1) 2186 DO p3b = noab+1,noab+nvab 2187 DO h10b = 1,noab 2188 DO h1b = 1,noab 2189 DO h2b = h1b,noab 2190 IF (next.eq.count) THEN 2191 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 2192 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 2193 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 2194 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 2195 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 2196 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_f,irrep_t)) T 2197 &HEN 2198 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 2199 &ange+h1b-1) * int_mb(k_range+h2b-1) 2200 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2201 & ERRQUIT('ccsdt_t2_2_4',0,MA_ERR) 2202 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2203 DO p5b = noab+1,noab+nvab 2204 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 2205 &1b-1)+int_mb(k_spin+h2b-1)) THEN 2206 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 2207 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 2208 CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h2b,p3b_1,p5b_1,h1b_1,h2b_1) 2209 CALL TCE_RESTRICTED_2(h10b,p5b,h10b_2,p5b_2) 2210 dim_common = int_mb(k_range+p5b-1) 2211 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb 2212 &(k_range+h2b-1) 2213 dima = dim_common * dima_sort 2214 dimb_sort = int_mb(k_range+h10b-1) 2215 dimb = dim_common * dimb_sort 2216 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2217 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2218 & ERRQUIT('ccsdt_t2_2_4',1,MA_ERR) 2219 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2220 &ccsdt_t2_2_4',2,MA_ERR) 2221 IF ((p5b .lt. p3b)) THEN 2222 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 2223 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 2224 &1 - noab - 1))))) 2225 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 2226 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 2227 &,4,3,2,1,-1.0d0) 2228 END IF 2229 IF ((p3b .le. p5b)) THEN 2230 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 2231 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 2232 &1 - noab - 1))))) 2233 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2234 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 2235 &,4,3,1,2,1.0d0) 2236 END IF 2237 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_4',3,MA_ERR) 2238 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2239 & ERRQUIT('ccsdt_t2_2_4',4,MA_ERR) 2240 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2241 &ccsdt_t2_2_4',5,MA_ERR) 2242 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 2243 & - noab - 1 + nvab * (h10b_2 - 1))) 2244 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 2245 &),int_mb(k_range+p5b-1),1,2,1.0d0) 2246 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_4',6,MA_ERR) 2247 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2248 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2249 &t),dima_sort) 2250 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_4',7,MA_ 2251 &ERR) 2252 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_4',8,MA_ 2253 &ERR) 2254 END IF 2255 END IF 2256 END IF 2257 END DO 2258 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2259 &ccsdt_t2_2_4',9,MA_ERR) 2260 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1 2261 &),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1 2262 &),4,1,3,2,-1.0d0) 2263 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 2264 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 2265 &))) 2266 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_4',10,MA_ERR) 2267 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_4',11,MA 2268 &_ERR) 2269 END IF 2270 END IF 2271 END IF 2272 next = NXTASK(nprocs,1) 2273 END IF 2274 count = count + 1 2275 END DO 2276 END DO 2277 END DO 2278 END DO 2279 next = NXTASK(-nprocs,1) 2280 call GA_SYNC() 2281 RETURN 2282 END 2283 SUBROUTINE ccsdt_t2a_2_4_1(d_a,k_a_offset,d_c,k_c_offset) 2284C $Id$ 2285C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2286C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2287C i2 ( h10 p5 )_f + = 1 * f ( h10 p5 )_f 2288 IMPLICIT NONE 2289#include "global.fh" 2290#include "mafdecls.fh" 2291#include "sym.fh" 2292#include "errquit.fh" 2293#include "tce.fh" 2294 INTEGER d_a 2295 INTEGER k_a_offset 2296 INTEGER d_c 2297 INTEGER k_c_offset 2298 INTEGER NXTASK 2299 INTEGER next 2300 INTEGER nprocs 2301 INTEGER count 2302 INTEGER h10b 2303 INTEGER p5b 2304 INTEGER dimc 2305 INTEGER h10b_1 2306 INTEGER p5b_1 2307 INTEGER dim_common 2308 INTEGER dima_sort 2309 INTEGER dima 2310 INTEGER l_a_sort 2311 INTEGER k_a_sort 2312 INTEGER l_a 2313 INTEGER k_a 2314 INTEGER l_c 2315 INTEGER k_c 2316 EXTERNAL NXTASK 2317 nprocs = GA_NNODES() 2318 count = 0 2319 next = NXTASK(nprocs,1) 2320 DO h10b = 1,noab 2321 DO p5b = noab+1,noab+nvab 2322 IF (next.eq.count) THEN 2323 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b- 2324 &1).ne.4)) THEN 2325 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN 2326 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T 2327 &HEN 2328 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1) 2329 CALL TCE_RESTRICTED_2(h10b,p5b,h10b_1,p5b_1) 2330 dim_common = 1 2331 dima_sort = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1) 2332 dima = dim_common * dima_sort 2333 IF (dima .gt. 0) THEN 2334 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2335 & ERRQUIT('ccsdt_t2_2_4_1',0,MA_ERR) 2336 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2337 &ccsdt_t2_2_4_1',1,MA_ERR) 2338 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 2339 & - 1 + (noab+nvab) * (h10b_1 - 1))) 2340 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1 2341 &),int_mb(k_range+p5b-1),2,1,1.0d0) 2342 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_4_1',2,MA_ERR 2343 &) 2344 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2345 &ccsdt_t2_2_4_1',3,MA_ERR) 2346 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 2347 &,int_mb(k_range+h10b-1),2,1,1.0d0) 2348 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 2349 & noab - 1 + nvab * (h10b - 1))) 2350 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_4_1',4,MA_ERR 2351 &) 2352 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_4_1',5,M 2353 &A_ERR) 2354 END IF 2355 END IF 2356 END IF 2357 END IF 2358 next = NXTASK(nprocs,1) 2359 END IF 2360 count = count + 1 2361 END DO 2362 END DO 2363 next = NXTASK(-nprocs,1) 2364 call GA_SYNC() 2365 RETURN 2366 END 2367 SUBROUTINE OFFSET_ccsdt_t2a_2_4_1(l_a_offset,k_a_offset,size) 2368C $Id$ 2369C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2370C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2371C i2 ( h10 p5 )_f 2372 IMPLICIT NONE 2373#include "global.fh" 2374#include "mafdecls.fh" 2375#include "sym.fh" 2376#include "errquit.fh" 2377#include "tce.fh" 2378 INTEGER l_a_offset 2379 INTEGER k_a_offset 2380 INTEGER size 2381 INTEGER length 2382 INTEGER addr 2383 INTEGER h10b 2384 INTEGER p5b 2385 length = 0 2386 DO h10b = 1,noab 2387 DO p5b = noab+1,noab+nvab 2388 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN 2389 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T 2390 &HEN 2391 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b- 2392 &1).ne.4)) THEN 2393 length = length + 1 2394 END IF 2395 END IF 2396 END IF 2397 END DO 2398 END DO 2399 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2400 &set)) CALL ERRQUIT('ccsdt_t2_2_4_1',0,MA_ERR) 2401 int_mb(k_a_offset) = length 2402 addr = 0 2403 size = 0 2404 DO h10b = 1,noab 2405 DO p5b = noab+1,noab+nvab 2406 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN 2407 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T 2408 &HEN 2409 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b- 2410 &1).ne.4)) THEN 2411 addr = addr + 1 2412 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h10b - 1) 2413 int_mb(k_a_offset+length+addr) = size 2414 size = size + int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1) 2415 END IF 2416 END IF 2417 END IF 2418 END DO 2419 END DO 2420 RETURN 2421 END 2422 SUBROUTINE ccsdt_t2a_2_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 2423 &k_c_offset) 2424C $Id$ 2425C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2426C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2427C i2 ( h10 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h10 p5 p6 )_v 2428 IMPLICIT NONE 2429#include "global.fh" 2430#include "mafdecls.fh" 2431#include "sym.fh" 2432#include "errquit.fh" 2433#include "tce.fh" 2434 INTEGER d_a 2435 INTEGER k_a_offset 2436 INTEGER d_b 2437 INTEGER k_b_offset 2438 INTEGER d_c 2439 INTEGER k_c_offset 2440 INTEGER NXTASK 2441 INTEGER next 2442 INTEGER nprocs 2443 INTEGER count 2444 INTEGER h10b 2445 INTEGER p5b 2446 INTEGER dimc 2447 INTEGER l_c_sort 2448 INTEGER k_c_sort 2449 INTEGER p6b 2450 INTEGER h7b 2451 INTEGER p6b_1 2452 INTEGER h7b_1 2453 INTEGER h10b_2 2454 INTEGER h7b_2 2455 INTEGER p5b_2 2456 INTEGER p6b_2 2457 INTEGER dim_common 2458 INTEGER dima_sort 2459 INTEGER dima 2460 INTEGER dimb_sort 2461 INTEGER dimb 2462 INTEGER l_a_sort 2463 INTEGER k_a_sort 2464 INTEGER l_a 2465 INTEGER k_a 2466 INTEGER l_b_sort 2467 INTEGER k_b_sort 2468 INTEGER l_b 2469 INTEGER k_b 2470 INTEGER l_c 2471 INTEGER k_c 2472 EXTERNAL NXTASK 2473 nprocs = GA_NNODES() 2474 count = 0 2475 next = NXTASK(nprocs,1) 2476 DO h10b = 1,noab 2477 DO p5b = noab+1,noab+nvab 2478 IF (next.eq.count) THEN 2479 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b- 2480 &1).ne.4)) THEN 2481 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN 2482 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep 2483 &_v,irrep_t)) THEN 2484 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1) 2485 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2486 & ERRQUIT('ccsdt_t2_2_4_2',0,MA_ERR) 2487 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2488 DO p6b = noab+1,noab+nvab 2489 DO h7b = 1,noab 2490 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN 2491 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 2492 &EN 2493 CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1) 2494 CALL TCE_RESTRICTED_4(h10b,h7b,p5b,p6b,h10b_2,h7b_2,p5b_2,p6b_2) 2495 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1) 2496 dima_sort = 1 2497 dima = dim_common * dima_sort 2498 dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1) 2499 dimb = dim_common * dimb_sort 2500 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2501 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2502 & ERRQUIT('ccsdt_t2_2_4_2',1,MA_ERR) 2503 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2504 &ccsdt_t2_2_4_2',2,MA_ERR) 2505 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 2506 & - 1 + noab * (p6b_1 - noab - 1))) 2507 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 2508 &,int_mb(k_range+h7b-1),2,1,1.0d0) 2509 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_4_2',3,MA_ERR 2510 &) 2511 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2512 & ERRQUIT('ccsdt_t2_2_4_2',4,MA_ERR) 2513 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2514 &ccsdt_t2_2_4_2',5,MA_ERR) 2515 IF ((h7b .le. h10b) .and. (p6b .lt. p5b)) THEN 2516 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 2517 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 2518 &b+nvab) * (h7b_2 - 1))))) 2519 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 2520 &,int_mb(k_range+h10b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1 2521 &),4,2,1,3,-1.0d0) 2522 END IF 2523 IF ((h7b .le. h10b) .and. (p5b .le. p6b)) THEN 2524 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 2525 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 2526 &b+nvab) * (h7b_2 - 1))))) 2527 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 2528 &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 2529 &),3,2,1,4,1.0d0) 2530 END IF 2531 IF ((h10b .lt. h7b) .and. (p6b .lt. p5b)) THEN 2532 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 2533 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 2534 &+nvab) * (h10b_2 - 1))))) 2535 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 2536 &),int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1 2537 &),4,1,2,3,1.0d0) 2538 END IF 2539 IF ((h10b .lt. h7b) .and. (p5b .le. p6b)) THEN 2540 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 2541 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 2542 &+nvab) * (h10b_2 - 1))))) 2543 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 2544 &),int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 2545 &),3,1,2,4,-1.0d0) 2546 END IF 2547 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_4_2',6,MA_ERR 2548 &) 2549 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2550 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2551 &t),dima_sort) 2552 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_4_2',7,M 2553 &A_ERR) 2554 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_4_2',8,M 2555 &A_ERR) 2556 END IF 2557 END IF 2558 END IF 2559 END DO 2560 END DO 2561 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2562 &ccsdt_t2_2_4_2',9,MA_ERR) 2563 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 2564 &,int_mb(k_range+h10b-1),2,1,-1.0d0) 2565 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 2566 & noab - 1 + nvab * (h10b - 1))) 2567 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_4_2',10,MA_ER 2568 &R) 2569 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_4_2',11, 2570 &MA_ERR) 2571 END IF 2572 END IF 2573 END IF 2574 next = NXTASK(nprocs,1) 2575 END IF 2576 count = count + 1 2577 END DO 2578 END DO 2579 next = NXTASK(-nprocs,1) 2580 call GA_SYNC() 2581 RETURN 2582 END 2583 SUBROUTINE ccsdt_t2a_2_5(d_a,k_a_offset,d_b,k_b_offset,d_c, 2584 &k_c_offset) 2585C $Id$ 2586C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2587C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2588C i1 ( h10 p3 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( h7 p9 ) * t ( p3 p9 h1 h7 )_t * i2 ( h7 h10 h2 p9 )_v 2589 IMPLICIT NONE 2590#include "global.fh" 2591#include "mafdecls.fh" 2592#include "sym.fh" 2593#include "errquit.fh" 2594#include "tce.fh" 2595 INTEGER d_a 2596 INTEGER k_a_offset 2597 INTEGER d_b 2598 INTEGER k_b_offset 2599 INTEGER d_c 2600 INTEGER k_c_offset 2601 INTEGER NXTASK 2602 INTEGER next 2603 INTEGER nprocs 2604 INTEGER count 2605 INTEGER p3b 2606 INTEGER h10b 2607 INTEGER h1b 2608 INTEGER h2b 2609 INTEGER dimc 2610 INTEGER l_c_sort 2611 INTEGER k_c_sort 2612 INTEGER p9b 2613 INTEGER h7b 2614 INTEGER p3b_1 2615 INTEGER p9b_1 2616 INTEGER h1b_1 2617 INTEGER h7b_1 2618 INTEGER h10b_2 2619 INTEGER h7b_2 2620 INTEGER h2b_2 2621 INTEGER p9b_2 2622 INTEGER dim_common 2623 INTEGER dima_sort 2624 INTEGER dima 2625 INTEGER dimb_sort 2626 INTEGER dimb 2627 INTEGER l_a_sort 2628 INTEGER k_a_sort 2629 INTEGER l_a 2630 INTEGER k_a 2631 INTEGER l_b_sort 2632 INTEGER k_b_sort 2633 INTEGER l_b 2634 INTEGER k_b 2635 INTEGER l_c 2636 INTEGER k_c 2637 EXTERNAL NXTASK 2638 nprocs = GA_NNODES() 2639 count = 0 2640 next = NXTASK(nprocs,1) 2641 DO p3b = noab+1,noab+nvab 2642 DO h10b = 1,noab 2643 DO h1b = 1,noab 2644 DO h2b = 1,noab 2645 IF (next.eq.count) THEN 2646 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 2647 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 2648 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 2649 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 2650 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 2651 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 2652 &HEN 2653 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 2654 &ange+h1b-1) * int_mb(k_range+h2b-1) 2655 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2656 & ERRQUIT('ccsdt_t2_2_5',0,MA_ERR) 2657 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2658 DO p9b = noab+1,noab+nvab 2659 DO h7b = 1,noab 2660 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h 2661 &1b-1)+int_mb(k_spin+h7b-1)) THEN 2662 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p9b-1),ieor(int_mb( 2663 &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_t) THEN 2664 CALL TCE_RESTRICTED_4(p3b,p9b,h1b,h7b,p3b_1,p9b_1,h1b_1,h7b_1) 2665 CALL TCE_RESTRICTED_4(h10b,h7b,h2b,p9b,h10b_2,h7b_2,h2b_2,p9b_2) 2666 dim_common = int_mb(k_range+p9b-1) * int_mb(k_range+h7b-1) 2667 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) 2668 dima = dim_common * dima_sort 2669 dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h2b-1) 2670 dimb = dim_common * dimb_sort 2671 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2672 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2673 & ERRQUIT('ccsdt_t2_2_5',1,MA_ERR) 2674 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2675 &ccsdt_t2_2_5',2,MA_ERR) 2676 IF ((p9b .lt. p3b) .and. (h7b .lt. h1b)) THEN 2677 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2678 & - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p9b_ 2679 &1 - noab - 1))))) 2680 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 2681 &,int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 2682 &,4,2,3,1,1.0d0) 2683 END IF 2684 IF ((p9b .lt. p3b) .and. (h1b .le. h7b)) THEN 2685 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 2686 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p9b_ 2687 &1 - noab - 1))))) 2688 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 2689 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1) 2690 &,3,2,4,1,-1.0d0) 2691 END IF 2692 IF ((p3b .le. p9b) .and. (h7b .lt. h1b)) THEN 2693 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2694 & - 1 + noab * (h7b_1 - 1 + noab * (p9b_1 - noab - 1 + nvab * (p3b_ 2695 &1 - noab - 1))))) 2696 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2697 &,int_mb(k_range+p9b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 2698 &,4,1,3,2,-1.0d0) 2699 END IF 2700 IF ((p3b .le. p9b) .and. (h1b .le. h7b)) THEN 2701 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 2702 & - 1 + noab * (h1b_1 - 1 + noab * (p9b_1 - noab - 1 + nvab * (p3b_ 2703 &1 - noab - 1))))) 2704 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2705 &,int_mb(k_range+p9b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1) 2706 &,3,1,4,2,1.0d0) 2707 END IF 2708 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_5',3,MA_ERR) 2709 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2710 & ERRQUIT('ccsdt_t2_2_5',4,MA_ERR) 2711 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2712 &ccsdt_t2_2_5',5,MA_ERR) 2713 IF ((h7b .le. h10b)) THEN 2714 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 2715 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h10b_2 - 1 + noab * (h7b 2716 &_2 - 1))))) 2717 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 2718 &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+p9b-1 2719 &),3,2,1,4,1.0d0) 2720 END IF 2721 IF ((h10b .lt. h7b)) THEN 2722 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 2723 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (h10b 2724 &_2 - 1))))) 2725 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 2726 &),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),int_mb(k_range+p9b-1 2727 &),3,1,2,4,-1.0d0) 2728 END IF 2729 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_5',6,MA_ERR) 2730 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2731 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2732 &t),dima_sort) 2733 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_5',7,MA_ 2734 &ERR) 2735 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_5',8,MA_ 2736 &ERR) 2737 END IF 2738 END IF 2739 END IF 2740 END DO 2741 END DO 2742 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2743 &ccsdt_t2_2_5',9,MA_ERR) 2744 IF ((h1b .le. h2b)) THEN 2745 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 2746 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1 2747 &),4,2,3,1,1.0d0) 2748 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 2749 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 2750 &))) 2751 END IF 2752 IF ((h2b .le. h1b)) THEN 2753 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 2754 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1 2755 &),4,2,1,3,-1.0d0) 2756 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2757 & 1 + noab * (h2b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 2758 &))) 2759 END IF 2760 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_5',10,MA_ERR) 2761 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_5',11,MA 2762 &_ERR) 2763 END IF 2764 END IF 2765 END IF 2766 next = NXTASK(nprocs,1) 2767 END IF 2768 count = count + 1 2769 END DO 2770 END DO 2771 END DO 2772 END DO 2773 next = NXTASK(-nprocs,1) 2774 call GA_SYNC() 2775 RETURN 2776 END 2777 SUBROUTINE ccsdt_t2a_2_5_1(d_a,k_a_offset,d_c,k_c_offset) 2778C $Id$ 2779C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2780C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2781C i2 ( h7 h10 h1 p9 )_v + = 1 * v ( h7 h10 h1 p9 )_v 2782 IMPLICIT NONE 2783#include "global.fh" 2784#include "mafdecls.fh" 2785#include "sym.fh" 2786#include "errquit.fh" 2787#include "tce.fh" 2788 INTEGER d_a 2789 INTEGER k_a_offset 2790 INTEGER d_c 2791 INTEGER k_c_offset 2792 INTEGER NXTASK 2793 INTEGER next 2794 INTEGER nprocs 2795 INTEGER count 2796 INTEGER h7b 2797 INTEGER h10b 2798 INTEGER h1b 2799 INTEGER p9b 2800 INTEGER dimc 2801 INTEGER h7b_1 2802 INTEGER h10b_1 2803 INTEGER h1b_1 2804 INTEGER p9b_1 2805 INTEGER dim_common 2806 INTEGER dima_sort 2807 INTEGER dima 2808 INTEGER l_a_sort 2809 INTEGER k_a_sort 2810 INTEGER l_a 2811 INTEGER k_a 2812 INTEGER l_c 2813 INTEGER k_c 2814 EXTERNAL NXTASK 2815 nprocs = GA_NNODES() 2816 count = 0 2817 next = NXTASK(nprocs,1) 2818 DO h7b = 1,noab 2819 DO h10b = h7b,noab 2820 DO h1b = 1,noab 2821 DO p9b = noab+1,noab+nvab 2822 IF (next.eq.count) THEN 2823 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b- 2824 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN 2825 IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 2826 &h1b-1)+int_mb(k_spin+p9b-1)) THEN 2827 IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 2828 &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN 2829 dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 2830 &ange+h1b-1) * int_mb(k_range+p9b-1) 2831 CALL TCE_RESTRICTED_4(h7b,h10b,h1b,p9b,h7b_1,h10b_1,h1b_1,p9b_1) 2832 dim_common = 1 2833 dima_sort = int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int_m 2834 &b(k_range+h1b-1) * int_mb(k_range+p9b-1) 2835 dima = dim_common * dima_sort 2836 IF (dima .gt. 0) THEN 2837 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2838 & ERRQUIT('ccsdt_t2_2_5_1',0,MA_ERR) 2839 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2840 &ccsdt_t2_2_5_1',1,MA_ERR) 2841 IF ((h1b .le. p9b)) THEN 2842 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p9b_1 2843 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 2844 &b+nvab) * (h7b_1 - 1))))) 2845 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 2846 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p9b-1 2847 &),4,3,2,1,1.0d0) 2848 END IF 2849 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_5_1',2,MA_ERR 2850 &) 2851 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2852 &ccsdt_t2_2_5_1',3,MA_ERR) 2853 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p9b-1) 2854 &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h7b-1 2855 &),4,3,2,1,1.0d0) 2856 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b - 2857 & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h7b - 1)) 2858 &))) 2859 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_5_1',4,MA_ERR 2860 &) 2861 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_5_1',5,M 2862 &A_ERR) 2863 END IF 2864 END IF 2865 END IF 2866 END IF 2867 next = NXTASK(nprocs,1) 2868 END IF 2869 count = count + 1 2870 END DO 2871 END DO 2872 END DO 2873 END DO 2874 next = NXTASK(-nprocs,1) 2875 call GA_SYNC() 2876 RETURN 2877 END 2878 SUBROUTINE OFFSET_ccsdt_t2a_2_5_1(l_a_offset,k_a_offset,size) 2879C $Id$ 2880C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2881C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2882C i2 ( h7 h10 h1 p9 )_v 2883 IMPLICIT NONE 2884#include "global.fh" 2885#include "mafdecls.fh" 2886#include "sym.fh" 2887#include "errquit.fh" 2888#include "tce.fh" 2889 INTEGER l_a_offset 2890 INTEGER k_a_offset 2891 INTEGER size 2892 INTEGER length 2893 INTEGER addr 2894 INTEGER h7b 2895 INTEGER h10b 2896 INTEGER h1b 2897 INTEGER p9b 2898 length = 0 2899 DO h7b = 1,noab 2900 DO h10b = h7b,noab 2901 DO h1b = 1,noab 2902 DO p9b = noab+1,noab+nvab 2903 IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 2904 &h1b-1)+int_mb(k_spin+p9b-1)) THEN 2905 IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 2906 &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN 2907 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b- 2908 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN 2909 length = length + 1 2910 END IF 2911 END IF 2912 END IF 2913 END DO 2914 END DO 2915 END DO 2916 END DO 2917 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2918 &set)) CALL ERRQUIT('ccsdt_t2_2_5_1',0,MA_ERR) 2919 int_mb(k_a_offset) = length 2920 addr = 0 2921 size = 0 2922 DO h7b = 1,noab 2923 DO h10b = h7b,noab 2924 DO h1b = 1,noab 2925 DO p9b = noab+1,noab+nvab 2926 IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 2927 &h1b-1)+int_mb(k_spin+p9b-1)) THEN 2928 IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 2929 &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN 2930 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b- 2931 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN 2932 addr = addr + 1 2933 int_mb(k_a_offset+addr) = p9b - noab - 1 + nvab * (h1b - 1 + noab 2934 &* (h10b - 1 + noab * (h7b - 1))) 2935 int_mb(k_a_offset+length+addr) = size 2936 size = size + int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int 2937 &_mb(k_range+h1b-1) * int_mb(k_range+p9b-1) 2938 END IF 2939 END IF 2940 END IF 2941 END DO 2942 END DO 2943 END DO 2944 END DO 2945 RETURN 2946 END 2947 SUBROUTINE ccsdt_t2a_2_5_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 2948 &k_c_offset) 2949C $Id$ 2950C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2951C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2952C i2 ( h7 h10 h1 p9 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h7 h10 p5 p9 )_v 2953 IMPLICIT NONE 2954#include "global.fh" 2955#include "mafdecls.fh" 2956#include "sym.fh" 2957#include "errquit.fh" 2958#include "tce.fh" 2959 INTEGER d_a 2960 INTEGER k_a_offset 2961 INTEGER d_b 2962 INTEGER k_b_offset 2963 INTEGER d_c 2964 INTEGER k_c_offset 2965 INTEGER NXTASK 2966 INTEGER next 2967 INTEGER nprocs 2968 INTEGER count 2969 INTEGER h7b 2970 INTEGER h10b 2971 INTEGER h1b 2972 INTEGER p9b 2973 INTEGER dimc 2974 INTEGER l_c_sort 2975 INTEGER k_c_sort 2976 INTEGER p5b 2977 INTEGER p5b_1 2978 INTEGER h1b_1 2979 INTEGER h7b_2 2980 INTEGER h10b_2 2981 INTEGER p9b_2 2982 INTEGER p5b_2 2983 INTEGER dim_common 2984 INTEGER dima_sort 2985 INTEGER dima 2986 INTEGER dimb_sort 2987 INTEGER dimb 2988 INTEGER l_a_sort 2989 INTEGER k_a_sort 2990 INTEGER l_a 2991 INTEGER k_a 2992 INTEGER l_b_sort 2993 INTEGER k_b_sort 2994 INTEGER l_b 2995 INTEGER k_b 2996 INTEGER l_c 2997 INTEGER k_c 2998 EXTERNAL NXTASK 2999 nprocs = GA_NNODES() 3000 count = 0 3001 next = NXTASK(nprocs,1) 3002 DO h7b = 1,noab 3003 DO h10b = h7b,noab 3004 DO h1b = 1,noab 3005 DO p9b = noab+1,noab+nvab 3006 IF (next.eq.count) THEN 3007 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b- 3008 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN 3009 IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 3010 &h1b-1)+int_mb(k_spin+p9b-1)) THEN 3011 IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 3012 &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. ieor(irrep_v,irrep_t)) T 3013 &HEN 3014 dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 3015 &ange+h1b-1) * int_mb(k_range+p9b-1) 3016 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3017 & ERRQUIT('ccsdt_t2_2_5_2',0,MA_ERR) 3018 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3019 DO p5b = noab+1,noab+nvab 3020 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3021 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 3022 &EN 3023 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 3024 CALL TCE_RESTRICTED_4(h7b,h10b,p9b,p5b,h7b_2,h10b_2,p9b_2,p5b_2) 3025 dim_common = int_mb(k_range+p5b-1) 3026 dima_sort = int_mb(k_range+h1b-1) 3027 dima = dim_common * dima_sort 3028 dimb_sort = int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int_m 3029 &b(k_range+p9b-1) 3030 dimb = dim_common * dimb_sort 3031 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3032 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3033 & ERRQUIT('ccsdt_t2_2_5_2',1,MA_ERR) 3034 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3035 &ccsdt_t2_2_5_2',2,MA_ERR) 3036 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 3037 & - 1 + noab * (p5b_1 - noab - 1))) 3038 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3039 &,int_mb(k_range+h1b-1),2,1,1.0d0) 3040 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_5_2',3,MA_ERR 3041 &) 3042 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3043 & ERRQUIT('ccsdt_t2_2_5_2',4,MA_ERR) 3044 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3045 &ccsdt_t2_2_5_2',5,MA_ERR) 3046 IF ((p5b .le. p9b)) THEN 3047 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 3048 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 3049 &b+nvab) * (h7b_2 - 1))))) 3050 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 3051 &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1 3052 &),4,2,1,3,1.0d0) 3053 END IF 3054 IF ((p9b .lt. p5b)) THEN 3055 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 3056 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 3057 &b+nvab) * (h7b_2 - 1))))) 3058 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 3059 &,int_mb(k_range+h10b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1 3060 &),3,2,1,4,-1.0d0) 3061 END IF 3062 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_5_2',6,MA_ERR 3063 &) 3064 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3065 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3066 &t),dima_sort) 3067 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_5_2',7,M 3068 &A_ERR) 3069 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_5_2',8,M 3070 &A_ERR) 3071 END IF 3072 END IF 3073 END IF 3074 END DO 3075 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3076 &ccsdt_t2_2_5_2',9,MA_ERR) 3077 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p9b-1) 3078 &,int_mb(k_range+h10b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1 3079 &),3,2,4,1,1.0d0) 3080 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b - 3081 & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h7b - 1)) 3082 &))) 3083 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_5_2',10,MA_ER 3084 &R) 3085 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_5_2',11, 3086 &MA_ERR) 3087 END IF 3088 END IF 3089 END IF 3090 next = NXTASK(nprocs,1) 3091 END IF 3092 count = count + 1 3093 END DO 3094 END DO 3095 END DO 3096 END DO 3097 next = NXTASK(-nprocs,1) 3098 call GA_SYNC() 3099 RETURN 3100 END 3101 SUBROUTINE ccsdt_t2a_2_6(d_a,k_a_offset,d_b,k_b_offset,d_c, 3102 &k_c_offset) 3103C $Id$ 3104C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3105C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3106C i1 ( h10 p3 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h10 p3 p5 p6 )_v 3107 IMPLICIT NONE 3108#include "global.fh" 3109#include "mafdecls.fh" 3110#include "sym.fh" 3111#include "errquit.fh" 3112#include "tce.fh" 3113 INTEGER d_a 3114 INTEGER k_a_offset 3115 INTEGER d_b 3116 INTEGER k_b_offset 3117 INTEGER d_c 3118 INTEGER k_c_offset 3119 INTEGER NXTASK 3120 INTEGER next 3121 INTEGER nprocs 3122 INTEGER count 3123 INTEGER p3b 3124 INTEGER h10b 3125 INTEGER h1b 3126 INTEGER h2b 3127 INTEGER dimc 3128 INTEGER l_c_sort 3129 INTEGER k_c_sort 3130 INTEGER p5b 3131 INTEGER p6b 3132 INTEGER p5b_1 3133 INTEGER p6b_1 3134 INTEGER h1b_1 3135 INTEGER h2b_1 3136 INTEGER p3b_2 3137 INTEGER h10b_2 3138 INTEGER p5b_2 3139 INTEGER p6b_2 3140 INTEGER dim_common 3141 INTEGER dima_sort 3142 INTEGER dima 3143 INTEGER dimb_sort 3144 INTEGER dimb 3145 INTEGER l_a_sort 3146 INTEGER k_a_sort 3147 INTEGER l_a 3148 INTEGER k_a 3149 INTEGER l_b_sort 3150 INTEGER k_b_sort 3151 INTEGER l_b 3152 INTEGER k_b 3153 INTEGER nsuperp(2) 3154 INTEGER isuperp 3155 INTEGER l_c 3156 INTEGER k_c 3157 DOUBLE PRECISION FACTORIAL 3158 EXTERNAL NXTASK 3159 EXTERNAL FACTORIAL 3160 nprocs = GA_NNODES() 3161 count = 0 3162 next = NXTASK(nprocs,1) 3163 DO p3b = noab+1,noab+nvab 3164 DO h10b = 1,noab 3165 DO h1b = 1,noab 3166 DO h2b = h1b,noab 3167 IF (next.eq.count) THEN 3168 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 3169 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 3170 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 3171 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 3172 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 3173 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 3174 &HEN 3175 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 3176 &ange+h1b-1) * int_mb(k_range+h2b-1) 3177 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3178 & ERRQUIT('ccsdt_t2_2_6',0,MA_ERR) 3179 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3180 DO p5b = noab+1,noab+nvab 3181 DO p6b = p5b,noab+nvab 3182 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 3183 &1b-1)+int_mb(k_spin+h2b-1)) THEN 3184 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 3185 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 3186 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1) 3187 CALL TCE_RESTRICTED_4(p3b,h10b,p5b,p6b,p3b_2,h10b_2,p5b_2,p6b_2) 3188 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) 3189 dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 3190 dima = dim_common * dima_sort 3191 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) 3192 dimb = dim_common * dimb_sort 3193 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3194 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3195 & ERRQUIT('ccsdt_t2_2_6',1,MA_ERR) 3196 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3197 &ccsdt_t2_2_6',2,MA_ERR) 3198 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 3199 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 3200 &1 - noab - 1))))) 3201 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3202 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 3203 &,4,3,2,1,1.0d0) 3204 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_6',3,MA_ERR) 3205 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3206 & ERRQUIT('ccsdt_t2_2_6',4,MA_ERR) 3207 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3208 &ccsdt_t2_2_6',5,MA_ERR) 3209 IF ((h10b .le. p3b)) THEN 3210 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 3211 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 3212 &+nvab) * (h10b_2 - 1))))) 3213 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 3214 &),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 3215 &),1,2,4,3,1.0d0) 3216 END IF 3217 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_6',6,MA_ERR) 3218 nsuperp(1) = 1 3219 nsuperp(2) = 1 3220 isuperp = 1 3221 IF (p5b .eq. p6b) THEN 3222 nsuperp(isuperp) = nsuperp(isuperp) + 1 3223 ELSE 3224 isuperp = isuperp + 1 3225 END IF 3226 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 3227 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 3228 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 3229 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_6',7,MA_ 3230 &ERR) 3231 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_6',8,MA_ 3232 &ERR) 3233 END IF 3234 END IF 3235 END IF 3236 END DO 3237 END DO 3238 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3239 &ccsdt_t2_2_6',9,MA_ERR) 3240 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1 3241 &),int_mb(k_range+p3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1 3242 &),2,1,4,3,1.0d0/2.0d0) 3243 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 3244 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 3245 &))) 3246 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_6',10,MA_ERR) 3247 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_6',11,MA 3248 &_ERR) 3249 END IF 3250 END IF 3251 END IF 3252 next = NXTASK(nprocs,1) 3253 END IF 3254 count = count + 1 3255 END DO 3256 END DO 3257 END DO 3258 END DO 3259 next = NXTASK(-nprocs,1) 3260 call GA_SYNC() 3261 RETURN 3262 END 3263 SUBROUTINE ccsdt_t2a_2_7(d_a,k_a_offset,d_b,k_b_offset,d_c, 3264 &k_c_offset) 3265C $Id$ 3266C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3267C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3268C i1 ( h10 p3 h1 h2 )_vt + = 1/2 * Sum ( h7 p5 p6 ) * t ( p3 p5 p6 h1 h2 h7 )_t * v ( h7 h10 p5 p6 )_v 3269 IMPLICIT NONE 3270#include "global.fh" 3271#include "mafdecls.fh" 3272#include "sym.fh" 3273#include "errquit.fh" 3274#include "tce.fh" 3275 INTEGER d_a 3276 INTEGER k_a_offset 3277 INTEGER d_b 3278 INTEGER k_b_offset 3279 INTEGER d_c 3280 INTEGER k_c_offset 3281 INTEGER NXTASK 3282 INTEGER next 3283 INTEGER nprocs 3284 INTEGER count 3285 INTEGER p3b 3286 INTEGER h10b 3287 INTEGER h1b 3288 INTEGER h2b 3289 INTEGER dimc 3290 INTEGER l_c_sort 3291 INTEGER k_c_sort 3292 INTEGER p5b 3293 INTEGER p6b 3294 INTEGER h7b 3295 INTEGER p3b_1 3296 INTEGER p5b_1 3297 INTEGER p6b_1 3298 INTEGER h1b_1 3299 INTEGER h2b_1 3300 INTEGER h7b_1 3301 INTEGER h10b_2 3302 INTEGER h7b_2 3303 INTEGER p5b_2 3304 INTEGER p6b_2 3305 INTEGER dim_common 3306 INTEGER dima_sort 3307 INTEGER dima 3308 INTEGER dimb_sort 3309 INTEGER dimb 3310 INTEGER l_a_sort 3311 INTEGER k_a_sort 3312 INTEGER l_a 3313 INTEGER k_a 3314 INTEGER l_b_sort 3315 INTEGER k_b_sort 3316 INTEGER l_b 3317 INTEGER k_b 3318 INTEGER nsuperp(2) 3319 INTEGER isuperp 3320 INTEGER l_c 3321 INTEGER k_c 3322 LOGICAL ACOLO 3323 DOUBLE PRECISION FACTORIAL 3324 EXTERNAL NXTASK 3325 EXTERNAL FACTORIAL 3326 nprocs = GA_NNODES() 3327 count = 0 3328 next = NXTASK(nprocs,1) 3329 DO p3b = noab+1,noab+nvab 3330 DO h10b = 1,noab 3331 DO h1b = 1,noab 3332 DO h2b = h1b,noab 3333 IF (next.eq.count) THEN 3334 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 3335 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 3336 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 3337 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 3338 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 3339 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 3340 &HEN 3341 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 3342 &ange+h1b-1) * int_mb(k_range+h2b-1) 3343 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3344 & ERRQUIT('ccsdt_t2_2_7',0,MA_ERR) 3345 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3346 DO p5b = noab+1,noab+nvab 3347 DO p6b = p5b,noab+nvab 3348 DO h7b = 1,noab 3349 IF(acolo(p3b,p5b,p6b,h1b,h2b,h7b)) THEN 3350 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 3351 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b- 3352 &1)) THEN 3353 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 3354 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 3355 &_mb(k_sym+h7b-1)))))) .eq. irrep_t) THEN 3356 CALL TCE_RESTRICTED_6(p3b,p5b,p6b,h1b,h2b,h7b,p3b_1,p5b_1,p6b_1,h1 3357 &b_1,h2b_1,h7b_1) 3358 CALL TCE_RESTRICTED_4(h10b,h7b,p5b,p6b,h10b_2,h7b_2,p5b_2,p6b_2) 3359 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_m 3360 &b(k_range+h7b-1) 3361 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb 3362 &(k_range+h2b-1) 3363 dima = dim_common * dima_sort 3364 dimb_sort = int_mb(k_range+h10b-1) 3365 dimb = dim_common * dimb_sort 3366 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3367 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3368 & ERRQUIT('ccsdt_t2_2_7',1,MA_ERR) 3369 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3370 &ccsdt_t2_2_7',2,MA_ERR) 3371 IF ((p6b .lt. p3b) .and. (h7b .lt. h1b)) THEN 3372 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 3373 & - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noa 3374 &b - 1 + nvab * (p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 3375 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3376 &,int_mb(k_range+p6b-1),int_mb(k_range+p3b-1),int_mb(k_range+h7b-1) 3377 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,3,4,2,1,1.0d0) 3378 END IF 3379 IF ((p6b .lt. p3b) .and. (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 3380 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 3381 & - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noa 3382 &b - 1 + nvab * (p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 3383 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3384 &,int_mb(k_range+p6b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 3385 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),6,4,3,5,2,1,-1.0d0) 3386 END IF 3387 IF ((p6b .lt. p3b) .and. (h2b .le. h7b)) THEN 3388 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 3389 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noa 3390 &b - 1 + nvab * (p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 3391 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3392 &,int_mb(k_range+p6b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 3393 &,int_mb(k_range+h2b-1),int_mb(k_range+h7b-1),5,4,3,6,2,1,1.0d0) 3394 END IF 3395 IF ((p5b .lt. p3b) .and. (p3b .le. p6b) .and. (h7b .lt. h1b)) THEN 3396 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 3397 & - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + noab * (p6b_1 - noa 3398 &b - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 3399 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3400 &,int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+h7b-1) 3401 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,2,4,3,1,-1.0d0) 3402 END IF 3403 IF ((p5b .lt. p3b) .and. (p3b .le. p6b) .and. (h1b .le. h7b) .and. 3404 & (h7b .lt. h2b)) THEN 3405 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 3406 & - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noa 3407 &b - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 3408 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3409 &,int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 3410 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),6,4,2,5,3,1,1.0d0) 3411 END IF 3412 IF ((p5b .lt. p3b) .and. (p3b .le. p6b) .and. (h2b .le. h7b)) THEN 3413 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 3414 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noa 3415 &b - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 3416 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3417 &,int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 3418 &,int_mb(k_range+h2b-1),int_mb(k_range+h7b-1),5,4,2,6,3,1,-1.0d0) 3419 END IF 3420 IF ((p3b .le. p5b) .and. (h7b .lt. h1b)) THEN 3421 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 3422 & - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + noab * (p6b_1 - noa 3423 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 3424 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 3425 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h7b-1) 3426 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,1,4,3,2,1.0d0) 3427 END IF 3428 IF ((p3b .le. p5b) .and. (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 3429 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 3430 & - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noa 3431 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 3432 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 3433 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 3434 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),6,4,1,5,3,2,-1.0d0) 3435 END IF 3436 IF ((p3b .le. p5b) .and. (h2b .le. h7b)) THEN 3437 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 3438 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noa 3439 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 3440 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 3441 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 3442 &,int_mb(k_range+h2b-1),int_mb(k_range+h7b-1),5,4,1,6,3,2,1.0d0) 3443 END IF 3444 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_2_7',3,MA_ERR) 3445 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3446 & ERRQUIT('ccsdt_t2_2_7',4,MA_ERR) 3447 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3448 &ccsdt_t2_2_7',5,MA_ERR) 3449 IF ((h7b .le. h10b)) THEN 3450 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 3451 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 3452 &b+nvab) * (h7b_2 - 1))))) 3453 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 3454 &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 3455 &),2,1,4,3,1.0d0) 3456 END IF 3457 IF ((h10b .lt. h7b)) THEN 3458 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 3459 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 3460 &+nvab) * (h10b_2 - 1))))) 3461 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 3462 &),int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 3463 &),1,2,4,3,-1.0d0) 3464 END IF 3465 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_2_7',6,MA_ERR) 3466 nsuperp(1) = 1 3467 nsuperp(2) = 1 3468 isuperp = 1 3469 IF (p5b .eq. p6b) THEN 3470 nsuperp(isuperp) = nsuperp(isuperp) + 1 3471 ELSE 3472 isuperp = isuperp + 1 3473 END IF 3474 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 3475 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 3476 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 3477 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_2_7',7,MA_ 3478 &ERR) 3479 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_2_7',8,MA_ 3480 &ERR) 3481 END IF !active 3482 END IF 3483 END IF 3484 END IF 3485 END DO 3486 END DO 3487 END DO 3488 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3489 &ccsdt_t2_2_7',9,MA_ERR) 3490 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1 3491 &),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1 3492 &),4,1,3,2,1.0d0/2.0d0) 3493 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 3494 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 3495 &))) 3496 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_2_7',10,MA_ERR) 3497 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_2_7',11,MA 3498 &_ERR) 3499 END IF 3500 END IF 3501 END IF 3502 next = NXTASK(nprocs,1) 3503 END IF 3504 count = count + 1 3505 END DO 3506 END DO 3507 END DO 3508 END DO 3509 next = NXTASK(-nprocs,1) 3510 call GA_SYNC() 3511 RETURN 3512 END 3513 SUBROUTINE ccsdt_t2a_3(d_a,k_a_offset,d_b,k_b_offset,d_c, 3514 &k_c_offset) 3515C $Id$ 3516C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3517C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3518C i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i1 ( p3 p4 h2 p5 )_v 3519 IMPLICIT NONE 3520#include "global.fh" 3521#include "mafdecls.fh" 3522#include "sym.fh" 3523#include "errquit.fh" 3524#include "tce.fh" 3525 INTEGER d_a 3526 INTEGER k_a_offset 3527 INTEGER d_b 3528 INTEGER k_b_offset 3529 INTEGER d_c 3530 INTEGER k_c_offset 3531 INTEGER NXTASK 3532 INTEGER next 3533 INTEGER nprocs 3534 INTEGER count 3535 INTEGER p3b 3536 INTEGER p4b 3537 INTEGER h1b 3538 INTEGER h2b 3539 INTEGER dimc 3540 INTEGER l_c_sort 3541 INTEGER k_c_sort 3542 INTEGER p5b 3543 INTEGER p5b_1 3544 INTEGER h1b_1 3545 INTEGER p3b_2 3546 INTEGER p4b_2 3547 INTEGER h2b_2 3548 INTEGER p5b_2 3549 INTEGER dim_common 3550 INTEGER dima_sort 3551 INTEGER dima 3552 INTEGER dimb_sort 3553 INTEGER dimb 3554 INTEGER l_a_sort 3555 INTEGER k_a_sort 3556 INTEGER l_a 3557 INTEGER k_a 3558 INTEGER l_b_sort 3559 INTEGER k_b_sort 3560 INTEGER l_b 3561 INTEGER k_b 3562 INTEGER l_c 3563 INTEGER k_c 3564 EXTERNAL NXTASK 3565 nprocs = GA_NNODES() 3566 count = 0 3567 next = NXTASK(nprocs,1) 3568 DO p3b = noab+1,noab+nvab 3569 DO p4b = p3b,noab+nvab 3570 DO h1b = 1,noab 3571 DO h2b = 1,noab 3572 IF (next.eq.count) THEN 3573 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 3574 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 3575 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 3576 &1b-1)+int_mb(k_spin+h2b-1)) THEN 3577 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 3578 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 3579 &EN 3580 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 3581 &nge+h1b-1) * int_mb(k_range+h2b-1) 3582 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3583 & ERRQUIT('ccsdt_t2_3',0,MA_ERR) 3584 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3585 DO p5b = noab+1,noab+nvab 3586 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3587 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 3588 &EN 3589 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 3590 CALL TCE_RESTRICTED_4(p3b,p4b,h2b,p5b,p3b_2,p4b_2,h2b_2,p5b_2) 3591 dim_common = int_mb(k_range+p5b-1) 3592 dima_sort = int_mb(k_range+h1b-1) 3593 dima = dim_common * dima_sort 3594 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb 3595 &(k_range+h2b-1) 3596 dimb = dim_common * dimb_sort 3597 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3598 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3599 & ERRQUIT('ccsdt_t2_3',1,MA_ERR) 3600 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3601 &ccsdt_t2_3',2,MA_ERR) 3602 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 3603 & - 1 + noab * (p5b_1 - noab - 1))) 3604 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3605 &,int_mb(k_range+h1b-1),2,1,1.0d0) 3606 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_3',3,MA_ERR) 3607 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3608 & ERRQUIT('ccsdt_t2_3',4,MA_ERR) 3609 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3610 &ccsdt_t2_3',5,MA_ERR) 3611 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 3612 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (p4b_2 - noab - 1 + nvab 3613 &* (p3b_2 - noab - 1))))) 3614 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1) 3615 &,int_mb(k_range+p4b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1) 3616 &,3,2,1,4,1.0d0) 3617 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_3',6,MA_ERR) 3618 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3619 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3620 &t),dima_sort) 3621 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_3',7,MA_ER 3622 &R) 3623 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_3',8,MA_ER 3624 &R) 3625 END IF 3626 END IF 3627 END IF 3628 END DO 3629 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3630 &ccsdt_t2_3',9,MA_ERR) 3631 IF ((h1b .le. h2b)) THEN 3632 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 3633 &,int_mb(k_range+p4b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 3634 &,3,2,4,1,-1.0d0) 3635 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 3636 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 3637 & - 1))))) 3638 END IF 3639 IF ((h2b .le. h1b)) THEN 3640 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 3641 &,int_mb(k_range+p4b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 3642 &,3,2,1,4,1.0d0) 3643 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 3644 & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 3645 & - 1))))) 3646 END IF 3647 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_3',10,MA_ERR) 3648 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_3',11,MA_E 3649 &RR) 3650 END IF 3651 END IF 3652 END IF 3653 next = NXTASK(nprocs,1) 3654 END IF 3655 count = count + 1 3656 END DO 3657 END DO 3658 END DO 3659 END DO 3660 next = NXTASK(-nprocs,1) 3661 call GA_SYNC() 3662 RETURN 3663 END 3664 SUBROUTINE ccsdt_t2a_3_1(d_a,k_a_offset,d_c,k_c_offset) 3665C $Id$ 3666C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3667C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3668C i1 ( p3 p4 h1 p5 )_v + = 1 * v ( p3 p4 h1 p5 )_v 3669 IMPLICIT NONE 3670#include "global.fh" 3671#include "mafdecls.fh" 3672#include "sym.fh" 3673#include "errquit.fh" 3674#include "tce.fh" 3675 INTEGER d_a 3676 INTEGER k_a_offset 3677 INTEGER d_c 3678 INTEGER k_c_offset 3679 INTEGER NXTASK 3680 INTEGER next 3681 INTEGER nprocs 3682 INTEGER count 3683 INTEGER p3b 3684 INTEGER p4b 3685 INTEGER h1b 3686 INTEGER p5b 3687 INTEGER dimc 3688 INTEGER p3b_1 3689 INTEGER p4b_1 3690 INTEGER h1b_1 3691 INTEGER p5b_1 3692 INTEGER dim_common 3693 INTEGER dima_sort 3694 INTEGER dima 3695 INTEGER l_a_sort 3696 INTEGER k_a_sort 3697 INTEGER l_a 3698 INTEGER k_a 3699 INTEGER l_c 3700 INTEGER k_c 3701 EXTERNAL NXTASK 3702 nprocs = GA_NNODES() 3703 count = 0 3704 next = NXTASK(nprocs,1) 3705 DO p3b = noab+1,noab+nvab 3706 DO p4b = p3b,noab+nvab 3707 DO h1b = 1,noab 3708 DO p5b = noab+1,noab+nvab 3709 IF (next.eq.count) THEN 3710 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 3711 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 3712 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 3713 &1b-1)+int_mb(k_spin+p5b-1)) THEN 3714 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 3715 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 3716 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 3717 &nge+h1b-1) * int_mb(k_range+p5b-1) 3718 CALL TCE_RESTRICTED_4(p3b,p4b,h1b,p5b,p3b_1,p4b_1,h1b_1,p5b_1) 3719 dim_common = 1 3720 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb 3721 &(k_range+h1b-1) * int_mb(k_range+p5b-1) 3722 dima = dim_common * dima_sort 3723 IF (dima .gt. 0) THEN 3724 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3725 & ERRQUIT('ccsdt_t2_3_1',0,MA_ERR) 3726 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3727 &ccsdt_t2_3_1',1,MA_ERR) 3728 IF ((h1b .le. p5b)) THEN 3729 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 3730 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p4b_1 - 1 + (noab 3731 &+nvab) * (p3b_1 - 1))))) 3732 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 3733 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1) 3734 &,4,3,2,1,1.0d0) 3735 END IF 3736 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_3_1',2,MA_ERR) 3737 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3738 &ccsdt_t2_3_1',3,MA_ERR) 3739 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 3740 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 3741 &,4,3,2,1,1.0d0) 3742 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 3743 & noab - 1 + nvab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b 3744 & - noab - 1))))) 3745 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_3_1',4,MA_ERR) 3746 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_3_1',5,MA_ 3747 &ERR) 3748 END IF 3749 END IF 3750 END IF 3751 END IF 3752 next = NXTASK(nprocs,1) 3753 END IF 3754 count = count + 1 3755 END DO 3756 END DO 3757 END DO 3758 END DO 3759 next = NXTASK(-nprocs,1) 3760 call GA_SYNC() 3761 RETURN 3762 END 3763 SUBROUTINE OFFSET_ccsdt_t2a_3_1(l_a_offset,k_a_offset,size) 3764C $Id$ 3765C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3766C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3767C i1 ( p3 p4 h1 p5 )_v 3768 IMPLICIT NONE 3769#include "global.fh" 3770#include "mafdecls.fh" 3771#include "sym.fh" 3772#include "errquit.fh" 3773#include "tce.fh" 3774 INTEGER l_a_offset 3775 INTEGER k_a_offset 3776 INTEGER size 3777 INTEGER length 3778 INTEGER addr 3779 INTEGER p3b 3780 INTEGER p4b 3781 INTEGER h1b 3782 INTEGER p5b 3783 length = 0 3784 DO p3b = noab+1,noab+nvab 3785 DO p4b = p3b,noab+nvab 3786 DO h1b = 1,noab 3787 DO p5b = noab+1,noab+nvab 3788 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 3789 &1b-1)+int_mb(k_spin+p5b-1)) THEN 3790 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 3791 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 3792 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 3793 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 3794 length = length + 1 3795 END IF 3796 END IF 3797 END IF 3798 END DO 3799 END DO 3800 END DO 3801 END DO 3802 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 3803 &set)) CALL ERRQUIT('ccsdt_t2_3_1',0,MA_ERR) 3804 int_mb(k_a_offset) = length 3805 addr = 0 3806 size = 0 3807 DO p3b = noab+1,noab+nvab 3808 DO p4b = p3b,noab+nvab 3809 DO h1b = 1,noab 3810 DO p5b = noab+1,noab+nvab 3811 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 3812 &1b-1)+int_mb(k_spin+p5b-1)) THEN 3813 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 3814 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 3815 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 3816 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 3817 addr = addr + 1 3818 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 3819 &* (p4b - noab - 1 + nvab * (p3b - noab - 1))) 3820 int_mb(k_a_offset+length+addr) = size 3821 size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_ 3822 &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 3823 END IF 3824 END IF 3825 END IF 3826 END DO 3827 END DO 3828 END DO 3829 END DO 3830 RETURN 3831 END 3832 SUBROUTINE ccsdt_t2a_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 3833 &k_c_offset) 3834C $Id$ 3835C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3836C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3837C i1 ( p3 p4 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( p3 p4 p5 p6 )_v 3838 IMPLICIT NONE 3839#include "global.fh" 3840#include "mafdecls.fh" 3841#include "sym.fh" 3842#include "errquit.fh" 3843#include "tce.fh" 3844 INTEGER d_a 3845 INTEGER k_a_offset 3846 INTEGER d_b 3847 INTEGER k_b_offset 3848 INTEGER d_c 3849 INTEGER k_c_offset 3850 INTEGER NXTASK 3851 INTEGER next 3852 INTEGER nprocs 3853 INTEGER count 3854 INTEGER p3b 3855 INTEGER p4b 3856 INTEGER h1b 3857 INTEGER p5b 3858 INTEGER dimc 3859 INTEGER l_c_sort 3860 INTEGER k_c_sort 3861 INTEGER p6b 3862 INTEGER p6b_1 3863 INTEGER h1b_1 3864 INTEGER p3b_2 3865 INTEGER p4b_2 3866 INTEGER p5b_2 3867 INTEGER p6b_2 3868 INTEGER dim_common 3869 INTEGER dima_sort 3870 INTEGER dima 3871 INTEGER dimb_sort 3872 INTEGER dimb 3873 INTEGER l_a_sort 3874 INTEGER k_a_sort 3875 INTEGER l_a 3876 INTEGER k_a 3877 INTEGER l_b_sort 3878 INTEGER k_b_sort 3879 INTEGER l_b 3880 INTEGER k_b 3881 INTEGER l_c 3882 INTEGER k_c 3883 EXTERNAL NXTASK 3884 nprocs = GA_NNODES() 3885 count = 0 3886 next = NXTASK(nprocs,1) 3887 DO p3b = noab+1,noab+nvab 3888 DO p4b = p3b,noab+nvab 3889 DO h1b = 1,noab 3890 DO p5b = noab+1,noab+nvab 3891 IF (next.eq.count) THEN 3892 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 3893 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 3894 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 3895 &1b-1)+int_mb(k_spin+p5b-1)) THEN 3896 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 3897 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 3898 &EN 3899 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 3900 &nge+h1b-1) * int_mb(k_range+p5b-1) 3901 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3902 & ERRQUIT('ccsdt_t2_3_2',0,MA_ERR) 3903 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3904 DO p6b = noab+1,noab+nvab 3905 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3906 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 3907 &EN 3908 CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1) 3909 CALL TCE_RESTRICTED_4(p3b,p4b,p5b,p6b,p3b_2,p4b_2,p5b_2,p6b_2) 3910 dim_common = int_mb(k_range+p6b-1) 3911 dima_sort = int_mb(k_range+h1b-1) 3912 dima = dim_common * dima_sort 3913 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb 3914 &(k_range+p5b-1) 3915 dimb = dim_common * dimb_sort 3916 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3917 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3918 & ERRQUIT('ccsdt_t2_3_2',1,MA_ERR) 3919 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3920 &ccsdt_t2_3_2',2,MA_ERR) 3921 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 3922 & - 1 + noab * (p6b_1 - noab - 1))) 3923 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 3924 &,int_mb(k_range+h1b-1),2,1,1.0d0) 3925 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_3_2',3,MA_ERR) 3926 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3927 & ERRQUIT('ccsdt_t2_3_2',4,MA_ERR) 3928 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3929 &ccsdt_t2_3_2',5,MA_ERR) 3930 IF ((p6b .lt. p5b)) THEN 3931 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 3932 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab 3933 &+nvab) * (p3b_2 - 1))))) 3934 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1) 3935 &,int_mb(k_range+p4b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 3936 &,4,2,1,3,-1.0d0) 3937 END IF 3938 IF ((p5b .le. p6b)) THEN 3939 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 3940 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab 3941 &+nvab) * (p3b_2 - 1))))) 3942 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1) 3943 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 3944 &,3,2,1,4,1.0d0) 3945 END IF 3946 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_3_2',6,MA_ERR) 3947 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3948 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3949 &t),dima_sort) 3950 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_3_2',7,MA_ 3951 &ERR) 3952 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_3_2',8,MA_ 3953 &ERR) 3954 END IF 3955 END IF 3956 END IF 3957 END DO 3958 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3959 &ccsdt_t2_3_2',9,MA_ERR) 3960 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 3961 &,int_mb(k_range+p4b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 3962 &,3,2,4,1,-1.0d0/2.0d0) 3963 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 3964 & noab - 1 + nvab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b 3965 & - noab - 1))))) 3966 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_3_2',10,MA_ERR) 3967 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_3_2',11,MA 3968 &_ERR) 3969 END IF 3970 END IF 3971 END IF 3972 next = NXTASK(nprocs,1) 3973 END IF 3974 count = count + 1 3975 END DO 3976 END DO 3977 END DO 3978 END DO 3979 next = NXTASK(-nprocs,1) 3980 call GA_SYNC() 3981 RETURN 3982 END 3983 SUBROUTINE ccsdt_t2a_4(d_a,k_a_offset,d_b,k_b_offset,d_c, 3984 &k_c_offset) 3985C $Id$ 3986C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3987C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3988C i0 ( p3 p4 h1 h2 )_tf + = -1 * P( 2 ) * Sum ( h9 ) * t ( p3 p4 h1 h9 )_t * i1 ( h9 h2 )_f 3989 IMPLICIT NONE 3990#include "global.fh" 3991#include "mafdecls.fh" 3992#include "sym.fh" 3993#include "errquit.fh" 3994#include "tce.fh" 3995 INTEGER d_a 3996 INTEGER k_a_offset 3997 INTEGER d_b 3998 INTEGER k_b_offset 3999 INTEGER d_c 4000 INTEGER k_c_offset 4001 INTEGER NXTASK 4002 INTEGER next 4003 INTEGER nprocs 4004 INTEGER count 4005 INTEGER p3b 4006 INTEGER p4b 4007 INTEGER h1b 4008 INTEGER h2b 4009 INTEGER dimc 4010 INTEGER l_c_sort 4011 INTEGER k_c_sort 4012 INTEGER h9b 4013 INTEGER p3b_1 4014 INTEGER p4b_1 4015 INTEGER h1b_1 4016 INTEGER h9b_1 4017 INTEGER h9b_2 4018 INTEGER h2b_2 4019 INTEGER dim_common 4020 INTEGER dima_sort 4021 INTEGER dima 4022 INTEGER dimb_sort 4023 INTEGER dimb 4024 INTEGER l_a_sort 4025 INTEGER k_a_sort 4026 INTEGER l_a 4027 INTEGER k_a 4028 INTEGER l_b_sort 4029 INTEGER k_b_sort 4030 INTEGER l_b 4031 INTEGER k_b 4032 INTEGER l_c 4033 INTEGER k_c 4034 EXTERNAL NXTASK 4035 nprocs = GA_NNODES() 4036 count = 0 4037 next = NXTASK(nprocs,1) 4038 DO p3b = noab+1,noab+nvab 4039 DO p4b = p3b,noab+nvab 4040 DO h1b = 1,noab 4041 DO h2b = 1,noab 4042 IF (next.eq.count) THEN 4043 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 4044 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 4045 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 4046 &1b-1)+int_mb(k_spin+h2b-1)) THEN 4047 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 4048 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_t,irrep_f)) TH 4049 &EN 4050 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 4051 &nge+h1b-1) * int_mb(k_range+h2b-1) 4052 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4053 & ERRQUIT('ccsdt_t2_4',0,MA_ERR) 4054 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4055 DO h9b = 1,noab 4056 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 4057 &1b-1)+int_mb(k_spin+h9b-1)) THEN 4058 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 4059 &k_sym+h1b-1),int_mb(k_sym+h9b-1)))) .eq. irrep_t) THEN 4060 CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h9b,p3b_1,p4b_1,h1b_1,h9b_1) 4061 CALL TCE_RESTRICTED_2(h9b,h2b,h9b_2,h2b_2) 4062 dim_common = int_mb(k_range+h9b-1) 4063 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb 4064 &(k_range+h1b-1) 4065 dima = dim_common * dima_sort 4066 dimb_sort = int_mb(k_range+h2b-1) 4067 dimb = dim_common * dimb_sort 4068 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4069 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4070 & ERRQUIT('ccsdt_t2_4',1,MA_ERR) 4071 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4072 &ccsdt_t2_4',2,MA_ERR) 4073 IF ((h9b .lt. h1b)) THEN 4074 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 4075 & - 1 + noab * (h9b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 4076 &1 - noab - 1))))) 4077 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4078 &,int_mb(k_range+p4b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1) 4079 &,4,2,1,3,-1.0d0) 4080 END IF 4081 IF ((h1b .le. h9b)) THEN 4082 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h9b_1 4083 & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 4084 &1 - noab - 1))))) 4085 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4086 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h9b-1) 4087 &,3,2,1,4,1.0d0) 4088 END IF 4089 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_4',3,MA_ERR) 4090 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4091 & ERRQUIT('ccsdt_t2_4',4,MA_ERR) 4092 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4093 &ccsdt_t2_4',5,MA_ERR) 4094 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 4095 & - 1 + noab * (h9b_2 - 1))) 4096 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 4097 &,int_mb(k_range+h2b-1),2,1,1.0d0) 4098 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_4',6,MA_ERR) 4099 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4100 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4101 &t),dima_sort) 4102 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_4',7,MA_ER 4103 &R) 4104 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_4',8,MA_ER 4105 &R) 4106 END IF 4107 END IF 4108 END IF 4109 END DO 4110 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4111 &ccsdt_t2_4',9,MA_ERR) 4112 IF ((h1b .le. h2b)) THEN 4113 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 4114 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 4115 &,4,3,2,1,-1.0d0) 4116 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 4117 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 4118 & - 1))))) 4119 END IF 4120 IF ((h2b .le. h1b)) THEN 4121 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 4122 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 4123 &,4,3,1,2,1.0d0) 4124 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 4125 & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 4126 & - 1))))) 4127 END IF 4128 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_4',10,MA_ERR) 4129 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_4',11,MA_E 4130 &RR) 4131 END IF 4132 END IF 4133 END IF 4134 next = NXTASK(nprocs,1) 4135 END IF 4136 count = count + 1 4137 END DO 4138 END DO 4139 END DO 4140 END DO 4141 next = NXTASK(-nprocs,1) 4142 call GA_SYNC() 4143 RETURN 4144 END 4145 SUBROUTINE ccsdt_t2a_4_1(d_a,k_a_offset,d_c,k_c_offset) 4146C $Id$ 4147C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4148C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4149C i1 ( h9 h1 )_f + = 1 * f ( h9 h1 )_f 4150 IMPLICIT NONE 4151#include "global.fh" 4152#include "mafdecls.fh" 4153#include "sym.fh" 4154#include "errquit.fh" 4155#include "tce.fh" 4156 INTEGER d_a 4157 INTEGER k_a_offset 4158 INTEGER d_c 4159 INTEGER k_c_offset 4160 INTEGER NXTASK 4161 INTEGER next 4162 INTEGER nprocs 4163 INTEGER count 4164 INTEGER h9b 4165 INTEGER h1b 4166 INTEGER dimc 4167 INTEGER h9b_1 4168 INTEGER h1b_1 4169 INTEGER dim_common 4170 INTEGER dima_sort 4171 INTEGER dima 4172 INTEGER l_a_sort 4173 INTEGER k_a_sort 4174 INTEGER l_a 4175 INTEGER k_a 4176 INTEGER l_c 4177 INTEGER k_c 4178 EXTERNAL NXTASK 4179 nprocs = GA_NNODES() 4180 count = 0 4181 next = NXTASK(nprocs,1) 4182 DO h9b = 1,noab 4183 DO h1b = 1,noab 4184 IF (next.eq.count) THEN 4185 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1 4186 &).ne.4)) THEN 4187 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4188 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 4189 &EN 4190 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) 4191 CALL TCE_RESTRICTED_2(h9b,h1b,h9b_1,h1b_1) 4192 dim_common = 1 4193 dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) 4194 dima = dim_common * dima_sort 4195 IF (dima .gt. 0) THEN 4196 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4197 & ERRQUIT('ccsdt_t2_4_1',0,MA_ERR) 4198 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4199 &ccsdt_t2_4_1',1,MA_ERR) 4200 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 4201 & - 1 + (noab+nvab) * (h9b_1 - 1))) 4202 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 4203 &,int_mb(k_range+h1b-1),2,1,1.0d0) 4204 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_4_1',2,MA_ERR) 4205 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4206 &ccsdt_t2_4_1',3,MA_ERR) 4207 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 4208 &,int_mb(k_range+h9b-1),2,1,1.0d0) 4209 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 4210 & 1 + noab * (h9b - 1))) 4211 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_4_1',4,MA_ERR) 4212 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_4_1',5,MA_ 4213 &ERR) 4214 END IF 4215 END IF 4216 END IF 4217 END IF 4218 next = NXTASK(nprocs,1) 4219 END IF 4220 count = count + 1 4221 END DO 4222 END DO 4223 next = NXTASK(-nprocs,1) 4224 call GA_SYNC() 4225 RETURN 4226 END 4227 SUBROUTINE OFFSET_ccsdt_t2a_4_1(l_a_offset,k_a_offset,size) 4228C $Id$ 4229C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4230C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4231C i1 ( h9 h1 )_f 4232 IMPLICIT NONE 4233#include "global.fh" 4234#include "mafdecls.fh" 4235#include "sym.fh" 4236#include "errquit.fh" 4237#include "tce.fh" 4238 INTEGER l_a_offset 4239 INTEGER k_a_offset 4240 INTEGER size 4241 INTEGER length 4242 INTEGER addr 4243 INTEGER h9b 4244 INTEGER h1b 4245 length = 0 4246 DO h9b = 1,noab 4247 DO h1b = 1,noab 4248 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4249 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 4250 &EN 4251 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1 4252 &).ne.4)) THEN 4253 length = length + 1 4254 END IF 4255 END IF 4256 END IF 4257 END DO 4258 END DO 4259 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 4260 &set)) CALL ERRQUIT('ccsdt_t2_4_1',0,MA_ERR) 4261 int_mb(k_a_offset) = length 4262 addr = 0 4263 size = 0 4264 DO h9b = 1,noab 4265 DO h1b = 1,noab 4266 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4267 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 4268 &EN 4269 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1 4270 &).ne.4)) THEN 4271 addr = addr + 1 4272 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h9b - 1) 4273 int_mb(k_a_offset+length+addr) = size 4274 size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) 4275 END IF 4276 END IF 4277 END IF 4278 END DO 4279 END DO 4280 RETURN 4281 END 4282 SUBROUTINE ccsdt_t2a_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 4283 &k_c_offset) 4284C $Id$ 4285C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4286C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4287C i1 ( h9 h1 )_ft + = 1 * Sum ( p8 ) * t ( p8 h1 )_t * i2 ( h9 p8 )_f 4288 IMPLICIT NONE 4289#include "global.fh" 4290#include "mafdecls.fh" 4291#include "sym.fh" 4292#include "errquit.fh" 4293#include "tce.fh" 4294 INTEGER d_a 4295 INTEGER k_a_offset 4296 INTEGER d_b 4297 INTEGER k_b_offset 4298 INTEGER d_c 4299 INTEGER k_c_offset 4300 INTEGER NXTASK 4301 INTEGER next 4302 INTEGER nprocs 4303 INTEGER count 4304 INTEGER h9b 4305 INTEGER h1b 4306 INTEGER dimc 4307 INTEGER l_c_sort 4308 INTEGER k_c_sort 4309 INTEGER p8b 4310 INTEGER p8b_1 4311 INTEGER h1b_1 4312 INTEGER h9b_2 4313 INTEGER p8b_2 4314 INTEGER dim_common 4315 INTEGER dima_sort 4316 INTEGER dima 4317 INTEGER dimb_sort 4318 INTEGER dimb 4319 INTEGER l_a_sort 4320 INTEGER k_a_sort 4321 INTEGER l_a 4322 INTEGER k_a 4323 INTEGER l_b_sort 4324 INTEGER k_b_sort 4325 INTEGER l_b 4326 INTEGER k_b 4327 INTEGER l_c 4328 INTEGER k_c 4329 EXTERNAL NXTASK 4330 nprocs = GA_NNODES() 4331 count = 0 4332 next = NXTASK(nprocs,1) 4333 DO h9b = 1,noab 4334 DO h1b = 1,noab 4335 IF (next.eq.count) THEN 4336 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1 4337 &).ne.4)) THEN 4338 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4339 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 4340 &f,irrep_t)) THEN 4341 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) 4342 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4343 & ERRQUIT('ccsdt_t2_4_2',0,MA_ERR) 4344 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4345 DO p8b = noab+1,noab+nvab 4346 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4347 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 4348 &EN 4349 CALL TCE_RESTRICTED_2(p8b,h1b,p8b_1,h1b_1) 4350 CALL TCE_RESTRICTED_2(h9b,p8b,h9b_2,p8b_2) 4351 dim_common = int_mb(k_range+p8b-1) 4352 dima_sort = int_mb(k_range+h1b-1) 4353 dima = dim_common * dima_sort 4354 dimb_sort = int_mb(k_range+h9b-1) 4355 dimb = dim_common * dimb_sort 4356 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4357 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4358 & ERRQUIT('ccsdt_t2_4_2',1,MA_ERR) 4359 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4360 &ccsdt_t2_4_2',2,MA_ERR) 4361 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 4362 & - 1 + noab * (p8b_1 - noab - 1))) 4363 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 4364 &,int_mb(k_range+h1b-1),2,1,1.0d0) 4365 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_4_2',3,MA_ERR) 4366 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4367 & ERRQUIT('ccsdt_t2_4_2',4,MA_ERR) 4368 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4369 &ccsdt_t2_4_2',5,MA_ERR) 4370 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 4371 & - noab - 1 + nvab * (h9b_2 - 1))) 4372 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 4373 &,int_mb(k_range+p8b-1),1,2,1.0d0) 4374 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_4_2',6,MA_ERR) 4375 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4376 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4377 &t),dima_sort) 4378 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_4_2',7,MA_ 4379 &ERR) 4380 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_4_2',8,MA_ 4381 &ERR) 4382 END IF 4383 END IF 4384 END IF 4385 END DO 4386 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4387 &ccsdt_t2_4_2',9,MA_ERR) 4388 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h9b-1) 4389 &,int_mb(k_range+h1b-1),1,2,1.0d0) 4390 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 4391 & 1 + noab * (h9b - 1))) 4392 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_4_2',10,MA_ERR) 4393 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_4_2',11,MA 4394 &_ERR) 4395 END IF 4396 END IF 4397 END IF 4398 next = NXTASK(nprocs,1) 4399 END IF 4400 count = count + 1 4401 END DO 4402 END DO 4403 next = NXTASK(-nprocs,1) 4404 call GA_SYNC() 4405 RETURN 4406 END 4407 SUBROUTINE ccsdt_t2a_4_2_1(d_a,k_a_offset,d_c,k_c_offset) 4408C $Id$ 4409C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4410C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4411C i2 ( h9 p8 )_f + = 1 * f ( h9 p8 )_f 4412 IMPLICIT NONE 4413#include "global.fh" 4414#include "mafdecls.fh" 4415#include "sym.fh" 4416#include "errquit.fh" 4417#include "tce.fh" 4418 INTEGER d_a 4419 INTEGER k_a_offset 4420 INTEGER d_c 4421 INTEGER k_c_offset 4422 INTEGER NXTASK 4423 INTEGER next 4424 INTEGER nprocs 4425 INTEGER count 4426 INTEGER h9b 4427 INTEGER p8b 4428 INTEGER dimc 4429 INTEGER h9b_1 4430 INTEGER p8b_1 4431 INTEGER dim_common 4432 INTEGER dima_sort 4433 INTEGER dima 4434 INTEGER l_a_sort 4435 INTEGER k_a_sort 4436 INTEGER l_a 4437 INTEGER k_a 4438 INTEGER l_c 4439 INTEGER k_c 4440 EXTERNAL NXTASK 4441 nprocs = GA_NNODES() 4442 count = 0 4443 next = NXTASK(nprocs,1) 4444 DO h9b = 1,noab 4445 DO p8b = noab+1,noab+nvab 4446 IF (next.eq.count) THEN 4447 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1 4448 &).ne.4)) THEN 4449 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN 4450 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH 4451 &EN 4452 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1) 4453 CALL TCE_RESTRICTED_2(h9b,p8b,h9b_1,p8b_1) 4454 dim_common = 1 4455 dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1) 4456 dima = dim_common * dima_sort 4457 IF (dima .gt. 0) THEN 4458 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4459 & ERRQUIT('ccsdt_t2_4_2_1',0,MA_ERR) 4460 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4461 &ccsdt_t2_4_2_1',1,MA_ERR) 4462 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1 4463 & - 1 + (noab+nvab) * (h9b_1 - 1))) 4464 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 4465 &,int_mb(k_range+p8b-1),2,1,1.0d0) 4466 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_4_2_1',2,MA_ERR 4467 &) 4468 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4469 &ccsdt_t2_4_2_1',3,MA_ERR) 4470 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 4471 &,int_mb(k_range+h9b-1),2,1,1.0d0) 4472 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 4473 & noab - 1 + nvab * (h9b - 1))) 4474 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_4_2_1',4,MA_ERR 4475 &) 4476 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_4_2_1',5,M 4477 &A_ERR) 4478 END IF 4479 END IF 4480 END IF 4481 END IF 4482 next = NXTASK(nprocs,1) 4483 END IF 4484 count = count + 1 4485 END DO 4486 END DO 4487 next = NXTASK(-nprocs,1) 4488 call GA_SYNC() 4489 RETURN 4490 END 4491 SUBROUTINE OFFSET_ccsdt_t2a_4_2_1(l_a_offset,k_a_offset,size) 4492C $Id$ 4493C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4494C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4495C i2 ( h9 p8 )_f 4496 IMPLICIT NONE 4497#include "global.fh" 4498#include "mafdecls.fh" 4499#include "sym.fh" 4500#include "errquit.fh" 4501#include "tce.fh" 4502 INTEGER l_a_offset 4503 INTEGER k_a_offset 4504 INTEGER size 4505 INTEGER length 4506 INTEGER addr 4507 INTEGER h9b 4508 INTEGER p8b 4509 length = 0 4510 DO h9b = 1,noab 4511 DO p8b = noab+1,noab+nvab 4512 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN 4513 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH 4514 &EN 4515 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1 4516 &).ne.4)) THEN 4517 length = length + 1 4518 END IF 4519 END IF 4520 END IF 4521 END DO 4522 END DO 4523 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 4524 &set)) CALL ERRQUIT('ccsdt_t2_4_2_1',0,MA_ERR) 4525 int_mb(k_a_offset) = length 4526 addr = 0 4527 size = 0 4528 DO h9b = 1,noab 4529 DO p8b = noab+1,noab+nvab 4530 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN 4531 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH 4532 &EN 4533 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1 4534 &).ne.4)) THEN 4535 addr = addr + 1 4536 int_mb(k_a_offset+addr) = p8b - noab - 1 + nvab * (h9b - 1) 4537 int_mb(k_a_offset+length+addr) = size 4538 size = size + int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1) 4539 END IF 4540 END IF 4541 END IF 4542 END DO 4543 END DO 4544 RETURN 4545 END 4546 SUBROUTINE ccsdt_t2a_4_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 4547 &k_c_offset) 4548C $Id$ 4549C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4550C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4551C i2 ( h9 p8 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 p6 p8 )_v 4552 IMPLICIT NONE 4553#include "global.fh" 4554#include "mafdecls.fh" 4555#include "sym.fh" 4556#include "errquit.fh" 4557#include "tce.fh" 4558 INTEGER d_a 4559 INTEGER k_a_offset 4560 INTEGER d_b 4561 INTEGER k_b_offset 4562 INTEGER d_c 4563 INTEGER k_c_offset 4564 INTEGER NXTASK 4565 INTEGER next 4566 INTEGER nprocs 4567 INTEGER count 4568 INTEGER h9b 4569 INTEGER p8b 4570 INTEGER dimc 4571 INTEGER l_c_sort 4572 INTEGER k_c_sort 4573 INTEGER p6b 4574 INTEGER h7b 4575 INTEGER p6b_1 4576 INTEGER h7b_1 4577 INTEGER h9b_2 4578 INTEGER h7b_2 4579 INTEGER p8b_2 4580 INTEGER p6b_2 4581 INTEGER dim_common 4582 INTEGER dima_sort 4583 INTEGER dima 4584 INTEGER dimb_sort 4585 INTEGER dimb 4586 INTEGER l_a_sort 4587 INTEGER k_a_sort 4588 INTEGER l_a 4589 INTEGER k_a 4590 INTEGER l_b_sort 4591 INTEGER k_b_sort 4592 INTEGER l_b 4593 INTEGER k_b 4594 INTEGER l_c 4595 INTEGER k_c 4596 EXTERNAL NXTASK 4597 nprocs = GA_NNODES() 4598 count = 0 4599 next = NXTASK(nprocs,1) 4600 DO h9b = 1,noab 4601 DO p8b = noab+1,noab+nvab 4602 IF (next.eq.count) THEN 4603 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1 4604 &).ne.4)) THEN 4605 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN 4606 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. ieor(irrep_ 4607 &v,irrep_t)) THEN 4608 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1) 4609 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4610 & ERRQUIT('ccsdt_t2_4_2_2',0,MA_ERR) 4611 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4612 DO p6b = noab+1,noab+nvab 4613 DO h7b = 1,noab 4614 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4615 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 4616 &EN 4617 CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1) 4618 CALL TCE_RESTRICTED_4(h9b,h7b,p8b,p6b,h9b_2,h7b_2,p8b_2,p6b_2) 4619 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1) 4620 dima_sort = 1 4621 dima = dim_common * dima_sort 4622 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1) 4623 dimb = dim_common * dimb_sort 4624 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4625 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4626 & ERRQUIT('ccsdt_t2_4_2_2',1,MA_ERR) 4627 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4628 &ccsdt_t2_4_2_2',2,MA_ERR) 4629 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 4630 & - 1 + noab * (p6b_1 - noab - 1))) 4631 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 4632 &,int_mb(k_range+h7b-1),2,1,1.0d0) 4633 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_4_2_2',3,MA_ERR 4634 &) 4635 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4636 & ERRQUIT('ccsdt_t2_4_2_2',4,MA_ERR) 4637 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4638 &ccsdt_t2_4_2_2',5,MA_ERR) 4639 IF ((h7b .le. h9b) .and. (p6b .le. p8b)) THEN 4640 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 4641 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 4642 &+nvab) * (h7b_2 - 1))))) 4643 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 4644 &,int_mb(k_range+h9b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1) 4645 &,4,2,1,3,1.0d0) 4646 END IF 4647 IF ((h7b .le. h9b) .and. (p8b .lt. p6b)) THEN 4648 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 4649 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 4650 &+nvab) * (h7b_2 - 1))))) 4651 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 4652 &,int_mb(k_range+h9b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1) 4653 &,3,2,1,4,-1.0d0) 4654 END IF 4655 IF ((h9b .lt. h7b) .and. (p6b .le. p8b)) THEN 4656 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 4657 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 4658 &+nvab) * (h9b_2 - 1))))) 4659 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 4660 &,int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1) 4661 &,4,1,2,3,-1.0d0) 4662 END IF 4663 IF ((h9b .lt. h7b) .and. (p8b .lt. p6b)) THEN 4664 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 4665 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 4666 &+nvab) * (h9b_2 - 1))))) 4667 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 4668 &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1) 4669 &,3,1,2,4,1.0d0) 4670 END IF 4671 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_4_2_2',6,MA_ERR 4672 &) 4673 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4674 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4675 &t),dima_sort) 4676 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_4_2_2',7,M 4677 &A_ERR) 4678 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_4_2_2',8,M 4679 &A_ERR) 4680 END IF 4681 END IF 4682 END IF 4683 END DO 4684 END DO 4685 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4686 &ccsdt_t2_4_2_2',9,MA_ERR) 4687 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 4688 &,int_mb(k_range+h9b-1),2,1,1.0d0) 4689 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 4690 & noab - 1 + nvab * (h9b - 1))) 4691 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_4_2_2',10,MA_ER 4692 &R) 4693 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_4_2_2',11, 4694 &MA_ERR) 4695 END IF 4696 END IF 4697 END IF 4698 next = NXTASK(nprocs,1) 4699 END IF 4700 count = count + 1 4701 END DO 4702 END DO 4703 next = NXTASK(-nprocs,1) 4704 call GA_SYNC() 4705 RETURN 4706 END 4707 SUBROUTINE ccsdt_t2a_4_3(d_a,k_a_offset,d_b,k_b_offset,d_c, 4708 &k_c_offset) 4709C $Id$ 4710C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4711C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4712C i1 ( h9 h1 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 h1 p6 )_v 4713 IMPLICIT NONE 4714#include "global.fh" 4715#include "mafdecls.fh" 4716#include "sym.fh" 4717#include "errquit.fh" 4718#include "tce.fh" 4719 INTEGER d_a 4720 INTEGER k_a_offset 4721 INTEGER d_b 4722 INTEGER k_b_offset 4723 INTEGER d_c 4724 INTEGER k_c_offset 4725 INTEGER NXTASK 4726 INTEGER next 4727 INTEGER nprocs 4728 INTEGER count 4729 INTEGER h9b 4730 INTEGER h1b 4731 INTEGER dimc 4732 INTEGER l_c_sort 4733 INTEGER k_c_sort 4734 INTEGER p6b 4735 INTEGER h7b 4736 INTEGER p6b_1 4737 INTEGER h7b_1 4738 INTEGER h9b_2 4739 INTEGER h7b_2 4740 INTEGER h1b_2 4741 INTEGER p6b_2 4742 INTEGER dim_common 4743 INTEGER dima_sort 4744 INTEGER dima 4745 INTEGER dimb_sort 4746 INTEGER dimb 4747 INTEGER l_a_sort 4748 INTEGER k_a_sort 4749 INTEGER l_a 4750 INTEGER k_a 4751 INTEGER l_b_sort 4752 INTEGER k_b_sort 4753 INTEGER l_b 4754 INTEGER k_b 4755 INTEGER l_c 4756 INTEGER k_c 4757 EXTERNAL NXTASK 4758 nprocs = GA_NNODES() 4759 count = 0 4760 next = NXTASK(nprocs,1) 4761 DO h9b = 1,noab 4762 DO h1b = 1,noab 4763 IF (next.eq.count) THEN 4764 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1 4765 &).ne.4)) THEN 4766 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4767 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 4768 &v,irrep_t)) THEN 4769 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) 4770 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4771 & ERRQUIT('ccsdt_t2_4_3',0,MA_ERR) 4772 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4773 DO p6b = noab+1,noab+nvab 4774 DO h7b = 1,noab 4775 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4776 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 4777 &EN 4778 CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1) 4779 CALL TCE_RESTRICTED_4(h9b,h7b,h1b,p6b,h9b_2,h7b_2,h1b_2,p6b_2) 4780 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1) 4781 dima_sort = 1 4782 dima = dim_common * dima_sort 4783 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) 4784 dimb = dim_common * dimb_sort 4785 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4786 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4787 & ERRQUIT('ccsdt_t2_4_3',1,MA_ERR) 4788 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4789 &ccsdt_t2_4_3',2,MA_ERR) 4790 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 4791 & - 1 + noab * (p6b_1 - noab - 1))) 4792 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 4793 &,int_mb(k_range+h7b-1),2,1,1.0d0) 4794 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_4_3',3,MA_ERR) 4795 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4796 & ERRQUIT('ccsdt_t2_4_3',4,MA_ERR) 4797 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4798 &ccsdt_t2_4_3',5,MA_ERR) 4799 IF ((h7b .le. h9b) .and. (h1b .le. p6b)) THEN 4800 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 4801 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 4802 &+nvab) * (h7b_2 - 1))))) 4803 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 4804 &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 4805 &,3,2,1,4,1.0d0) 4806 END IF 4807 IF ((h9b .lt. h7b) .and. (h1b .le. p6b)) THEN 4808 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 4809 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 4810 &+nvab) * (h9b_2 - 1))))) 4811 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 4812 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1) 4813 &,3,1,2,4,-1.0d0) 4814 END IF 4815 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_4_3',6,MA_ERR) 4816 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4817 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4818 &t),dima_sort) 4819 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_4_3',7,MA_ 4820 &ERR) 4821 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_4_3',8,MA_ 4822 &ERR) 4823 END IF 4824 END IF 4825 END IF 4826 END DO 4827 END DO 4828 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4829 &ccsdt_t2_4_3',9,MA_ERR) 4830 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 4831 &,int_mb(k_range+h9b-1),2,1,-1.0d0) 4832 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 4833 & 1 + noab * (h9b - 1))) 4834 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_4_3',10,MA_ERR) 4835 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_4_3',11,MA 4836 &_ERR) 4837 END IF 4838 END IF 4839 END IF 4840 next = NXTASK(nprocs,1) 4841 END IF 4842 count = count + 1 4843 END DO 4844 END DO 4845 next = NXTASK(-nprocs,1) 4846 call GA_SYNC() 4847 RETURN 4848 END 4849 SUBROUTINE ccsdt_t2a_4_4(d_a,k_a_offset,d_b,k_b_offset,d_c, 4850 &k_c_offset) 4851C $Id$ 4852C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4853C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4854C i1 ( h9 h1 )_vt + = -1/2 * Sum ( h8 p6 p7 ) * t ( p6 p7 h1 h8 )_t * v ( h8 h9 p6 p7 )_v 4855 IMPLICIT NONE 4856#include "global.fh" 4857#include "mafdecls.fh" 4858#include "sym.fh" 4859#include "errquit.fh" 4860#include "tce.fh" 4861 INTEGER d_a 4862 INTEGER k_a_offset 4863 INTEGER d_b 4864 INTEGER k_b_offset 4865 INTEGER d_c 4866 INTEGER k_c_offset 4867 INTEGER NXTASK 4868 INTEGER next 4869 INTEGER nprocs 4870 INTEGER count 4871 INTEGER h9b 4872 INTEGER h1b 4873 INTEGER dimc 4874 INTEGER l_c_sort 4875 INTEGER k_c_sort 4876 INTEGER p6b 4877 INTEGER p7b 4878 INTEGER h8b 4879 INTEGER p6b_1 4880 INTEGER p7b_1 4881 INTEGER h1b_1 4882 INTEGER h8b_1 4883 INTEGER h9b_2 4884 INTEGER h8b_2 4885 INTEGER p6b_2 4886 INTEGER p7b_2 4887 INTEGER dim_common 4888 INTEGER dima_sort 4889 INTEGER dima 4890 INTEGER dimb_sort 4891 INTEGER dimb 4892 INTEGER l_a_sort 4893 INTEGER k_a_sort 4894 INTEGER l_a 4895 INTEGER k_a 4896 INTEGER l_b_sort 4897 INTEGER k_b_sort 4898 INTEGER l_b 4899 INTEGER k_b 4900 INTEGER nsuperp(2) 4901 INTEGER isuperp 4902 INTEGER l_c 4903 INTEGER k_c 4904 DOUBLE PRECISION FACTORIAL 4905 EXTERNAL NXTASK 4906 EXTERNAL FACTORIAL 4907 nprocs = GA_NNODES() 4908 count = 0 4909 next = NXTASK(nprocs,1) 4910 DO h9b = 1,noab 4911 DO h1b = 1,noab 4912 IF (next.eq.count) THEN 4913 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1 4914 &).ne.4)) THEN 4915 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4916 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 4917 &v,irrep_t)) THEN 4918 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1) 4919 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4920 & ERRQUIT('ccsdt_t2_4_4',0,MA_ERR) 4921 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4922 DO p6b = noab+1,noab+nvab 4923 DO p7b = p6b,noab+nvab 4924 DO h8b = 1,noab 4925 IF (int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h 4926 &1b-1)+int_mb(k_spin+h8b-1)) THEN 4927 IF (ieor(int_mb(k_sym+p6b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb( 4928 &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_t) THEN 4929 CALL TCE_RESTRICTED_4(p6b,p7b,h1b,h8b,p6b_1,p7b_1,h1b_1,h8b_1) 4930 CALL TCE_RESTRICTED_4(h9b,h8b,p6b,p7b,h9b_2,h8b_2,p6b_2,p7b_2) 4931 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+p7b-1) * int_m 4932 &b(k_range+h8b-1) 4933 dima_sort = int_mb(k_range+h1b-1) 4934 dima = dim_common * dima_sort 4935 dimb_sort = int_mb(k_range+h9b-1) 4936 dimb = dim_common * dimb_sort 4937 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4938 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4939 & ERRQUIT('ccsdt_t2_4_4',1,MA_ERR) 4940 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4941 &ccsdt_t2_4_4',2,MA_ERR) 4942 IF ((h8b .lt. h1b)) THEN 4943 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 4944 & - 1 + noab * (h8b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p6b_ 4945 &1 - noab - 1))))) 4946 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 4947 &,int_mb(k_range+p7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) 4948 &,4,3,2,1,-1.0d0) 4949 END IF 4950 IF ((h1b .le. h8b)) THEN 4951 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 4952 & - 1 + noab * (h1b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p6b_ 4953 &1 - noab - 1))))) 4954 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 4955 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) 4956 &,3,4,2,1,1.0d0) 4957 END IF 4958 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_4_4',3,MA_ERR) 4959 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4960 & ERRQUIT('ccsdt_t2_4_4',4,MA_ERR) 4961 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4962 &ccsdt_t2_4_4',5,MA_ERR) 4963 IF ((h8b .le. h9b)) THEN 4964 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 4965 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 4966 &+nvab) * (h8b_2 - 1))))) 4967 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 4968 &,int_mb(k_range+h9b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b-1) 4969 &,2,1,4,3,1.0d0) 4970 END IF 4971 IF ((h9b .lt. h8b)) THEN 4972 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 4973 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 4974 &+nvab) * (h9b_2 - 1))))) 4975 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 4976 &,int_mb(k_range+h8b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b-1) 4977 &,1,2,4,3,-1.0d0) 4978 END IF 4979 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_4_4',6,MA_ERR) 4980 nsuperp(1) = 1 4981 nsuperp(2) = 1 4982 isuperp = 1 4983 IF (p6b .eq. p7b) THEN 4984 nsuperp(isuperp) = nsuperp(isuperp) + 1 4985 ELSE 4986 isuperp = isuperp + 1 4987 END IF 4988 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 4989 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 4990 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 4991 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_4_4',7,MA_ 4992 &ERR) 4993 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_4_4',8,MA_ 4994 &ERR) 4995 END IF 4996 END IF 4997 END IF 4998 END DO 4999 END DO 5000 END DO 5001 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5002 &ccsdt_t2_4_4',9,MA_ERR) 5003 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h9b-1) 5004 &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0) 5005 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 5006 & 1 + noab * (h9b - 1))) 5007 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_4_4',10,MA_ERR) 5008 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_4_4',11,MA 5009 &_ERR) 5010 END IF 5011 END IF 5012 END IF 5013 next = NXTASK(nprocs,1) 5014 END IF 5015 count = count + 1 5016 END DO 5017 END DO 5018 next = NXTASK(-nprocs,1) 5019 call GA_SYNC() 5020 RETURN 5021 END 5022 SUBROUTINE ccsdt_t2a_5(d_a,k_a_offset,d_b,k_b_offset,d_c, 5023 &k_c_offset) 5024C $Id$ 5025C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5026C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5027C i0 ( p3 p4 h1 h2 )_tf + = 1 * P( 2 ) * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i1 ( p4 p5 )_f 5028 IMPLICIT NONE 5029#include "global.fh" 5030#include "mafdecls.fh" 5031#include "sym.fh" 5032#include "errquit.fh" 5033#include "tce.fh" 5034 INTEGER d_a 5035 INTEGER k_a_offset 5036 INTEGER d_b 5037 INTEGER k_b_offset 5038 INTEGER d_c 5039 INTEGER k_c_offset 5040 INTEGER NXTASK 5041 INTEGER next 5042 INTEGER nprocs 5043 INTEGER count 5044 INTEGER p3b 5045 INTEGER p4b 5046 INTEGER h1b 5047 INTEGER h2b 5048 INTEGER dimc 5049 INTEGER l_c_sort 5050 INTEGER k_c_sort 5051 INTEGER p5b 5052 INTEGER p3b_1 5053 INTEGER p5b_1 5054 INTEGER h1b_1 5055 INTEGER h2b_1 5056 INTEGER p4b_2 5057 INTEGER p5b_2 5058 INTEGER dim_common 5059 INTEGER dima_sort 5060 INTEGER dima 5061 INTEGER dimb_sort 5062 INTEGER dimb 5063 INTEGER l_a_sort 5064 INTEGER k_a_sort 5065 INTEGER l_a 5066 INTEGER k_a 5067 INTEGER l_b_sort 5068 INTEGER k_b_sort 5069 INTEGER l_b 5070 INTEGER k_b 5071 INTEGER l_c 5072 INTEGER k_c 5073 EXTERNAL NXTASK 5074 nprocs = GA_NNODES() 5075 count = 0 5076 next = NXTASK(nprocs,1) 5077 DO p3b = noab+1,noab+nvab 5078 DO p4b = noab+1,noab+nvab 5079 DO h1b = 1,noab 5080 DO h2b = h1b,noab 5081 IF (next.eq.count) THEN 5082 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 5083 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5084 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 5085 &1b-1)+int_mb(k_spin+h2b-1)) THEN 5086 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 5087 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_t,irrep_f)) TH 5088 &EN 5089 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 5090 &nge+h1b-1) * int_mb(k_range+h2b-1) 5091 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5092 & ERRQUIT('ccsdt_t2_5',0,MA_ERR) 5093 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5094 DO p5b = noab+1,noab+nvab 5095 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 5096 &1b-1)+int_mb(k_spin+h2b-1)) THEN 5097 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 5098 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 5099 CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h2b,p3b_1,p5b_1,h1b_1,h2b_1) 5100 CALL TCE_RESTRICTED_2(p4b,p5b,p4b_2,p5b_2) 5101 dim_common = int_mb(k_range+p5b-1) 5102 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb 5103 &(k_range+h2b-1) 5104 dima = dim_common * dima_sort 5105 dimb_sort = int_mb(k_range+p4b-1) 5106 dimb = dim_common * dimb_sort 5107 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5108 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5109 & ERRQUIT('ccsdt_t2_5',1,MA_ERR) 5110 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5111 &ccsdt_t2_5',2,MA_ERR) 5112 IF ((p5b .lt. p3b)) THEN 5113 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 5114 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 5115 &1 - noab - 1))))) 5116 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 5117 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 5118 &,4,3,2,1,-1.0d0) 5119 END IF 5120 IF ((p3b .le. p5b)) THEN 5121 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 5122 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_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+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 5126 &,4,3,1,2,1.0d0) 5127 END IF 5128 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_5',3,MA_ERR) 5129 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5130 & ERRQUIT('ccsdt_t2_5',4,MA_ERR) 5131 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5132 &ccsdt_t2_5',5,MA_ERR) 5133 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 5134 & - noab - 1 + nvab * (p4b_2 - noab - 1))) 5135 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 5136 &,int_mb(k_range+p5b-1),1,2,1.0d0) 5137 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_5',6,MA_ERR) 5138 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 5139 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 5140 &t),dima_sort) 5141 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_5',7,MA_ER 5142 &R) 5143 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_5',8,MA_ER 5144 &R) 5145 END IF 5146 END IF 5147 END IF 5148 END DO 5149 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5150 &ccsdt_t2_5',9,MA_ERR) 5151 IF ((p3b .le. p4b)) THEN 5152 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 5153 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 5154 &,4,1,3,2,1.0d0) 5155 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 5156 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 5157 & - 1))))) 5158 END IF 5159 IF ((p4b .le. p3b)) THEN 5160 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 5161 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 5162 &,1,4,3,2,-1.0d0) 5163 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 5164 & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 5165 & - 1))))) 5166 END IF 5167 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_5',10,MA_ERR) 5168 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_5',11,MA_E 5169 &RR) 5170 END IF 5171 END IF 5172 END IF 5173 next = NXTASK(nprocs,1) 5174 END IF 5175 count = count + 1 5176 END DO 5177 END DO 5178 END DO 5179 END DO 5180 next = NXTASK(-nprocs,1) 5181 call GA_SYNC() 5182 RETURN 5183 END 5184 SUBROUTINE ccsdt_t2a_5_1(d_a,k_a_offset,d_c,k_c_offset) 5185C $Id$ 5186C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5187C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5188C i1 ( p3 p5 )_f + = 1 * f ( p3 p5 )_f 5189 IMPLICIT NONE 5190#include "global.fh" 5191#include "mafdecls.fh" 5192#include "sym.fh" 5193#include "errquit.fh" 5194#include "tce.fh" 5195 INTEGER d_a 5196 INTEGER k_a_offset 5197 INTEGER d_c 5198 INTEGER k_c_offset 5199 INTEGER NXTASK 5200 INTEGER next 5201 INTEGER nprocs 5202 INTEGER count 5203 INTEGER p3b 5204 INTEGER p5b 5205 INTEGER dimc 5206 INTEGER p3b_1 5207 INTEGER p5b_1 5208 INTEGER dim_common 5209 INTEGER dima_sort 5210 INTEGER dima 5211 INTEGER l_a_sort 5212 INTEGER k_a_sort 5213 INTEGER l_a 5214 INTEGER k_a 5215 INTEGER l_c 5216 INTEGER k_c 5217 EXTERNAL NXTASK 5218 nprocs = GA_NNODES() 5219 count = 0 5220 next = NXTASK(nprocs,1) 5221 DO p3b = noab+1,noab+nvab 5222 DO p5b = noab+1,noab+nvab 5223 IF (next.eq.count) THEN 5224 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 5225 &).ne.4)) THEN 5226 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 5227 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) TH 5228 &EN 5229 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1) 5230 CALL TCE_RESTRICTED_2(p3b,p5b,p3b_1,p5b_1) 5231 dim_common = 1 5232 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1) 5233 dima = dim_common * dima_sort 5234 IF (dima .gt. 0) THEN 5235 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5236 & ERRQUIT('ccsdt_t2_5_1',0,MA_ERR) 5237 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5238 &ccsdt_t2_5_1',1,MA_ERR) 5239 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 5240 & - 1 + (noab+nvab) * (p3b_1 - 1))) 5241 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5242 &,int_mb(k_range+p5b-1),2,1,1.0d0) 5243 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_5_1',2,MA_ERR) 5244 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5245 &ccsdt_t2_5_1',3,MA_ERR) 5246 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 5247 &,int_mb(k_range+p3b-1),2,1,1.0d0) 5248 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 5249 & noab - 1 + nvab * (p3b - noab - 1))) 5250 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_5_1',4,MA_ERR) 5251 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_5_1',5,MA_ 5252 &ERR) 5253 END IF 5254 END IF 5255 END IF 5256 END IF 5257 next = NXTASK(nprocs,1) 5258 END IF 5259 count = count + 1 5260 END DO 5261 END DO 5262 next = NXTASK(-nprocs,1) 5263 call GA_SYNC() 5264 RETURN 5265 END 5266 SUBROUTINE OFFSET_ccsdt_t2a_5_1(l_a_offset,k_a_offset,size) 5267C $Id$ 5268C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5269C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5270C i1 ( p3 p5 )_f 5271 IMPLICIT NONE 5272#include "global.fh" 5273#include "mafdecls.fh" 5274#include "sym.fh" 5275#include "errquit.fh" 5276#include "tce.fh" 5277 INTEGER l_a_offset 5278 INTEGER k_a_offset 5279 INTEGER size 5280 INTEGER length 5281 INTEGER addr 5282 INTEGER p3b 5283 INTEGER p5b 5284 length = 0 5285 DO p3b = noab+1,noab+nvab 5286 DO p5b = noab+1,noab+nvab 5287 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 5288 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) TH 5289 &EN 5290 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 5291 &).ne.4)) THEN 5292 length = length + 1 5293 END IF 5294 END IF 5295 END IF 5296 END DO 5297 END DO 5298 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 5299 &set)) CALL ERRQUIT('ccsdt_t2_5_1',0,MA_ERR) 5300 int_mb(k_a_offset) = length 5301 addr = 0 5302 size = 0 5303 DO p3b = noab+1,noab+nvab 5304 DO p5b = noab+1,noab+nvab 5305 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 5306 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) TH 5307 &EN 5308 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 5309 &).ne.4)) THEN 5310 addr = addr + 1 5311 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (p3b - noab - 1) 5312 int_mb(k_a_offset+length+addr) = size 5313 size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1) 5314 END IF 5315 END IF 5316 END IF 5317 END DO 5318 END DO 5319 RETURN 5320 END 5321 SUBROUTINE ccsdt_t2a_5_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 5322 &k_c_offset) 5323C $Id$ 5324C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5325C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5326C i1 ( p3 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 p3 p5 p6 )_v 5327 IMPLICIT NONE 5328#include "global.fh" 5329#include "mafdecls.fh" 5330#include "sym.fh" 5331#include "errquit.fh" 5332#include "tce.fh" 5333 INTEGER d_a 5334 INTEGER k_a_offset 5335 INTEGER d_b 5336 INTEGER k_b_offset 5337 INTEGER d_c 5338 INTEGER k_c_offset 5339 INTEGER NXTASK 5340 INTEGER next 5341 INTEGER nprocs 5342 INTEGER count 5343 INTEGER p3b 5344 INTEGER p5b 5345 INTEGER dimc 5346 INTEGER l_c_sort 5347 INTEGER k_c_sort 5348 INTEGER p6b 5349 INTEGER h7b 5350 INTEGER p6b_1 5351 INTEGER h7b_1 5352 INTEGER p3b_2 5353 INTEGER h7b_2 5354 INTEGER p5b_2 5355 INTEGER p6b_2 5356 INTEGER dim_common 5357 INTEGER dima_sort 5358 INTEGER dima 5359 INTEGER dimb_sort 5360 INTEGER dimb 5361 INTEGER l_a_sort 5362 INTEGER k_a_sort 5363 INTEGER l_a 5364 INTEGER k_a 5365 INTEGER l_b_sort 5366 INTEGER k_b_sort 5367 INTEGER l_b 5368 INTEGER k_b 5369 INTEGER l_c 5370 INTEGER k_c 5371 EXTERNAL NXTASK 5372 nprocs = GA_NNODES() 5373 count = 0 5374 next = NXTASK(nprocs,1) 5375 DO p3b = noab+1,noab+nvab 5376 DO p5b = noab+1,noab+nvab 5377 IF (next.eq.count) THEN 5378 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 5379 &).ne.4)) THEN 5380 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 5381 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 5382 &v,irrep_t)) THEN 5383 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1) 5384 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5385 & ERRQUIT('ccsdt_t2_5_2',0,MA_ERR) 5386 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5387 DO p6b = noab+1,noab+nvab 5388 DO h7b = 1,noab 5389 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN 5390 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 5391 &EN 5392 CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1) 5393 CALL TCE_RESTRICTED_4(p3b,h7b,p5b,p6b,p3b_2,h7b_2,p5b_2,p6b_2) 5394 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1) 5395 dima_sort = 1 5396 dima = dim_common * dima_sort 5397 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1) 5398 dimb = dim_common * dimb_sort 5399 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5400 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5401 & ERRQUIT('ccsdt_t2_5_2',1,MA_ERR) 5402 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5403 &ccsdt_t2_5_2',2,MA_ERR) 5404 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 5405 & - 1 + noab * (p6b_1 - noab - 1))) 5406 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 5407 &,int_mb(k_range+h7b-1),2,1,1.0d0) 5408 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_5_2',3,MA_ERR) 5409 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5410 & ERRQUIT('ccsdt_t2_5_2',4,MA_ERR) 5411 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5412 &ccsdt_t2_5_2',5,MA_ERR) 5413 IF ((h7b .le. p3b) .and. (p6b .lt. p5b)) THEN 5414 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 5415 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 5416 &+nvab) * (h7b_2 - 1))))) 5417 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 5418 &,int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 5419 &,4,2,1,3,-1.0d0) 5420 END IF 5421 IF ((h7b .le. p3b) .and. (p5b .le. p6b)) THEN 5422 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 5423 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 5424 &+nvab) * (h7b_2 - 1))))) 5425 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 5426 &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 5427 &,3,2,1,4,1.0d0) 5428 END IF 5429 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_5_2',6,MA_ERR) 5430 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 5431 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 5432 &t),dima_sort) 5433 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_5_2',7,MA_ 5434 &ERR) 5435 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_5_2',8,MA_ 5436 &ERR) 5437 END IF 5438 END IF 5439 END IF 5440 END DO 5441 END DO 5442 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5443 &ccsdt_t2_5_2',9,MA_ERR) 5444 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 5445 &,int_mb(k_range+p3b-1),2,1,-1.0d0) 5446 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 5447 & noab - 1 + nvab * (p3b - noab - 1))) 5448 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_5_2',10,MA_ERR) 5449 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_5_2',11,MA 5450 &_ERR) 5451 END IF 5452 END IF 5453 END IF 5454 next = NXTASK(nprocs,1) 5455 END IF 5456 count = count + 1 5457 END DO 5458 END DO 5459 next = NXTASK(-nprocs,1) 5460 call GA_SYNC() 5461 RETURN 5462 END 5463 SUBROUTINE ccsdt_t2a_5_3(d_a,k_a_offset,d_b,k_b_offset,d_c, 5464 &k_c_offset) 5465C $Id$ 5466C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5467C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5468C i1 ( p3 p5 )_vt + = -1/2 * Sum ( h7 h8 p6 ) * t ( p3 p6 h7 h8 )_t * v ( h7 h8 p5 p6 )_v 5469 IMPLICIT NONE 5470#include "global.fh" 5471#include "mafdecls.fh" 5472#include "sym.fh" 5473#include "errquit.fh" 5474#include "tce.fh" 5475 INTEGER d_a 5476 INTEGER k_a_offset 5477 INTEGER d_b 5478 INTEGER k_b_offset 5479 INTEGER d_c 5480 INTEGER k_c_offset 5481 INTEGER NXTASK 5482 INTEGER next 5483 INTEGER nprocs 5484 INTEGER count 5485 INTEGER p3b 5486 INTEGER p5b 5487 INTEGER dimc 5488 INTEGER l_c_sort 5489 INTEGER k_c_sort 5490 INTEGER p6b 5491 INTEGER h7b 5492 INTEGER h8b 5493 INTEGER p3b_1 5494 INTEGER p6b_1 5495 INTEGER h7b_1 5496 INTEGER h8b_1 5497 INTEGER h7b_2 5498 INTEGER h8b_2 5499 INTEGER p5b_2 5500 INTEGER p6b_2 5501 INTEGER dim_common 5502 INTEGER dima_sort 5503 INTEGER dima 5504 INTEGER dimb_sort 5505 INTEGER dimb 5506 INTEGER l_a_sort 5507 INTEGER k_a_sort 5508 INTEGER l_a 5509 INTEGER k_a 5510 INTEGER l_b_sort 5511 INTEGER k_b_sort 5512 INTEGER l_b 5513 INTEGER k_b 5514 INTEGER nsubh(2) 5515 INTEGER isubh 5516 INTEGER l_c 5517 INTEGER k_c 5518 DOUBLE PRECISION FACTORIAL 5519 EXTERNAL NXTASK 5520 EXTERNAL FACTORIAL 5521 nprocs = GA_NNODES() 5522 count = 0 5523 next = NXTASK(nprocs,1) 5524 DO p3b = noab+1,noab+nvab 5525 DO p5b = noab+1,noab+nvab 5526 IF (next.eq.count) THEN 5527 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 5528 &).ne.4)) THEN 5529 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 5530 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 5531 &v,irrep_t)) THEN 5532 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1) 5533 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5534 & ERRQUIT('ccsdt_t2_5_3',0,MA_ERR) 5535 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5536 DO p6b = noab+1,noab+nvab 5537 DO h7b = 1,noab 5538 DO h8b = h7b,noab 5539 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 5540 &7b-1)+int_mb(k_spin+h8b-1)) THEN 5541 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 5542 &k_sym+h7b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_t) THEN 5543 CALL TCE_RESTRICTED_4(p3b,p6b,h7b,h8b,p3b_1,p6b_1,h7b_1,h8b_1) 5544 CALL TCE_RESTRICTED_4(h7b,h8b,p5b,p6b,h7b_2,h8b_2,p5b_2,p6b_2) 5545 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1) * int_m 5546 &b(k_range+h8b-1) 5547 dima_sort = int_mb(k_range+p3b-1) 5548 dima = dim_common * dima_sort 5549 dimb_sort = int_mb(k_range+p5b-1) 5550 dimb = dim_common * dimb_sort 5551 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5552 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5553 & ERRQUIT('ccsdt_t2_5_3',1,MA_ERR) 5554 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5555 &ccsdt_t2_5_3',2,MA_ERR) 5556 IF ((p6b .lt. p3b)) THEN 5557 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 5558 & - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p6b_ 5559 &1 - noab - 1))))) 5560 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 5561 &,int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),int_mb(k_range+h8b-1) 5562 &,2,4,3,1,-1.0d0) 5563 END IF 5564 IF ((p3b .le. p6b)) THEN 5565 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 5566 & - 1 + noab * (h7b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p3b_ 5567 &1 - noab - 1))))) 5568 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5569 &,int_mb(k_range+p6b-1),int_mb(k_range+h7b-1),int_mb(k_range+h8b-1) 5570 &,1,4,3,2,1.0d0) 5571 END IF 5572 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_5_3',3,MA_ERR) 5573 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5574 & ERRQUIT('ccsdt_t2_5_3',4,MA_ERR) 5575 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5576 &ccsdt_t2_5_3',5,MA_ERR) 5577 IF ((p6b .lt. p5b)) THEN 5578 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 5579 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 5580 &+nvab) * (h7b_2 - 1))))) 5581 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 5582 &,int_mb(k_range+h8b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 5583 &,4,2,1,3,-1.0d0) 5584 END IF 5585 IF ((p5b .le. p6b)) THEN 5586 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 5587 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 5588 &+nvab) * (h7b_2 - 1))))) 5589 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 5590 &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 5591 &,3,2,1,4,1.0d0) 5592 END IF 5593 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_5_3',6,MA_ERR) 5594 nsubh(1) = 1 5595 nsubh(2) = 1 5596 isubh = 1 5597 IF (h7b .eq. h8b) THEN 5598 nsubh(isubh) = nsubh(isubh) + 1 5599 ELSE 5600 isubh = isubh + 1 5601 END IF 5602 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 5603 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 5604 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 5605 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_5_3',7,MA_ 5606 &ERR) 5607 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_5_3',8,MA_ 5608 &ERR) 5609 END IF 5610 END IF 5611 END IF 5612 END DO 5613 END DO 5614 END DO 5615 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5616 &ccsdt_t2_5_3',9,MA_ERR) 5617 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 5618 &,int_mb(k_range+p3b-1),2,1,-1.0d0/2.0d0) 5619 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 5620 & noab - 1 + nvab * (p3b - noab - 1))) 5621 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_5_3',10,MA_ERR) 5622 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_5_3',11,MA 5623 &_ERR) 5624 END IF 5625 END IF 5626 END IF 5627 next = NXTASK(nprocs,1) 5628 END IF 5629 count = count + 1 5630 END DO 5631 END DO 5632 next = NXTASK(-nprocs,1) 5633 call GA_SYNC() 5634 RETURN 5635 END 5636 SUBROUTINE ccsdt_t2a_6(d_a,k_a_offset,d_b,k_b_offset,d_c, 5637 &k_c_offset) 5638C $Id$ 5639C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5640C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5641C i0 ( p3 p4 h1 h2 )_vt + = -1/2 * Sum ( h11 h9 ) * t ( p3 p4 h9 h11 )_t * i1 ( h9 h11 h1 h2 )_v 5642 IMPLICIT NONE 5643#include "global.fh" 5644#include "mafdecls.fh" 5645#include "sym.fh" 5646#include "errquit.fh" 5647#include "tce.fh" 5648 INTEGER d_a 5649 INTEGER k_a_offset 5650 INTEGER d_b 5651 INTEGER k_b_offset 5652 INTEGER d_c 5653 INTEGER k_c_offset 5654 INTEGER NXTASK 5655 INTEGER next 5656 INTEGER nprocs 5657 INTEGER count 5658 INTEGER p3b 5659 INTEGER p4b 5660 INTEGER h1b 5661 INTEGER h2b 5662 INTEGER dimc 5663 INTEGER l_c_sort 5664 INTEGER k_c_sort 5665 INTEGER h9b 5666 INTEGER h11b 5667 INTEGER p3b_1 5668 INTEGER p4b_1 5669 INTEGER h9b_1 5670 INTEGER h11b_1 5671 INTEGER h9b_2 5672 INTEGER h11b_2 5673 INTEGER h1b_2 5674 INTEGER h2b_2 5675 INTEGER dim_common 5676 INTEGER dima_sort 5677 INTEGER dima 5678 INTEGER dimb_sort 5679 INTEGER dimb 5680 INTEGER l_a_sort 5681 INTEGER k_a_sort 5682 INTEGER l_a 5683 INTEGER k_a 5684 INTEGER l_b_sort 5685 INTEGER k_b_sort 5686 INTEGER l_b 5687 INTEGER k_b 5688 INTEGER nsubh(2) 5689 INTEGER isubh 5690 INTEGER l_c 5691 INTEGER k_c 5692 DOUBLE PRECISION FACTORIAL 5693 EXTERNAL NXTASK 5694 EXTERNAL FACTORIAL 5695 nprocs = GA_NNODES() 5696 count = 0 5697 next = NXTASK(nprocs,1) 5698 DO p3b = noab+1,noab+nvab 5699 DO p4b = p3b,noab+nvab 5700 DO h1b = 1,noab 5701 DO h2b = h1b,noab 5702 IF (next.eq.count) THEN 5703 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 5704 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5705 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 5706 &1b-1)+int_mb(k_spin+h2b-1)) THEN 5707 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 5708 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 5709 &EN 5710 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 5711 &nge+h1b-1) * int_mb(k_range+h2b-1) 5712 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5713 & ERRQUIT('ccsdt_t2_6',0,MA_ERR) 5714 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5715 DO h9b = 1,noab 5716 DO h11b = h9b,noab 5717 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 5718 &9b-1)+int_mb(k_spin+h11b-1)) THEN 5719 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 5720 &k_sym+h9b-1),int_mb(k_sym+h11b-1)))) .eq. irrep_t) THEN 5721 CALL TCE_RESTRICTED_4(p3b,p4b,h9b,h11b,p3b_1,p4b_1,h9b_1,h11b_1) 5722 CALL TCE_RESTRICTED_4(h9b,h11b,h1b,h2b,h9b_2,h11b_2,h1b_2,h2b_2) 5723 dim_common = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) 5724 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) 5725 dima = dim_common * dima_sort 5726 dimb_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 5727 dimb = dim_common * dimb_sort 5728 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5729 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5730 & ERRQUIT('ccsdt_t2_6',1,MA_ERR) 5731 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5732 &ccsdt_t2_6',2,MA_ERR) 5733 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h11b_ 5734 &1 - 1 + noab * (h9b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b 5735 &_1 - noab - 1))))) 5736 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5737 &,int_mb(k_range+p4b-1),int_mb(k_range+h9b-1),int_mb(k_range+h11b-1 5738 &),2,1,4,3,1.0d0) 5739 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_6',3,MA_ERR) 5740 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5741 & ERRQUIT('ccsdt_t2_6',4,MA_ERR) 5742 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5743 &ccsdt_t2_6',5,MA_ERR) 5744 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 5745 & - 1 + noab * (h1b_2 - 1 + noab * (h11b_2 - 1 + noab * (h9b_2 - 1) 5746 &)))) 5747 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 5748 &,int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 5749 &),4,3,2,1,1.0d0) 5750 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_6',6,MA_ERR) 5751 nsubh(1) = 1 5752 nsubh(2) = 1 5753 isubh = 1 5754 IF (h9b .eq. h11b) THEN 5755 nsubh(isubh) = nsubh(isubh) + 1 5756 ELSE 5757 isubh = isubh + 1 5758 END IF 5759 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 5760 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 5761 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 5762 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_6',7,MA_ER 5763 &R) 5764 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_6',8,MA_ER 5765 &R) 5766 END IF 5767 END IF 5768 END IF 5769 END DO 5770 END DO 5771 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5772 &ccsdt_t2_6',9,MA_ERR) 5773 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5774 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 5775 &,4,3,2,1,-1.0d0/2.0d0) 5776 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 5777 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 5778 & - 1))))) 5779 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_6',10,MA_ERR) 5780 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_6',11,MA_E 5781 &RR) 5782 END IF 5783 END IF 5784 END IF 5785 next = NXTASK(nprocs,1) 5786 END IF 5787 count = count + 1 5788 END DO 5789 END DO 5790 END DO 5791 END DO 5792 next = NXTASK(-nprocs,1) 5793 call GA_SYNC() 5794 RETURN 5795 END 5796 SUBROUTINE ccsdt_t2a_6_1(d_a,k_a_offset,d_c,k_c_offset) 5797C $Id$ 5798C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5799C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5800C i1 ( h9 h11 h1 h2 )_v + = -1 * v ( h9 h11 h1 h2 )_v 5801 IMPLICIT NONE 5802#include "global.fh" 5803#include "mafdecls.fh" 5804#include "sym.fh" 5805#include "errquit.fh" 5806#include "tce.fh" 5807 INTEGER d_a 5808 INTEGER k_a_offset 5809 INTEGER d_c 5810 INTEGER k_c_offset 5811 INTEGER NXTASK 5812 INTEGER next 5813 INTEGER nprocs 5814 INTEGER count 5815 INTEGER h9b 5816 INTEGER h11b 5817 INTEGER h1b 5818 INTEGER h2b 5819 INTEGER dimc 5820 INTEGER h9b_1 5821 INTEGER h11b_1 5822 INTEGER h1b_1 5823 INTEGER h2b_1 5824 INTEGER dim_common 5825 INTEGER dima_sort 5826 INTEGER dima 5827 INTEGER l_a_sort 5828 INTEGER k_a_sort 5829 INTEGER l_a 5830 INTEGER k_a 5831 INTEGER l_c 5832 INTEGER k_c 5833 EXTERNAL NXTASK 5834 nprocs = GA_NNODES() 5835 count = 0 5836 next = NXTASK(nprocs,1) 5837 DO h9b = 1,noab 5838 DO h11b = h9b,noab 5839 DO h1b = 1,noab 5840 DO h2b = h1b,noab 5841 IF (next.eq.count) THEN 5842 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b- 5843 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5844 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+ 5845 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 5846 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb 5847 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 5848 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_mb(k_r 5849 &ange+h1b-1) * int_mb(k_range+h2b-1) 5850 CALL TCE_RESTRICTED_4(h9b,h11b,h1b,h2b,h9b_1,h11b_1,h1b_1,h2b_1) 5851 dim_common = 1 5852 dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_m 5853 &b(k_range+h1b-1) * int_mb(k_range+h2b-1) 5854 dima = dim_common * dima_sort 5855 IF (dima .gt. 0) THEN 5856 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5857 & ERRQUIT('ccsdt_t2_6_1',0,MA_ERR) 5858 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5859 &ccsdt_t2_6_1',1,MA_ERR) 5860 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 5861 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa 5862 &b+nvab) * (h9b_1 - 1))))) 5863 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 5864 &,int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 5865 &),4,3,2,1,1.0d0) 5866 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_6_1',2,MA_ERR) 5867 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5868 &ccsdt_t2_6_1',3,MA_ERR) 5869 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5870 &,int_mb(k_range+h1b-1),int_mb(k_range+h11b-1),int_mb(k_range+h9b-1 5871 &),4,3,2,1,-1.0d0) 5872 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 5873 & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h9b - 1))))) 5874 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_6_1',4,MA_ERR) 5875 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_6_1',5,MA_ 5876 &ERR) 5877 END IF 5878 END IF 5879 END IF 5880 END IF 5881 next = NXTASK(nprocs,1) 5882 END IF 5883 count = count + 1 5884 END DO 5885 END DO 5886 END DO 5887 END DO 5888 next = NXTASK(-nprocs,1) 5889 call GA_SYNC() 5890 RETURN 5891 END 5892 SUBROUTINE OFFSET_ccsdt_t2a_6_1(l_a_offset,k_a_offset,size) 5893C $Id$ 5894C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5895C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5896C i1 ( h9 h11 h1 h2 )_v 5897 IMPLICIT NONE 5898#include "global.fh" 5899#include "mafdecls.fh" 5900#include "sym.fh" 5901#include "errquit.fh" 5902#include "tce.fh" 5903 INTEGER l_a_offset 5904 INTEGER k_a_offset 5905 INTEGER size 5906 INTEGER length 5907 INTEGER addr 5908 INTEGER h9b 5909 INTEGER h11b 5910 INTEGER h1b 5911 INTEGER h2b 5912 length = 0 5913 DO h9b = 1,noab 5914 DO h11b = h9b,noab 5915 DO h1b = 1,noab 5916 DO h2b = h1b,noab 5917 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+ 5918 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 5919 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb 5920 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 5921 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b- 5922 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5923 length = length + 1 5924 END IF 5925 END IF 5926 END IF 5927 END DO 5928 END DO 5929 END DO 5930 END DO 5931 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 5932 &set)) CALL ERRQUIT('ccsdt_t2_6_1',0,MA_ERR) 5933 int_mb(k_a_offset) = length 5934 addr = 0 5935 size = 0 5936 DO h9b = 1,noab 5937 DO h11b = h9b,noab 5938 DO h1b = 1,noab 5939 DO h2b = h1b,noab 5940 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+ 5941 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 5942 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb 5943 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 5944 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b- 5945 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5946 addr = addr + 1 5947 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h11b 5948 & - 1 + noab * (h9b - 1))) 5949 int_mb(k_a_offset+length+addr) = size 5950 size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int 5951 &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 5952 END IF 5953 END IF 5954 END IF 5955 END DO 5956 END DO 5957 END DO 5958 END DO 5959 RETURN 5960 END 5961 SUBROUTINE ccsdt_t2a_6_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 5962 &k_c_offset) 5963C $Id$ 5964C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5965C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5966C i1 ( h9 h11 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( p8 ) * t ( p8 h1 )_t * i2 ( h9 h11 h2 p8 )_v 5967 IMPLICIT NONE 5968#include "global.fh" 5969#include "mafdecls.fh" 5970#include "sym.fh" 5971#include "errquit.fh" 5972#include "tce.fh" 5973 INTEGER d_a 5974 INTEGER k_a_offset 5975 INTEGER d_b 5976 INTEGER k_b_offset 5977 INTEGER d_c 5978 INTEGER k_c_offset 5979 INTEGER NXTASK 5980 INTEGER next 5981 INTEGER nprocs 5982 INTEGER count 5983 INTEGER h9b 5984 INTEGER h11b 5985 INTEGER h1b 5986 INTEGER h2b 5987 INTEGER dimc 5988 INTEGER l_c_sort 5989 INTEGER k_c_sort 5990 INTEGER p8b 5991 INTEGER p8b_1 5992 INTEGER h1b_1 5993 INTEGER h9b_2 5994 INTEGER h11b_2 5995 INTEGER h2b_2 5996 INTEGER p8b_2 5997 INTEGER dim_common 5998 INTEGER dima_sort 5999 INTEGER dima 6000 INTEGER dimb_sort 6001 INTEGER dimb 6002 INTEGER l_a_sort 6003 INTEGER k_a_sort 6004 INTEGER l_a 6005 INTEGER k_a 6006 INTEGER l_b_sort 6007 INTEGER k_b_sort 6008 INTEGER l_b 6009 INTEGER k_b 6010 INTEGER l_c 6011 INTEGER k_c 6012 EXTERNAL NXTASK 6013 nprocs = GA_NNODES() 6014 count = 0 6015 next = NXTASK(nprocs,1) 6016 DO h9b = 1,noab 6017 DO h11b = h9b,noab 6018 DO h1b = 1,noab 6019 DO h2b = 1,noab 6020 IF (next.eq.count) THEN 6021 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b- 6022 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6023 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+ 6024 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6025 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb 6026 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 6027 &HEN 6028 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_mb(k_r 6029 &ange+h1b-1) * int_mb(k_range+h2b-1) 6030 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6031 & ERRQUIT('ccsdt_t2_6_2',0,MA_ERR) 6032 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6033 DO p8b = noab+1,noab+nvab 6034 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 6035 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 6036 &EN 6037 CALL TCE_RESTRICTED_2(p8b,h1b,p8b_1,h1b_1) 6038 CALL TCE_RESTRICTED_4(h9b,h11b,h2b,p8b,h9b_2,h11b_2,h2b_2,p8b_2) 6039 dim_common = int_mb(k_range+p8b-1) 6040 dima_sort = int_mb(k_range+h1b-1) 6041 dima = dim_common * dima_sort 6042 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_m 6043 &b(k_range+h2b-1) 6044 dimb = dim_common * dimb_sort 6045 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6046 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6047 & ERRQUIT('ccsdt_t2_6_2',1,MA_ERR) 6048 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6049 &ccsdt_t2_6_2',2,MA_ERR) 6050 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 6051 & - 1 + noab * (p8b_1 - noab - 1))) 6052 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 6053 &,int_mb(k_range+h1b-1),2,1,1.0d0) 6054 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_6_2',3,MA_ERR) 6055 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6056 & ERRQUIT('ccsdt_t2_6_2',4,MA_ERR) 6057 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6058 &ccsdt_t2_6_2',5,MA_ERR) 6059 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 6060 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h11b_2 - 1 + noab * (h9b 6061 &_2 - 1))))) 6062 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 6063 &,int_mb(k_range+h11b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1 6064 &),3,2,1,4,1.0d0) 6065 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_6_2',6,MA_ERR) 6066 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6067 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6068 &t),dima_sort) 6069 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_6_2',7,MA_ 6070 &ERR) 6071 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_6_2',8,MA_ 6072 &ERR) 6073 END IF 6074 END IF 6075 END IF 6076 END DO 6077 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6078 &ccsdt_t2_6_2',9,MA_ERR) 6079 IF ((h1b .le. h2b)) THEN 6080 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6081 &,int_mb(k_range+h11b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1 6082 &),3,2,4,1,1.0d0) 6083 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 6084 & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h9b - 1))))) 6085 END IF 6086 IF ((h2b .le. h1b)) THEN 6087 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6088 &,int_mb(k_range+h11b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1 6089 &),3,2,1,4,-1.0d0) 6090 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 6091 & 1 + noab * (h2b - 1 + noab * (h11b - 1 + noab * (h9b - 1))))) 6092 END IF 6093 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_6_2',10,MA_ERR) 6094 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_6_2',11,MA 6095 &_ERR) 6096 END IF 6097 END IF 6098 END IF 6099 next = NXTASK(nprocs,1) 6100 END IF 6101 count = count + 1 6102 END DO 6103 END DO 6104 END DO 6105 END DO 6106 next = NXTASK(-nprocs,1) 6107 call GA_SYNC() 6108 RETURN 6109 END 6110 SUBROUTINE ccsdt_t2a_6_2_1(d_a,k_a_offset,d_c,k_c_offset) 6111C $Id$ 6112C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6113C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6114C i2 ( h9 h11 h1 p8 )_v + = 1 * v ( h9 h11 h1 p8 )_v 6115 IMPLICIT NONE 6116#include "global.fh" 6117#include "mafdecls.fh" 6118#include "sym.fh" 6119#include "errquit.fh" 6120#include "tce.fh" 6121 INTEGER d_a 6122 INTEGER k_a_offset 6123 INTEGER d_c 6124 INTEGER k_c_offset 6125 INTEGER NXTASK 6126 INTEGER next 6127 INTEGER nprocs 6128 INTEGER count 6129 INTEGER h9b 6130 INTEGER h11b 6131 INTEGER h1b 6132 INTEGER p8b 6133 INTEGER dimc 6134 INTEGER h9b_1 6135 INTEGER h11b_1 6136 INTEGER h1b_1 6137 INTEGER p8b_1 6138 INTEGER dim_common 6139 INTEGER dima_sort 6140 INTEGER dima 6141 INTEGER l_a_sort 6142 INTEGER k_a_sort 6143 INTEGER l_a 6144 INTEGER k_a 6145 INTEGER l_c 6146 INTEGER k_c 6147 EXTERNAL NXTASK 6148 nprocs = GA_NNODES() 6149 count = 0 6150 next = NXTASK(nprocs,1) 6151 DO h9b = 1,noab 6152 DO h11b = h9b,noab 6153 DO h1b = 1,noab 6154 DO p8b = noab+1,noab+nvab 6155 IF (next.eq.count) THEN 6156 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b- 6157 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN 6158 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+ 6159 &h1b-1)+int_mb(k_spin+p8b-1)) THEN 6160 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb 6161 &(k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN 6162 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_mb(k_r 6163 &ange+h1b-1) * int_mb(k_range+p8b-1) 6164 CALL TCE_RESTRICTED_4(h9b,h11b,h1b,p8b,h9b_1,h11b_1,h1b_1,p8b_1) 6165 dim_common = 1 6166 dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_m 6167 &b(k_range+h1b-1) * int_mb(k_range+p8b-1) 6168 dima = dim_common * dima_sort 6169 IF (dima .gt. 0) THEN 6170 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6171 & ERRQUIT('ccsdt_t2_6_2_1',0,MA_ERR) 6172 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6173 &ccsdt_t2_6_2_1',1,MA_ERR) 6174 IF ((h1b .le. p8b)) THEN 6175 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1 6176 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa 6177 &b+nvab) * (h9b_1 - 1))))) 6178 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 6179 &,int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+p8b-1 6180 &),4,3,2,1,1.0d0) 6181 END IF 6182 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_6_2_1',2,MA_ERR 6183 &) 6184 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6185 &ccsdt_t2_6_2_1',3,MA_ERR) 6186 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 6187 &,int_mb(k_range+h1b-1),int_mb(k_range+h11b-1),int_mb(k_range+h9b-1 6188 &),4,3,2,1,1.0d0) 6189 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 6190 & noab - 1 + nvab * (h1b - 1 + noab * (h11b - 1 + noab * (h9b - 1)) 6191 &))) 6192 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_6_2_1',4,MA_ERR 6193 &) 6194 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_6_2_1',5,M 6195 &A_ERR) 6196 END IF 6197 END IF 6198 END IF 6199 END IF 6200 next = NXTASK(nprocs,1) 6201 END IF 6202 count = count + 1 6203 END DO 6204 END DO 6205 END DO 6206 END DO 6207 next = NXTASK(-nprocs,1) 6208 call GA_SYNC() 6209 RETURN 6210 END 6211 SUBROUTINE OFFSET_ccsdt_t2a_6_2_1(l_a_offset,k_a_offset,size) 6212C $Id$ 6213C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6214C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6215C i2 ( h9 h11 h1 p8 )_v 6216 IMPLICIT NONE 6217#include "global.fh" 6218#include "mafdecls.fh" 6219#include "sym.fh" 6220#include "errquit.fh" 6221#include "tce.fh" 6222 INTEGER l_a_offset 6223 INTEGER k_a_offset 6224 INTEGER size 6225 INTEGER length 6226 INTEGER addr 6227 INTEGER h9b 6228 INTEGER h11b 6229 INTEGER h1b 6230 INTEGER p8b 6231 length = 0 6232 DO h9b = 1,noab 6233 DO h11b = h9b,noab 6234 DO h1b = 1,noab 6235 DO p8b = noab+1,noab+nvab 6236 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+ 6237 &h1b-1)+int_mb(k_spin+p8b-1)) THEN 6238 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb 6239 &(k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN 6240 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b- 6241 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN 6242 length = length + 1 6243 END IF 6244 END IF 6245 END IF 6246 END DO 6247 END DO 6248 END DO 6249 END DO 6250 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 6251 &set)) CALL ERRQUIT('ccsdt_t2_6_2_1',0,MA_ERR) 6252 int_mb(k_a_offset) = length 6253 addr = 0 6254 size = 0 6255 DO h9b = 1,noab 6256 DO h11b = h9b,noab 6257 DO h1b = 1,noab 6258 DO p8b = noab+1,noab+nvab 6259 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+ 6260 &h1b-1)+int_mb(k_spin+p8b-1)) THEN 6261 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb 6262 &(k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN 6263 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b- 6264 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN 6265 addr = addr + 1 6266 int_mb(k_a_offset+addr) = p8b - noab - 1 + nvab * (h1b - 1 + noab 6267 &* (h11b - 1 + noab * (h9b - 1))) 6268 int_mb(k_a_offset+length+addr) = size 6269 size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int 6270 &_mb(k_range+h1b-1) * int_mb(k_range+p8b-1) 6271 END IF 6272 END IF 6273 END IF 6274 END DO 6275 END DO 6276 END DO 6277 END DO 6278 RETURN 6279 END 6280 SUBROUTINE ccsdt_t2a_6_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 6281 &k_c_offset) 6282C $Id$ 6283C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6284C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6285C i2 ( h9 h11 h1 p8 )_vt + = 1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 h11 p6 p8 )_v 6286 IMPLICIT NONE 6287#include "global.fh" 6288#include "mafdecls.fh" 6289#include "sym.fh" 6290#include "errquit.fh" 6291#include "tce.fh" 6292 INTEGER d_a 6293 INTEGER k_a_offset 6294 INTEGER d_b 6295 INTEGER k_b_offset 6296 INTEGER d_c 6297 INTEGER k_c_offset 6298 INTEGER NXTASK 6299 INTEGER next 6300 INTEGER nprocs 6301 INTEGER count 6302 INTEGER h9b 6303 INTEGER h11b 6304 INTEGER h1b 6305 INTEGER p8b 6306 INTEGER dimc 6307 INTEGER l_c_sort 6308 INTEGER k_c_sort 6309 INTEGER p6b 6310 INTEGER p6b_1 6311 INTEGER h1b_1 6312 INTEGER h9b_2 6313 INTEGER h11b_2 6314 INTEGER p8b_2 6315 INTEGER p6b_2 6316 INTEGER dim_common 6317 INTEGER dima_sort 6318 INTEGER dima 6319 INTEGER dimb_sort 6320 INTEGER dimb 6321 INTEGER l_a_sort 6322 INTEGER k_a_sort 6323 INTEGER l_a 6324 INTEGER k_a 6325 INTEGER l_b_sort 6326 INTEGER k_b_sort 6327 INTEGER l_b 6328 INTEGER k_b 6329 INTEGER l_c 6330 INTEGER k_c 6331 EXTERNAL NXTASK 6332 nprocs = GA_NNODES() 6333 count = 0 6334 next = NXTASK(nprocs,1) 6335 DO h9b = 1,noab 6336 DO h11b = h9b,noab 6337 DO h1b = 1,noab 6338 DO p8b = noab+1,noab+nvab 6339 IF (next.eq.count) THEN 6340 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b- 6341 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN 6342 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+ 6343 &h1b-1)+int_mb(k_spin+p8b-1)) THEN 6344 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb 6345 &(k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. ieor(irrep_v,irrep_t)) T 6346 &HEN 6347 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_mb(k_r 6348 &ange+h1b-1) * int_mb(k_range+p8b-1) 6349 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6350 & ERRQUIT('ccsdt_t2_6_2_2',0,MA_ERR) 6351 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6352 DO p6b = noab+1,noab+nvab 6353 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 6354 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 6355 &EN 6356 CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1) 6357 CALL TCE_RESTRICTED_4(h9b,h11b,p8b,p6b,h9b_2,h11b_2,p8b_2,p6b_2) 6358 dim_common = int_mb(k_range+p6b-1) 6359 dima_sort = int_mb(k_range+h1b-1) 6360 dima = dim_common * dima_sort 6361 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_m 6362 &b(k_range+p8b-1) 6363 dimb = dim_common * dimb_sort 6364 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6365 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6366 & ERRQUIT('ccsdt_t2_6_2_2',1,MA_ERR) 6367 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6368 &ccsdt_t2_6_2_2',2,MA_ERR) 6369 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 6370 & - 1 + noab * (p6b_1 - noab - 1))) 6371 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 6372 &,int_mb(k_range+h1b-1),2,1,1.0d0) 6373 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_6_2_2',3,MA_ERR 6374 &) 6375 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6376 & ERRQUIT('ccsdt_t2_6_2_2',4,MA_ERR) 6377 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6378 &ccsdt_t2_6_2_2',5,MA_ERR) 6379 IF ((p6b .le. p8b)) THEN 6380 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 6381 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa 6382 &b+nvab) * (h9b_2 - 1))))) 6383 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 6384 &,int_mb(k_range+h11b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1 6385 &),4,2,1,3,1.0d0) 6386 END IF 6387 IF ((p8b .lt. p6b)) THEN 6388 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 6389 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa 6390 &b+nvab) * (h9b_2 - 1))))) 6391 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 6392 &,int_mb(k_range+h11b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1 6393 &),3,2,1,4,-1.0d0) 6394 END IF 6395 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_6_2_2',6,MA_ERR 6396 &) 6397 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6398 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6399 &t),dima_sort) 6400 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_6_2_2',7,M 6401 &A_ERR) 6402 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_6_2_2',8,M 6403 &A_ERR) 6404 END IF 6405 END IF 6406 END IF 6407 END DO 6408 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6409 &ccsdt_t2_6_2_2',9,MA_ERR) 6410 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 6411 &,int_mb(k_range+h11b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1 6412 &),3,2,4,1,1.0d0/2.0d0) 6413 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 6414 & noab - 1 + nvab * (h1b - 1 + noab * (h11b - 1 + noab * (h9b - 1)) 6415 &))) 6416 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_6_2_2',10,MA_ER 6417 &R) 6418 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_6_2_2',11, 6419 &MA_ERR) 6420 END IF 6421 END IF 6422 END IF 6423 next = NXTASK(nprocs,1) 6424 END IF 6425 count = count + 1 6426 END DO 6427 END DO 6428 END DO 6429 END DO 6430 next = NXTASK(-nprocs,1) 6431 call GA_SYNC() 6432 RETURN 6433 END 6434 SUBROUTINE ccsdt_t2a_6_3(d_a,k_a_offset,d_b,k_b_offset,d_c, 6435 &k_c_offset) 6436C $Id$ 6437C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6438C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6439C i1 ( h9 h11 h1 h2 )_vt + = -1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 h11 p5 p6 )_v 6440 IMPLICIT NONE 6441#include "global.fh" 6442#include "mafdecls.fh" 6443#include "sym.fh" 6444#include "errquit.fh" 6445#include "tce.fh" 6446 INTEGER d_a 6447 INTEGER k_a_offset 6448 INTEGER d_b 6449 INTEGER k_b_offset 6450 INTEGER d_c 6451 INTEGER k_c_offset 6452 INTEGER NXTASK 6453 INTEGER next 6454 INTEGER nprocs 6455 INTEGER count 6456 INTEGER h9b 6457 INTEGER h11b 6458 INTEGER h1b 6459 INTEGER h2b 6460 INTEGER dimc 6461 INTEGER l_c_sort 6462 INTEGER k_c_sort 6463 INTEGER p5b 6464 INTEGER p6b 6465 INTEGER p5b_1 6466 INTEGER p6b_1 6467 INTEGER h1b_1 6468 INTEGER h2b_1 6469 INTEGER h9b_2 6470 INTEGER h11b_2 6471 INTEGER p5b_2 6472 INTEGER p6b_2 6473 INTEGER dim_common 6474 INTEGER dima_sort 6475 INTEGER dima 6476 INTEGER dimb_sort 6477 INTEGER dimb 6478 INTEGER l_a_sort 6479 INTEGER k_a_sort 6480 INTEGER l_a 6481 INTEGER k_a 6482 INTEGER l_b_sort 6483 INTEGER k_b_sort 6484 INTEGER l_b 6485 INTEGER k_b 6486 INTEGER nsuperp(2) 6487 INTEGER isuperp 6488 INTEGER l_c 6489 INTEGER k_c 6490 DOUBLE PRECISION FACTORIAL 6491 EXTERNAL NXTASK 6492 EXTERNAL FACTORIAL 6493 nprocs = GA_NNODES() 6494 count = 0 6495 next = NXTASK(nprocs,1) 6496 DO h9b = 1,noab 6497 DO h11b = h9b,noab 6498 DO h1b = 1,noab 6499 DO h2b = h1b,noab 6500 IF (next.eq.count) THEN 6501 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b- 6502 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6503 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+ 6504 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6505 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb 6506 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 6507 &HEN 6508 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_mb(k_r 6509 &ange+h1b-1) * int_mb(k_range+h2b-1) 6510 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6511 & ERRQUIT('ccsdt_t2_6_3',0,MA_ERR) 6512 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6513 DO p5b = noab+1,noab+nvab 6514 DO p6b = p5b,noab+nvab 6515 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 6516 &1b-1)+int_mb(k_spin+h2b-1)) THEN 6517 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 6518 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 6519 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1) 6520 CALL TCE_RESTRICTED_4(h9b,h11b,p5b,p6b,h9b_2,h11b_2,p5b_2,p6b_2) 6521 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) 6522 dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 6523 dima = dim_common * dima_sort 6524 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) 6525 dimb = dim_common * dimb_sort 6526 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6527 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6528 & ERRQUIT('ccsdt_t2_6_3',1,MA_ERR) 6529 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6530 &ccsdt_t2_6_3',2,MA_ERR) 6531 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 6532 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 6533 &1 - noab - 1))))) 6534 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 6535 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 6536 &,4,3,2,1,1.0d0) 6537 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_6_3',3,MA_ERR) 6538 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6539 & ERRQUIT('ccsdt_t2_6_3',4,MA_ERR) 6540 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6541 &ccsdt_t2_6_3',5,MA_ERR) 6542 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 6543 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa 6544 &b+nvab) * (h9b_2 - 1))))) 6545 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 6546 &,int_mb(k_range+h11b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 6547 &),2,1,4,3,1.0d0) 6548 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_6_3',6,MA_ERR) 6549 nsuperp(1) = 1 6550 nsuperp(2) = 1 6551 isuperp = 1 6552 IF (p5b .eq. p6b) THEN 6553 nsuperp(isuperp) = nsuperp(isuperp) + 1 6554 ELSE 6555 isuperp = isuperp + 1 6556 END IF 6557 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 6558 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 6559 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 6560 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_6_3',7,MA_ 6561 &ERR) 6562 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_6_3',8,MA_ 6563 &ERR) 6564 END IF 6565 END IF 6566 END IF 6567 END DO 6568 END DO 6569 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6570 &ccsdt_t2_6_3',9,MA_ERR) 6571 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h11b-1 6572 &),int_mb(k_range+h9b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1 6573 &),2,1,4,3,-1.0d0/2.0d0) 6574 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 6575 & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h9b - 1))))) 6576 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_6_3',10,MA_ERR) 6577 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_6_3',11,MA 6578 &_ERR) 6579 END IF 6580 END IF 6581 END IF 6582 next = NXTASK(nprocs,1) 6583 END IF 6584 count = count + 1 6585 END DO 6586 END DO 6587 END DO 6588 END DO 6589 next = NXTASK(-nprocs,1) 6590 call GA_SYNC() 6591 RETURN 6592 END 6593 SUBROUTINE ccsdt_t2a_7(d_a,k_a_offset,d_b,k_b_offset,d_c, 6594 &k_c_offset) 6595C $Id$ 6596C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6597C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6598C i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 4 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i1 ( h6 p4 h2 p5 )_v 6599 IMPLICIT NONE 6600#include "global.fh" 6601#include "mafdecls.fh" 6602#include "sym.fh" 6603#include "errquit.fh" 6604#include "tce.fh" 6605 INTEGER d_a 6606 INTEGER k_a_offset 6607 INTEGER d_b 6608 INTEGER k_b_offset 6609 INTEGER d_c 6610 INTEGER k_c_offset 6611 INTEGER NXTASK 6612 INTEGER next 6613 INTEGER nprocs 6614 INTEGER count 6615 INTEGER p3b 6616 INTEGER p4b 6617 INTEGER h1b 6618 INTEGER h2b 6619 INTEGER dimc 6620 INTEGER l_c_sort 6621 INTEGER k_c_sort 6622 INTEGER p5b 6623 INTEGER h6b 6624 INTEGER p3b_1 6625 INTEGER p5b_1 6626 INTEGER h1b_1 6627 INTEGER h6b_1 6628 INTEGER p4b_2 6629 INTEGER h6b_2 6630 INTEGER h2b_2 6631 INTEGER p5b_2 6632 INTEGER dim_common 6633 INTEGER dima_sort 6634 INTEGER dima 6635 INTEGER dimb_sort 6636 INTEGER dimb 6637 INTEGER l_a_sort 6638 INTEGER k_a_sort 6639 INTEGER l_a 6640 INTEGER k_a 6641 INTEGER l_b_sort 6642 INTEGER k_b_sort 6643 INTEGER l_b 6644 INTEGER k_b 6645 INTEGER l_c 6646 INTEGER k_c 6647 EXTERNAL NXTASK 6648 nprocs = GA_NNODES() 6649 count = 0 6650 next = NXTASK(nprocs,1) 6651 DO p3b = noab+1,noab+nvab 6652 DO p4b = noab+1,noab+nvab 6653 DO h1b = 1,noab 6654 DO h2b = 1,noab 6655 IF (next.eq.count) THEN 6656 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 6657 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6658 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 6659 &1b-1)+int_mb(k_spin+h2b-1)) THEN 6660 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 6661 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 6662 &EN 6663 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 6664 &nge+h1b-1) * int_mb(k_range+h2b-1) 6665 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6666 & ERRQUIT('ccsdt_t2_7',0,MA_ERR) 6667 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6668 DO p5b = noab+1,noab+nvab 6669 DO h6b = 1,noab 6670 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 6671 &1b-1)+int_mb(k_spin+h6b-1)) THEN 6672 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 6673 &k_sym+h1b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_t) THEN 6674 CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h6b,p3b_1,p5b_1,h1b_1,h6b_1) 6675 CALL TCE_RESTRICTED_4(p4b,h6b,h2b,p5b,p4b_2,h6b_2,h2b_2,p5b_2) 6676 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) 6677 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) 6678 dima = dim_common * dima_sort 6679 dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h2b-1) 6680 dimb = dim_common * dimb_sort 6681 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6682 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6683 & ERRQUIT('ccsdt_t2_7',1,MA_ERR) 6684 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6685 &ccsdt_t2_7',2,MA_ERR) 6686 IF ((p5b .lt. p3b) .and. (h6b .lt. h1b)) THEN 6687 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 6688 & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 6689 &1 - noab - 1))))) 6690 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 6691 &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 6692 &,4,2,3,1,1.0d0) 6693 END IF 6694 IF ((p5b .lt. p3b) .and. (h1b .le. h6b)) THEN 6695 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 6696 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 6697 &1 - noab - 1))))) 6698 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 6699 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1) 6700 &,3,2,4,1,-1.0d0) 6701 END IF 6702 IF ((p3b .le. p5b) .and. (h6b .lt. h1b)) THEN 6703 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 6704 & - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 6705 &1 - noab - 1))))) 6706 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 6707 &,int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 6708 &,4,1,3,2,-1.0d0) 6709 END IF 6710 IF ((p3b .le. p5b) .and. (h1b .le. h6b)) THEN 6711 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 6712 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 6713 &1 - noab - 1))))) 6714 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 6715 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1) 6716 &,3,1,4,2,1.0d0) 6717 END IF 6718 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_7',3,MA_ERR) 6719 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6720 & ERRQUIT('ccsdt_t2_7',4,MA_ERR) 6721 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6722 &ccsdt_t2_7',5,MA_ERR) 6723 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 6724 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h6b_2 - 1 + noab * (p4b_ 6725 &2 - noab - 1))))) 6726 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 6727 &,int_mb(k_range+h6b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1) 6728 &,3,1,2,4,1.0d0) 6729 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_7',6,MA_ERR) 6730 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6731 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6732 &t),dima_sort) 6733 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_7',7,MA_ER 6734 &R) 6735 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_7',8,MA_ER 6736 &R) 6737 END IF 6738 END IF 6739 END IF 6740 END DO 6741 END DO 6742 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6743 &ccsdt_t2_7',9,MA_ERR) 6744 IF ((p3b .le. p4b) .and. (h1b .le. h2b)) THEN 6745 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6746 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 6747 &,4,2,3,1,-1.0d0) 6748 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 6749 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 6750 & - 1))))) 6751 END IF 6752 IF ((p3b .le. p4b) .and. (h2b .le. h1b)) THEN 6753 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6754 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 6755 &,4,2,1,3,1.0d0) 6756 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 6757 & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 6758 & - 1))))) 6759 END IF 6760 IF ((p4b .le. p3b) .and. (h1b .le. h2b)) THEN 6761 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6762 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 6763 &,2,4,3,1,1.0d0) 6764 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 6765 & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 6766 & - 1))))) 6767 END IF 6768 IF ((p4b .le. p3b) .and. (h2b .le. h1b)) THEN 6769 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6770 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 6771 &,2,4,1,3,-1.0d0) 6772 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 6773 & 1 + noab * (h2b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 6774 & - 1))))) 6775 END IF 6776 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_7',10,MA_ERR) 6777 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_7',11,MA_E 6778 &RR) 6779 END IF 6780 END IF 6781 END IF 6782 next = NXTASK(nprocs,1) 6783 END IF 6784 count = count + 1 6785 END DO 6786 END DO 6787 END DO 6788 END DO 6789 next = NXTASK(-nprocs,1) 6790 call GA_SYNC() 6791 RETURN 6792 END 6793 SUBROUTINE ccsdt_t2a_7_1(d_a,k_a_offset,d_c,k_c_offset) 6794C $Id$ 6795C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6796C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6797C i1 ( h6 p3 h1 p5 )_v + = 1 * v ( h6 p3 h1 p5 )_v 6798 IMPLICIT NONE 6799#include "global.fh" 6800#include "mafdecls.fh" 6801#include "sym.fh" 6802#include "errquit.fh" 6803#include "tce.fh" 6804 INTEGER d_a 6805 INTEGER k_a_offset 6806 INTEGER d_c 6807 INTEGER k_c_offset 6808 INTEGER NXTASK 6809 INTEGER next 6810 INTEGER nprocs 6811 INTEGER count 6812 INTEGER p3b 6813 INTEGER h6b 6814 INTEGER h1b 6815 INTEGER p5b 6816 INTEGER dimc 6817 INTEGER p3b_1 6818 INTEGER h6b_1 6819 INTEGER h1b_1 6820 INTEGER p5b_1 6821 INTEGER dim_common 6822 INTEGER dima_sort 6823 INTEGER dima 6824 INTEGER l_a_sort 6825 INTEGER k_a_sort 6826 INTEGER l_a 6827 INTEGER k_a 6828 INTEGER l_c 6829 INTEGER k_c 6830 EXTERNAL NXTASK 6831 nprocs = GA_NNODES() 6832 count = 0 6833 next = NXTASK(nprocs,1) 6834 DO p3b = noab+1,noab+nvab 6835 DO h6b = 1,noab 6836 DO h1b = 1,noab 6837 DO p5b = noab+1,noab+nvab 6838 IF (next.eq.count) THEN 6839 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1 6840 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 6841 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 6842 &1b-1)+int_mb(k_spin+p5b-1)) THEN 6843 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 6844 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 6845 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 6846 &nge+h1b-1) * int_mb(k_range+p5b-1) 6847 CALL TCE_RESTRICTED_4(p3b,h6b,h1b,p5b,p3b_1,h6b_1,h1b_1,p5b_1) 6848 dim_common = 1 6849 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb 6850 &(k_range+h1b-1) * int_mb(k_range+p5b-1) 6851 dima = dim_common * dima_sort 6852 IF (dima .gt. 0) THEN 6853 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6854 & ERRQUIT('ccsdt_t2_7_1',0,MA_ERR) 6855 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6856 &ccsdt_t2_7_1',1,MA_ERR) 6857 IF ((h6b .le. p3b) .and. (h1b .le. p5b)) THEN 6858 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 6859 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab 6860 &+nvab) * (h6b_1 - 1))))) 6861 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1) 6862 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1) 6863 &,4,3,1,2,1.0d0) 6864 END IF 6865 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_7_1',2,MA_ERR) 6866 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6867 &ccsdt_t2_7_1',3,MA_ERR) 6868 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 6869 &,int_mb(k_range+h1b-1),int_mb(k_range+h6b-1),int_mb(k_range+p3b-1) 6870 &,4,3,2,1,1.0d0) 6871 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 6872 & noab - 1 + nvab * (h1b - 1 + noab * (h6b - 1 + noab * (p3b - noab 6873 & - 1))))) 6874 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_7_1',4,MA_ERR) 6875 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_7_1',5,MA_ 6876 &ERR) 6877 END IF 6878 END IF 6879 END IF 6880 END IF 6881 next = NXTASK(nprocs,1) 6882 END IF 6883 count = count + 1 6884 END DO 6885 END DO 6886 END DO 6887 END DO 6888 next = NXTASK(-nprocs,1) 6889 call GA_SYNC() 6890 RETURN 6891 END 6892 SUBROUTINE OFFSET_ccsdt_t2a_7_1(l_a_offset,k_a_offset,size) 6893C $Id$ 6894C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6895C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6896C i1 ( h6 p3 h1 p5 )_v 6897 IMPLICIT NONE 6898#include "global.fh" 6899#include "mafdecls.fh" 6900#include "sym.fh" 6901#include "errquit.fh" 6902#include "tce.fh" 6903 INTEGER l_a_offset 6904 INTEGER k_a_offset 6905 INTEGER size 6906 INTEGER length 6907 INTEGER addr 6908 INTEGER p3b 6909 INTEGER h6b 6910 INTEGER h1b 6911 INTEGER p5b 6912 length = 0 6913 DO p3b = noab+1,noab+nvab 6914 DO h6b = 1,noab 6915 DO h1b = 1,noab 6916 DO p5b = noab+1,noab+nvab 6917 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 6918 &1b-1)+int_mb(k_spin+p5b-1)) THEN 6919 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 6920 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 6921 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1 6922 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 6923 length = length + 1 6924 END IF 6925 END IF 6926 END IF 6927 END DO 6928 END DO 6929 END DO 6930 END DO 6931 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 6932 &set)) CALL ERRQUIT('ccsdt_t2_7_1',0,MA_ERR) 6933 int_mb(k_a_offset) = length 6934 addr = 0 6935 size = 0 6936 DO p3b = noab+1,noab+nvab 6937 DO h6b = 1,noab 6938 DO h1b = 1,noab 6939 DO p5b = noab+1,noab+nvab 6940 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 6941 &1b-1)+int_mb(k_spin+p5b-1)) THEN 6942 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 6943 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 6944 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1 6945 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 6946 addr = addr + 1 6947 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 6948 &* (h6b - 1 + noab * (p3b - noab - 1))) 6949 int_mb(k_a_offset+length+addr) = size 6950 size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_ 6951 &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 6952 END IF 6953 END IF 6954 END IF 6955 END DO 6956 END DO 6957 END DO 6958 END DO 6959 RETURN 6960 END 6961 SUBROUTINE ccsdt_t2a_7_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 6962 &k_c_offset) 6963C $Id$ 6964C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6965C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6966C i1 ( h6 p3 h1 p5 )_vt + = -1 * Sum ( p7 ) * t ( p7 h1 )_t * v ( h6 p3 p5 p7 )_v 6967 IMPLICIT NONE 6968#include "global.fh" 6969#include "mafdecls.fh" 6970#include "sym.fh" 6971#include "errquit.fh" 6972#include "tce.fh" 6973 INTEGER d_a 6974 INTEGER k_a_offset 6975 INTEGER d_b 6976 INTEGER k_b_offset 6977 INTEGER d_c 6978 INTEGER k_c_offset 6979 INTEGER NXTASK 6980 INTEGER next 6981 INTEGER nprocs 6982 INTEGER count 6983 INTEGER p3b 6984 INTEGER h6b 6985 INTEGER h1b 6986 INTEGER p5b 6987 INTEGER dimc 6988 INTEGER l_c_sort 6989 INTEGER k_c_sort 6990 INTEGER p7b 6991 INTEGER p7b_1 6992 INTEGER h1b_1 6993 INTEGER p3b_2 6994 INTEGER h6b_2 6995 INTEGER p5b_2 6996 INTEGER p7b_2 6997 INTEGER dim_common 6998 INTEGER dima_sort 6999 INTEGER dima 7000 INTEGER dimb_sort 7001 INTEGER dimb 7002 INTEGER l_a_sort 7003 INTEGER k_a_sort 7004 INTEGER l_a 7005 INTEGER k_a 7006 INTEGER l_b_sort 7007 INTEGER k_b_sort 7008 INTEGER l_b 7009 INTEGER k_b 7010 INTEGER l_c 7011 INTEGER k_c 7012 EXTERNAL NXTASK 7013 nprocs = GA_NNODES() 7014 count = 0 7015 next = NXTASK(nprocs,1) 7016 DO p3b = noab+1,noab+nvab 7017 DO h6b = 1,noab 7018 DO h1b = 1,noab 7019 DO p5b = noab+1,noab+nvab 7020 IF (next.eq.count) THEN 7021 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1 7022 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 7023 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 7024 &1b-1)+int_mb(k_spin+p5b-1)) THEN 7025 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 7026 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 7027 &EN 7028 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 7029 &nge+h1b-1) * int_mb(k_range+p5b-1) 7030 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7031 & ERRQUIT('ccsdt_t2_7_2',0,MA_ERR) 7032 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7033 DO p7b = noab+1,noab+nvab 7034 IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)) THEN 7035 IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 7036 &EN 7037 CALL TCE_RESTRICTED_2(p7b,h1b,p7b_1,h1b_1) 7038 CALL TCE_RESTRICTED_4(p3b,h6b,p5b,p7b,p3b_2,h6b_2,p5b_2,p7b_2) 7039 dim_common = int_mb(k_range+p7b-1) 7040 dima_sort = int_mb(k_range+h1b-1) 7041 dima = dim_common * dima_sort 7042 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb 7043 &(k_range+p5b-1) 7044 dimb = dim_common * dimb_sort 7045 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7046 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7047 & ERRQUIT('ccsdt_t2_7_2',1,MA_ERR) 7048 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7049 &ccsdt_t2_7_2',2,MA_ERR) 7050 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 7051 & - 1 + noab * (p7b_1 - noab - 1))) 7052 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 7053 &,int_mb(k_range+h1b-1),2,1,1.0d0) 7054 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_7_2',3,MA_ERR) 7055 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7056 & ERRQUIT('ccsdt_t2_7_2',4,MA_ERR) 7057 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7058 &ccsdt_t2_7_2',5,MA_ERR) 7059 IF ((h6b .le. p3b) .and. (p7b .lt. p5b)) THEN 7060 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 7061 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 7062 &+nvab) * (h6b_2 - 1))))) 7063 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 7064 &,int_mb(k_range+p3b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) 7065 &,4,1,2,3,-1.0d0) 7066 END IF 7067 IF ((h6b .le. p3b) .and. (p5b .le. p7b)) THEN 7068 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 7069 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 7070 &+nvab) * (h6b_2 - 1))))) 7071 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 7072 &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) 7073 &,3,1,2,4,1.0d0) 7074 END IF 7075 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_7_2',6,MA_ERR) 7076 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 7077 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 7078 &t),dima_sort) 7079 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_7_2',7,MA_ 7080 &ERR) 7081 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_7_2',8,MA_ 7082 &ERR) 7083 END IF 7084 END IF 7085 END IF 7086 END DO 7087 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7088 &ccsdt_t2_7_2',9,MA_ERR) 7089 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 7090 &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 7091 &,3,2,4,1,-1.0d0) 7092 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 7093 & noab - 1 + nvab * (h1b - 1 + noab * (h6b - 1 + noab * (p3b - noab 7094 & - 1))))) 7095 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_7_2',10,MA_ERR) 7096 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_7_2',11,MA 7097 &_ERR) 7098 END IF 7099 END IF 7100 END IF 7101 next = NXTASK(nprocs,1) 7102 END IF 7103 count = count + 1 7104 END DO 7105 END DO 7106 END DO 7107 END DO 7108 next = NXTASK(-nprocs,1) 7109 call GA_SYNC() 7110 RETURN 7111 END 7112 SUBROUTINE ccsdt_t2a_7_3(d_a,k_a_offset,d_b,k_b_offset,d_c, 7113 &k_c_offset) 7114C $Id$ 7115C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7116C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7117C i1 ( h6 p3 h1 p5 )_vt + = -1/2 * Sum ( h8 p7 ) * t ( p3 p7 h1 h8 )_t * v ( h6 h8 p5 p7 )_v 7118 IMPLICIT NONE 7119#include "global.fh" 7120#include "mafdecls.fh" 7121#include "sym.fh" 7122#include "errquit.fh" 7123#include "tce.fh" 7124 INTEGER d_a 7125 INTEGER k_a_offset 7126 INTEGER d_b 7127 INTEGER k_b_offset 7128 INTEGER d_c 7129 INTEGER k_c_offset 7130 INTEGER NXTASK 7131 INTEGER next 7132 INTEGER nprocs 7133 INTEGER count 7134 INTEGER p3b 7135 INTEGER h6b 7136 INTEGER h1b 7137 INTEGER p5b 7138 INTEGER dimc 7139 INTEGER l_c_sort 7140 INTEGER k_c_sort 7141 INTEGER p7b 7142 INTEGER h8b 7143 INTEGER p3b_1 7144 INTEGER p7b_1 7145 INTEGER h1b_1 7146 INTEGER h8b_1 7147 INTEGER h6b_2 7148 INTEGER h8b_2 7149 INTEGER p5b_2 7150 INTEGER p7b_2 7151 INTEGER dim_common 7152 INTEGER dima_sort 7153 INTEGER dima 7154 INTEGER dimb_sort 7155 INTEGER dimb 7156 INTEGER l_a_sort 7157 INTEGER k_a_sort 7158 INTEGER l_a 7159 INTEGER k_a 7160 INTEGER l_b_sort 7161 INTEGER k_b_sort 7162 INTEGER l_b 7163 INTEGER k_b 7164 INTEGER l_c 7165 INTEGER k_c 7166 EXTERNAL NXTASK 7167 nprocs = GA_NNODES() 7168 count = 0 7169 next = NXTASK(nprocs,1) 7170 DO p3b = noab+1,noab+nvab 7171 DO h6b = 1,noab 7172 DO h1b = 1,noab 7173 DO p5b = noab+1,noab+nvab 7174 IF (next.eq.count) THEN 7175 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1 7176 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 7177 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 7178 &1b-1)+int_mb(k_spin+p5b-1)) THEN 7179 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 7180 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 7181 &EN 7182 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 7183 &nge+h1b-1) * int_mb(k_range+p5b-1) 7184 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7185 & ERRQUIT('ccsdt_t2_7_3',0,MA_ERR) 7186 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7187 DO p7b = noab+1,noab+nvab 7188 DO h8b = 1,noab 7189 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h 7190 &1b-1)+int_mb(k_spin+h8b-1)) THEN 7191 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb( 7192 &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_t) THEN 7193 CALL TCE_RESTRICTED_4(p3b,p7b,h1b,h8b,p3b_1,p7b_1,h1b_1,h8b_1) 7194 CALL TCE_RESTRICTED_4(h6b,h8b,p5b,p7b,h6b_2,h8b_2,p5b_2,p7b_2) 7195 dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+h8b-1) 7196 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) 7197 dima = dim_common * dima_sort 7198 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1) 7199 dimb = dim_common * dimb_sort 7200 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7201 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7202 & ERRQUIT('ccsdt_t2_7_3',1,MA_ERR) 7203 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7204 &ccsdt_t2_7_3',2,MA_ERR) 7205 IF ((p7b .lt. p3b) .and. (h8b .lt. h1b)) THEN 7206 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 7207 & - 1 + noab * (h8b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p7b_ 7208 &1 - noab - 1))))) 7209 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 7210 &,int_mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) 7211 &,4,2,3,1,1.0d0) 7212 END IF 7213 IF ((p7b .lt. p3b) .and. (h1b .le. h8b)) THEN 7214 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 7215 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p7b_ 7216 &1 - noab - 1))))) 7217 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 7218 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) 7219 &,3,2,4,1,-1.0d0) 7220 END IF 7221 IF ((p3b .le. p7b) .and. (h8b .lt. h1b)) THEN 7222 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 7223 & - 1 + noab * (h8b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p3b_ 7224 &1 - noab - 1))))) 7225 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7226 &,int_mb(k_range+p7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) 7227 &,4,1,3,2,-1.0d0) 7228 END IF 7229 IF ((p3b .le. p7b) .and. (h1b .le. h8b)) THEN 7230 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 7231 & - 1 + noab * (h1b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p3b_ 7232 &1 - noab - 1))))) 7233 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7234 &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) 7235 &,3,1,4,2,1.0d0) 7236 END IF 7237 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_7_3',3,MA_ERR) 7238 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7239 & ERRQUIT('ccsdt_t2_7_3',4,MA_ERR) 7240 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7241 &ccsdt_t2_7_3',5,MA_ERR) 7242 IF ((h8b .lt. h6b) .and. (p7b .lt. p5b)) THEN 7243 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 7244 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 7245 &+nvab) * (h8b_2 - 1))))) 7246 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 7247 &,int_mb(k_range+h6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) 7248 &,4,2,1,3,1.0d0) 7249 END IF 7250 IF ((h8b .lt. h6b) .and. (p5b .le. p7b)) THEN 7251 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 7252 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 7253 &+nvab) * (h8b_2 - 1))))) 7254 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 7255 &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) 7256 &,3,2,1,4,-1.0d0) 7257 END IF 7258 IF ((h6b .le. h8b) .and. (p7b .lt. p5b)) THEN 7259 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 7260 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 7261 &+nvab) * (h6b_2 - 1))))) 7262 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 7263 &,int_mb(k_range+h8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) 7264 &,4,1,2,3,-1.0d0) 7265 END IF 7266 IF ((h6b .le. h8b) .and. (p5b .le. p7b)) THEN 7267 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 7268 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 7269 &+nvab) * (h6b_2 - 1))))) 7270 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 7271 &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) 7272 &,3,1,2,4,1.0d0) 7273 END IF 7274 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_7_3',6,MA_ERR) 7275 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 7276 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 7277 &t),dima_sort) 7278 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_7_3',7,MA_ 7279 &ERR) 7280 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_7_3',8,MA_ 7281 &ERR) 7282 END IF 7283 END IF 7284 END IF 7285 END DO 7286 END DO 7287 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7288 &ccsdt_t2_7_3',9,MA_ERR) 7289 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 7290 &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 7291 &,4,2,3,1,-1.0d0/2.0d0) 7292 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 7293 & noab - 1 + nvab * (h1b - 1 + noab * (h6b - 1 + noab * (p3b - noab 7294 & - 1))))) 7295 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_7_3',10,MA_ERR) 7296 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_7_3',11,MA 7297 &_ERR) 7298 END IF 7299 END IF 7300 END IF 7301 next = NXTASK(nprocs,1) 7302 END IF 7303 count = count + 1 7304 END DO 7305 END DO 7306 END DO 7307 END DO 7308 next = NXTASK(-nprocs,1) 7309 call GA_SYNC() 7310 RETURN 7311 END 7312 SUBROUTINE ccsdt_t2a_8(d_a,k_a_offset,d_b,k_b_offset,d_c, 7313 &k_c_offset) 7314C $Id$ 7315C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7316C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7317C i0 ( p3 p4 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( p3 p4 p5 p6 )_v 7318 IMPLICIT NONE 7319#include "global.fh" 7320#include "mafdecls.fh" 7321#include "sym.fh" 7322#include "errquit.fh" 7323#include "tce.fh" 7324 INTEGER d_a 7325 INTEGER k_a_offset 7326 INTEGER d_b 7327 INTEGER k_b_offset 7328 INTEGER d_c 7329 INTEGER k_c_offset 7330 INTEGER NXTASK 7331 INTEGER next 7332 INTEGER nprocs 7333 INTEGER count 7334 INTEGER p3b 7335 INTEGER p4b 7336 INTEGER h1b 7337 INTEGER h2b 7338 INTEGER dimc 7339 INTEGER l_c_sort 7340 INTEGER k_c_sort 7341 INTEGER p5b 7342 INTEGER p6b 7343 INTEGER p5b_1 7344 INTEGER p6b_1 7345 INTEGER h1b_1 7346 INTEGER h2b_1 7347 INTEGER p3b_2 7348 INTEGER p4b_2 7349 INTEGER p5b_2 7350 INTEGER p6b_2 7351 INTEGER dim_common 7352 INTEGER dima_sort 7353 INTEGER dima 7354 INTEGER dimb_sort 7355 INTEGER dimb 7356 INTEGER l_a_sort 7357 INTEGER k_a_sort 7358 INTEGER l_a 7359 INTEGER k_a 7360 INTEGER l_b_sort 7361 INTEGER k_b_sort 7362 INTEGER l_b 7363 INTEGER k_b 7364 INTEGER nsuperp(2) 7365 INTEGER isuperp 7366 INTEGER l_c 7367 INTEGER k_c 7368 DOUBLE PRECISION FACTORIAL 7369 EXTERNAL NXTASK 7370 EXTERNAL FACTORIAL 7371 nprocs = GA_NNODES() 7372 count = 0 7373 next = NXTASK(nprocs,1) 7374 DO p3b = noab+1,noab+nvab 7375 DO p4b = p3b,noab+nvab 7376 DO h1b = 1,noab 7377 DO h2b = h1b,noab 7378 IF (next.eq.count) THEN 7379 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 7380 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 7381 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 7382 &1b-1)+int_mb(k_spin+h2b-1)) THEN 7383 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 7384 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 7385 &EN 7386 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 7387 &nge+h1b-1) * int_mb(k_range+h2b-1) 7388 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7389 & ERRQUIT('ccsdt_t2_8',0,MA_ERR) 7390 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7391 DO p5b = noab+1,noab+nvab 7392 DO p6b = p5b,noab+nvab 7393 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 7394 &1b-1)+int_mb(k_spin+h2b-1)) THEN 7395 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 7396 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 7397 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1) 7398 CALL TCE_RESTRICTED_4(p3b,p4b,p5b,p6b,p3b_2,p4b_2,p5b_2,p6b_2) 7399 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) 7400 dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 7401 dima = dim_common * dima_sort 7402 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) 7403 dimb = dim_common * dimb_sort 7404 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7405 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7406 & ERRQUIT('ccsdt_t2_8',1,MA_ERR) 7407 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7408 &ccsdt_t2_8',2,MA_ERR) 7409 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 7410 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 7411 &1 - noab - 1))))) 7412 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 7413 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 7414 &,4,3,2,1,1.0d0) 7415 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_8',3,MA_ERR) 7416 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7417 & ERRQUIT('ccsdt_t2_8',4,MA_ERR) 7418 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7419 &ccsdt_t2_8',5,MA_ERR) 7420 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 7421 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab 7422 &+nvab) * (p3b_2 - 1))))) 7423 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1) 7424 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 7425 &,2,1,4,3,1.0d0) 7426 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_8',6,MA_ERR) 7427 nsuperp(1) = 1 7428 nsuperp(2) = 1 7429 isuperp = 1 7430 IF (p5b .eq. p6b) THEN 7431 nsuperp(isuperp) = nsuperp(isuperp) + 1 7432 ELSE 7433 isuperp = isuperp + 1 7434 END IF 7435 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 7436 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 7437 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 7438 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_8',7,MA_ER 7439 &R) 7440 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_8',8,MA_ER 7441 &R) 7442 END IF 7443 END IF 7444 END IF 7445 END DO 7446 END DO 7447 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7448 &ccsdt_t2_8',9,MA_ERR) 7449 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 7450 &,int_mb(k_range+p3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 7451 &,2,1,4,3,1.0d0/2.0d0) 7452 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 7453 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 7454 & - 1))))) 7455 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_8',10,MA_ERR) 7456 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_8',11,MA_E 7457 &RR) 7458 END IF 7459 END IF 7460 END IF 7461 next = NXTASK(nprocs,1) 7462 END IF 7463 count = count + 1 7464 END DO 7465 END DO 7466 END DO 7467 END DO 7468 next = NXTASK(-nprocs,1) 7469 call GA_SYNC() 7470 RETURN 7471 END 7472 SUBROUTINE ccsdt_t2a_9(d_a,k_a_offset,d_b,k_b_offset,d_c, 7473 &k_c_offset) 7474C $Id$ 7475C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7476C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7477C i0 ( p3 p4 h1 h2 )_tf + = 1 * Sum ( p9 h10 ) * t ( p3 p4 p9 h1 h2 h10 )_t * i1 ( h10 p9 )_f 7478 IMPLICIT NONE 7479#include "global.fh" 7480#include "mafdecls.fh" 7481#include "sym.fh" 7482#include "errquit.fh" 7483#include "tce.fh" 7484 INTEGER d_a 7485 INTEGER k_a_offset 7486 INTEGER d_b 7487 INTEGER k_b_offset 7488 INTEGER d_c 7489 INTEGER k_c_offset 7490 INTEGER NXTASK 7491 INTEGER next 7492 INTEGER nprocs 7493 INTEGER count 7494 INTEGER p3b 7495 INTEGER p4b 7496 INTEGER h1b 7497 INTEGER h2b 7498 INTEGER dimc 7499 INTEGER l_c_sort 7500 INTEGER k_c_sort 7501 INTEGER p9b 7502 INTEGER h10b 7503 INTEGER p3b_1 7504 INTEGER p4b_1 7505 INTEGER p9b_1 7506 INTEGER h1b_1 7507 INTEGER h2b_1 7508 INTEGER h10b_1 7509 INTEGER h10b_2 7510 INTEGER p9b_2 7511 INTEGER dim_common 7512 INTEGER dima_sort 7513 INTEGER dima 7514 INTEGER dimb_sort 7515 INTEGER dimb 7516 INTEGER l_a_sort 7517 INTEGER k_a_sort 7518 INTEGER l_a 7519 INTEGER k_a 7520 INTEGER l_b_sort 7521 INTEGER k_b_sort 7522 INTEGER l_b 7523 INTEGER k_b 7524 INTEGER l_c 7525 INTEGER k_c 7526 LOGICAL ACOLO 7527 EXTERNAL NXTASK 7528 nprocs = GA_NNODES() 7529 count = 0 7530 next = NXTASK(nprocs,1) 7531 DO p3b = noab+1,noab+nvab 7532 DO p4b = p3b,noab+nvab 7533 DO h1b = 1,noab 7534 DO h2b = h1b,noab 7535 IF (next.eq.count) THEN 7536 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 7537 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 7538 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 7539 &1b-1)+int_mb(k_spin+h2b-1)) THEN 7540 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 7541 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_t,irrep_f)) TH 7542 &EN 7543 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 7544 &nge+h1b-1) * int_mb(k_range+h2b-1) 7545 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7546 & ERRQUIT('ccsdt_t2_9',0,MA_ERR) 7547 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7548 DO p9b = noab+1,noab+nvab 7549 DO h10b = 1,noab 7550 IF(acolo(p3b,p4b,p9b,h1b,h2b,h10b)) THEN 7551 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1)+int_mb(k_spin+p9b-1) 7552 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h10b 7553 &-1)) THEN 7554 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 7555 &k_sym+p9b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 7556 &_mb(k_sym+h10b-1)))))) .eq. irrep_t) THEN 7557 CALL TCE_RESTRICTED_6(p3b,p4b,p9b,h1b,h2b,h10b,p3b_1,p4b_1,p9b_1,h 7558 &1b_1,h2b_1,h10b_1) 7559 CALL TCE_RESTRICTED_2(h10b,p9b,h10b_2,p9b_2) 7560 dim_common = int_mb(k_range+p9b-1) * int_mb(k_range+h10b-1) 7561 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb 7562 &(k_range+h1b-1) * int_mb(k_range+h2b-1) 7563 dima = dim_common * dima_sort 7564 dimb_sort = 1 7565 dimb = dim_common * dimb_sort 7566 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7567 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7568 & ERRQUIT('ccsdt_t2_9',1,MA_ERR) 7569 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7570 &ccsdt_t2_9',2,MA_ERR) 7571 IF ((p9b .lt. p3b) .and. (h10b .lt. h1b)) THEN 7572 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 7573 & - 1 + noab * (h1b_1 - 1 + noab * (h10b_1 - 1 + noab * (p4b_1 - no 7574 &ab - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p9b_1 - noab - 1)))))) 7575 &) 7576 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 7577 &,int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+h10b-1 7578 &),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,3,2,4,1,1.0d0) 7579 END IF 7580 IF ((p9b .lt. p3b) .and. (h1b .le. h10b) .and. (h10b .lt. h2b)) TH 7581 &EN 7582 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 7583 & - 1 + noab * (h10b_1 - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - no 7584 &ab - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p9b_1 - noab - 1)))))) 7585 &) 7586 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 7587 &,int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+h1b-1) 7588 &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),6,4,3,2,5,1,-1.0d0) 7589 END IF 7590 IF ((p9b .lt. p3b) .and. (h2b .le. h10b)) THEN 7591 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_ 7592 &1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - no 7593 &ab - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p9b_1 - noab - 1)))))) 7594 &) 7595 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 7596 &,int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+h1b-1) 7597 &,int_mb(k_range+h2b-1),int_mb(k_range+h10b-1),5,4,3,2,6,1,1.0d0) 7598 END IF 7599 IF ((p3b .le. p9b) .and. (p9b .lt. p4b) .and. (h10b .lt. h1b)) THE 7600 &N 7601 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 7602 & - 1 + noab * (h1b_1 - 1 + noab * (h10b_1 - 1 + noab * (p4b_1 - no 7603 &ab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p3b_1 - noab - 1)))))) 7604 &) 7605 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7606 &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+h10b-1 7607 &),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,3,1,4,2,-1.0d0) 7608 END IF 7609 IF ((p3b .le. p9b) .and. (p9b .lt. p4b) .and. (h1b .le. h10b) .and 7610 &. (h10b .lt. h2b)) THEN 7611 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 7612 & - 1 + noab * (h10b_1 - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - no 7613 &ab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p3b_1 - noab - 1)))))) 7614 &) 7615 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7616 &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+h1b-1) 7617 &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),6,4,3,1,5,2,1.0d0) 7618 END IF 7619 IF ((p3b .le. p9b) .and. (p9b .lt. p4b) .and. (h2b .le. h10b)) THE 7620 &N 7621 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_ 7622 &1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - no 7623 &ab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p3b_1 - noab - 1)))))) 7624 &) 7625 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7626 &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+h1b-1) 7627 &,int_mb(k_range+h2b-1),int_mb(k_range+h10b-1),5,4,3,1,6,2,-1.0d0) 7628 END IF 7629 IF ((p4b .le. p9b) .and. (h10b .lt. h1b)) THEN 7630 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 7631 & - 1 + noab * (h1b_1 - 1 + noab * (h10b_1 - 1 + noab * (p9b_1 - no 7632 &ab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1)))))) 7633 &) 7634 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7635 &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+h10b-1 7636 &),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,2,1,4,3,1.0d0) 7637 END IF 7638 IF ((p4b .le. p9b) .and. (h1b .le. h10b) .and. (h10b .lt. h2b)) TH 7639 &EN 7640 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 7641 & - 1 + noab * (h10b_1 - 1 + noab * (h1b_1 - 1 + noab * (p9b_1 - no 7642 &ab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1)))))) 7643 &) 7644 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7645 &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+h1b-1) 7646 &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),6,4,2,1,5,3,-1.0d0) 7647 END IF 7648 IF ((p4b .le. p9b) .and. (h2b .le. h10b)) THEN 7649 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_ 7650 &1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p9b_1 - no 7651 &ab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1)))))) 7652 &) 7653 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7654 &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+h1b-1) 7655 &,int_mb(k_range+h2b-1),int_mb(k_range+h10b-1),5,4,2,1,6,3,1.0d0) 7656 END IF 7657 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_9',3,MA_ERR) 7658 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7659 & ERRQUIT('ccsdt_t2_9',4,MA_ERR) 7660 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7661 &ccsdt_t2_9',5,MA_ERR) 7662 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 7663 & - noab - 1 + nvab * (h10b_2 - 1))) 7664 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 7665 &),int_mb(k_range+p9b-1),1,2,1.0d0) 7666 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_9',6,MA_ERR) 7667 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 7668 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 7669 &t),dima_sort) 7670 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_9',7,MA_ER 7671 &R) 7672 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_9',8,MA_ER 7673 &R) 7674 END IF 7675 END IF 7676 END IF 7677 END IF !active 7678 END DO 7679 END DO 7680 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7681 &ccsdt_t2_9',9,MA_ERR) 7682 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 7683 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 7684 &,4,3,2,1,1.0d0) 7685 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 7686 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 7687 & - 1))))) 7688 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_9',10,MA_ERR) 7689 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_9',11,MA_E 7690 &RR) 7691 END IF 7692 END IF 7693 END IF 7694 next = NXTASK(nprocs,1) 7695 END IF 7696 count = count + 1 7697 END DO 7698 END DO 7699 END DO 7700 END DO 7701 next = NXTASK(-nprocs,1) 7702 call GA_SYNC() 7703 RETURN 7704 END 7705 SUBROUTINE ccsdt_t2a_9_1(d_a,k_a_offset,d_c,k_c_offset) 7706C $Id$ 7707C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7708C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7709C i1 ( h10 p9 )_f + = 1 * f ( h10 p9 )_f 7710 IMPLICIT NONE 7711#include "global.fh" 7712#include "mafdecls.fh" 7713#include "sym.fh" 7714#include "errquit.fh" 7715#include "tce.fh" 7716 INTEGER d_a 7717 INTEGER k_a_offset 7718 INTEGER d_c 7719 INTEGER k_c_offset 7720 INTEGER NXTASK 7721 INTEGER next 7722 INTEGER nprocs 7723 INTEGER count 7724 INTEGER h10b 7725 INTEGER p9b 7726 INTEGER dimc 7727 INTEGER h10b_1 7728 INTEGER p9b_1 7729 INTEGER dim_common 7730 INTEGER dima_sort 7731 INTEGER dima 7732 INTEGER l_a_sort 7733 INTEGER k_a_sort 7734 INTEGER l_a 7735 INTEGER k_a 7736 INTEGER l_c 7737 INTEGER k_c 7738 LOGICAL ACOLO_1P_1H 7739 EXTERNAL NXTASK 7740 nprocs = GA_NNODES() 7741 count = 0 7742 next = NXTASK(nprocs,1) 7743 DO h10b = 1,noab 7744 DO p9b = noab+1,noab+nvab 7745 IF (next.eq.count) THEN 7746 IF(acolo_1p_1h(p9b,h10b)) THEN 7747 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p9b- 7748 &1).ne.4)) THEN 7749 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p9b-1)) THEN 7750 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p9b-1)) .eq. irrep_f) T 7751 &HEN 7752 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+p9b-1) 7753 CALL TCE_RESTRICTED_2(h10b,p9b,h10b_1,p9b_1) 7754 dim_common = 1 7755 dima_sort = int_mb(k_range+h10b-1) * int_mb(k_range+p9b-1) 7756 dima = dim_common * dima_sort 7757 IF (dima .gt. 0) THEN 7758 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7759 & ERRQUIT('ccsdt_t2_9_1',0,MA_ERR) 7760 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7761 &ccsdt_t2_9_1',1,MA_ERR) 7762 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p9b_1 7763 & - 1 + (noab+nvab) * (h10b_1 - 1))) 7764 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1 7765 &),int_mb(k_range+p9b-1),2,1,1.0d0) 7766 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_9_1',2,MA_ERR) 7767 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7768 &ccsdt_t2_9_1',3,MA_ERR) 7769 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p9b-1) 7770 &,int_mb(k_range+h10b-1),2,1,1.0d0) 7771 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b - 7772 & noab - 1 + nvab * (h10b - 1))) 7773 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_9_1',4,MA_ERR) 7774 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_9_1',5,MA_ 7775 &ERR) 7776 END IF 7777 END IF 7778 END IF 7779 END IF 7780 END IF !active 7781 next = NXTASK(nprocs,1) 7782 END IF 7783 count = count + 1 7784 END DO 7785 END DO 7786 next = NXTASK(-nprocs,1) 7787 call GA_SYNC() 7788 RETURN 7789 END 7790 SUBROUTINE OFFSET_ccsdt_t2a_9_1(l_a_offset,k_a_offset,size) 7791C $Id$ 7792C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7793C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7794C i1 ( h10 p9 )_f 7795 IMPLICIT NONE 7796#include "global.fh" 7797#include "mafdecls.fh" 7798#include "sym.fh" 7799#include "errquit.fh" 7800#include "tce.fh" 7801 INTEGER l_a_offset 7802 INTEGER k_a_offset 7803 INTEGER size 7804 INTEGER length 7805 INTEGER addr 7806 INTEGER h10b 7807 INTEGER p9b 7808 LOGICAL ACOLO_1P_1H 7809 length = 0 7810 DO h10b = 1,noab 7811 DO p9b = noab+1,noab+nvab 7812 IF(acolo_1p_1h(p9b,h10b)) THEN 7813 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p9b-1)) THEN 7814 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p9b-1)) .eq. irrep_f) T 7815 &HEN 7816 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p9b- 7817 &1).ne.4)) THEN 7818 length = length + 1 7819 END IF 7820 END IF 7821 END IF 7822 END IF !active 7823 END DO 7824 END DO 7825 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 7826 &set)) CALL ERRQUIT('ccsdt_t2_9_1',0,MA_ERR) 7827 int_mb(k_a_offset) = length 7828 addr = 0 7829 size = 0 7830 DO h10b = 1,noab 7831 DO p9b = noab+1,noab+nvab 7832 IF(acolo_1p_1h(p9b,h10b)) THEN 7833 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p9b-1)) THEN 7834 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p9b-1)) .eq. irrep_f) T 7835 &HEN 7836 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p9b- 7837 &1).ne.4)) THEN 7838 addr = addr + 1 7839 int_mb(k_a_offset+addr) = p9b - noab - 1 + nvab * (h10b - 1) 7840 int_mb(k_a_offset+length+addr) = size 7841 size = size + int_mb(k_range+h10b-1) * int_mb(k_range+p9b-1) 7842 END IF 7843 END IF 7844 END IF 7845 END IF !active 7846 END DO 7847 END DO 7848 RETURN 7849 END 7850 SUBROUTINE ccsdt_t2a_9_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 7851 &k_c_offset) 7852C $Id$ 7853C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7854C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7855C i1 ( h10 p9 )_vt + = 1 * Sum ( h8 p7 ) * t ( p7 h8 )_t * v ( h8 h10 p7 p9 )_v 7856 IMPLICIT NONE 7857#include "global.fh" 7858#include "mafdecls.fh" 7859#include "sym.fh" 7860#include "errquit.fh" 7861#include "tce.fh" 7862 INTEGER d_a 7863 INTEGER k_a_offset 7864 INTEGER d_b 7865 INTEGER k_b_offset 7866 INTEGER d_c 7867 INTEGER k_c_offset 7868 INTEGER NXTASK 7869 INTEGER next 7870 INTEGER nprocs 7871 INTEGER count 7872 INTEGER h10b 7873 INTEGER p9b 7874 INTEGER dimc 7875 INTEGER l_c_sort 7876 INTEGER k_c_sort 7877 INTEGER p7b 7878 INTEGER h8b 7879 INTEGER p7b_1 7880 INTEGER h8b_1 7881 INTEGER h10b_2 7882 INTEGER h8b_2 7883 INTEGER p9b_2 7884 INTEGER p7b_2 7885 INTEGER dim_common 7886 INTEGER dima_sort 7887 INTEGER dima 7888 INTEGER dimb_sort 7889 INTEGER dimb 7890 INTEGER l_a_sort 7891 INTEGER k_a_sort 7892 INTEGER l_a 7893 INTEGER k_a 7894 INTEGER l_b_sort 7895 INTEGER k_b_sort 7896 INTEGER l_b 7897 INTEGER k_b 7898 INTEGER l_c 7899 INTEGER k_c 7900 LOGICAL ACOLO_1P_1H 7901 EXTERNAL NXTASK 7902 nprocs = GA_NNODES() 7903 count = 0 7904 next = NXTASK(nprocs,1) 7905 DO h10b = 1,noab 7906 DO p9b = noab+1,noab+nvab 7907 IF (next.eq.count) THEN 7908 IF(acolo_1p_1h(p9b,h10b)) THEN 7909 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p9b- 7910 &1).ne.4)) THEN 7911 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p9b-1)) THEN 7912 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p9b-1)) .eq. ieor(irrep 7913 &_v,irrep_t)) THEN 7914 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+p9b-1) 7915 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7916 & ERRQUIT('ccsdt_t2_9_2',0,MA_ERR) 7917 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7918 DO p7b = noab+1,noab+nvab 7919 DO h8b = 1,noab 7920 IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h8b-1)) THEN 7921 IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h8b-1)) .eq. irrep_t) TH 7922 &EN 7923 CALL TCE_RESTRICTED_2(p7b,h8b,p7b_1,h8b_1) 7924 CALL TCE_RESTRICTED_4(h10b,h8b,p9b,p7b,h10b_2,h8b_2,p9b_2,p7b_2) 7925 dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+h8b-1) 7926 dima_sort = 1 7927 dima = dim_common * dima_sort 7928 dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+p9b-1) 7929 dimb = dim_common * dimb_sort 7930 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7931 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7932 & ERRQUIT('ccsdt_t2_9_2',1,MA_ERR) 7933 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7934 &ccsdt_t2_9_2',2,MA_ERR) 7935 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 7936 & - 1 + noab * (p7b_1 - noab - 1))) 7937 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 7938 &,int_mb(k_range+h8b-1),2,1,1.0d0) 7939 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_9_2',3,MA_ERR) 7940 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7941 & ERRQUIT('ccsdt_t2_9_2',4,MA_ERR) 7942 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7943 &ccsdt_t2_9_2',5,MA_ERR) 7944 IF ((h8b .le. h10b) .and. (p7b .le. p9b)) THEN 7945 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 7946 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 7947 &b+nvab) * (h8b_2 - 1))))) 7948 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 7949 &,int_mb(k_range+h10b-1),int_mb(k_range+p7b-1),int_mb(k_range+p9b-1 7950 &),4,2,1,3,1.0d0) 7951 END IF 7952 IF ((h8b .le. h10b) .and. (p9b .lt. p7b)) THEN 7953 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 7954 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 7955 &b+nvab) * (h8b_2 - 1))))) 7956 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 7957 &,int_mb(k_range+h10b-1),int_mb(k_range+p9b-1),int_mb(k_range+p7b-1 7958 &),3,2,1,4,-1.0d0) 7959 END IF 7960 IF ((h10b .lt. h8b) .and. (p7b .le. p9b)) THEN 7961 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 7962 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 7963 &+nvab) * (h10b_2 - 1))))) 7964 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 7965 &),int_mb(k_range+h8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p9b-1 7966 &),4,1,2,3,-1.0d0) 7967 END IF 7968 IF ((h10b .lt. h8b) .and. (p9b .lt. p7b)) THEN 7969 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 7970 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 7971 &+nvab) * (h10b_2 - 1))))) 7972 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 7973 &),int_mb(k_range+h8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p7b-1 7974 &),3,1,2,4,1.0d0) 7975 END IF 7976 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_9_2',6,MA_ERR) 7977 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 7978 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 7979 &t),dima_sort) 7980 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_9_2',7,MA_ 7981 &ERR) 7982 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_9_2',8,MA_ 7983 &ERR) 7984 END IF 7985 END IF 7986 END IF 7987 END DO 7988 END DO 7989 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7990 &ccsdt_t2_9_2',9,MA_ERR) 7991 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p9b-1) 7992 &,int_mb(k_range+h10b-1),2,1,1.0d0) 7993 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b - 7994 & noab - 1 + nvab * (h10b - 1))) 7995 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_9_2',10,MA_ERR) 7996 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_9_2',11,MA 7997 &_ERR) 7998 END IF 7999 END IF 8000 END IF 8001 END IF !active 8002 next = NXTASK(nprocs,1) 8003 END IF 8004 count = count + 1 8005 END DO 8006 END DO 8007 next = NXTASK(-nprocs,1) 8008 call GA_SYNC() 8009 RETURN 8010 END 8011 SUBROUTINE ccsdt_t2a_10(d_a,k_a_offset,d_b,k_b_offset,d_c, 8012 &k_c_offset) 8013C $Id$ 8014C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8015C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8016C i0 ( p3 p4 h1 h2 )_vt + = -1/2 * P( 2 ) * Sum ( h6 h7 p5 ) * t ( p3 p4 p5 h1 h6 h7 )_t * i1 ( h6 h7 h2 p5 )_v 8017 IMPLICIT NONE 8018#include "global.fh" 8019#include "mafdecls.fh" 8020#include "sym.fh" 8021#include "errquit.fh" 8022#include "tce.fh" 8023 INTEGER d_a 8024 INTEGER k_a_offset 8025 INTEGER d_b 8026 INTEGER k_b_offset 8027 INTEGER d_c 8028 INTEGER k_c_offset 8029 INTEGER NXTASK 8030 INTEGER next 8031 INTEGER nprocs 8032 INTEGER count 8033 INTEGER p3b 8034 INTEGER p4b 8035 INTEGER h1b 8036 INTEGER h2b 8037 INTEGER dimc 8038 INTEGER l_c_sort 8039 INTEGER k_c_sort 8040 INTEGER p5b 8041 INTEGER h6b 8042 INTEGER h7b 8043 INTEGER p3b_1 8044 INTEGER p4b_1 8045 INTEGER p5b_1 8046 INTEGER h1b_1 8047 INTEGER h6b_1 8048 INTEGER h7b_1 8049 INTEGER h6b_2 8050 INTEGER h7b_2 8051 INTEGER h2b_2 8052 INTEGER p5b_2 8053 INTEGER dim_common 8054 INTEGER dima_sort 8055 INTEGER dima 8056 INTEGER dimb_sort 8057 INTEGER dimb 8058 INTEGER l_a_sort 8059 INTEGER k_a_sort 8060 INTEGER l_a 8061 INTEGER k_a 8062 INTEGER l_b_sort 8063 INTEGER k_b_sort 8064 INTEGER l_b 8065 INTEGER k_b 8066 INTEGER nsubh(2) 8067 INTEGER isubh 8068 INTEGER l_c 8069 INTEGER k_c 8070 LOGICAL ACOLO 8071 DOUBLE PRECISION FACTORIAL 8072 EXTERNAL NXTASK 8073 EXTERNAL FACTORIAL 8074 nprocs = GA_NNODES() 8075 count = 0 8076 next = NXTASK(nprocs,1) 8077 DO p3b = noab+1,noab+nvab 8078 DO p4b = p3b,noab+nvab 8079 DO h1b = 1,noab 8080 DO h2b = 1,noab 8081 IF (next.eq.count) THEN 8082 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 8083 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 8084 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 8085 &1b-1)+int_mb(k_spin+h2b-1)) THEN 8086 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 8087 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 8088 &EN 8089 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 8090 &nge+h1b-1) * int_mb(k_range+h2b-1) 8091 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8092 & ERRQUIT('ccsdt_t2_10',0,MA_ERR) 8093 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8094 DO p5b = noab+1,noab+nvab 8095 DO h6b = 1,noab 8096 DO h7b = h6b,noab 8097 IF(acolo(p3b,p4b,p5b,h1b,h6b,h7b)) THEN 8098 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) 8099 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b- 8100 &1)) THEN 8101 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 8102 &k_sym+p5b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h6b-1),int 8103 &_mb(k_sym+h7b-1)))))) .eq. irrep_t) THEN 8104 CALL TCE_RESTRICTED_6(p3b,p4b,p5b,h1b,h6b,h7b,p3b_1,p4b_1,p5b_1,h1 8105 &b_1,h6b_1,h7b_1) 8106 CALL TCE_RESTRICTED_4(h6b,h7b,h2b,p5b,h6b_2,h7b_2,h2b_2,p5b_2) 8107 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) * int_m 8108 &b(k_range+h7b-1) 8109 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb 8110 &(k_range+h1b-1) 8111 dima = dim_common * dima_sort 8112 dimb_sort = int_mb(k_range+h2b-1) 8113 dimb = dim_common * dimb_sort 8114 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8115 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8116 & ERRQUIT('ccsdt_t2_10',1,MA_ERR) 8117 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8118 &ccsdt_t2_10',2,MA_ERR) 8119 IF ((p5b .lt. p3b) .and. (h7b .lt. h1b)) THEN 8120 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 8121 & - 1 + noab * (h7b_1 - 1 + noab * (h6b_1 - 1 + noab * (p4b_1 - noa 8122 &b - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 8123 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8124 &,int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+h6b-1) 8125 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),6,3,2,5,4,1,1.0d0) 8126 END IF 8127 IF ((p5b .lt. p3b) .and. (h6b .lt. h1b) .and. (h1b .le. h7b)) THEN 8128 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8129 & - 1 + noab * (h1b_1 - 1 + noab * (h6b_1 - 1 + noab * (p4b_1 - noa 8130 &b - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 8131 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8132 &,int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+h6b-1) 8133 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),5,3,2,6,4,1,-1.0d0) 8134 END IF 8135 IF ((p5b .lt. p3b) .and. (h1b .le. h6b)) THEN 8136 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8137 & - 1 + noab * (h6b_1 - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noa 8138 &b - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 8139 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8140 &,int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+h1b-1) 8141 &,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),4,3,2,6,5,1,1.0d0) 8142 END IF 8143 IF ((p3b .le. p5b) .and. (p5b .lt. p4b) .and. (h7b .lt. h1b)) THEN 8144 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 8145 & - 1 + noab * (h7b_1 - 1 + noab * (h6b_1 - 1 + noab * (p4b_1 - noa 8146 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 8147 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8148 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),int_mb(k_range+h6b-1) 8149 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),6,3,1,5,4,2,-1.0d0) 8150 END IF 8151 IF ((p3b .le. p5b) .and. (p5b .lt. p4b) .and. (h6b .lt. h1b) .and. 8152 & (h1b .le. h7b)) THEN 8153 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8154 & - 1 + noab * (h1b_1 - 1 + noab * (h6b_1 - 1 + noab * (p4b_1 - noa 8155 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 8156 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8157 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),int_mb(k_range+h6b-1) 8158 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),5,3,1,6,4,2,1.0d0) 8159 END IF 8160 IF ((p3b .le. p5b) .and. (p5b .lt. p4b) .and. (h1b .le. h6b)) THEN 8161 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8162 & - 1 + noab * (h6b_1 - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noa 8163 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 8164 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8165 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),int_mb(k_range+h1b-1) 8166 &,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),4,3,1,6,5,2,-1.0d0) 8167 END IF 8168 IF ((p4b .le. p5b) .and. (h7b .lt. h1b)) THEN 8169 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 8170 & - 1 + noab * (h7b_1 - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noa 8171 &b - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 8172 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8173 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+h6b-1) 8174 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),6,2,1,5,4,3,1.0d0) 8175 END IF 8176 IF ((p4b .le. p5b) .and. (h6b .lt. h1b) .and. (h1b .le. h7b)) THEN 8177 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8178 & - 1 + noab * (h1b_1 - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noa 8179 &b - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 8180 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8181 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+h6b-1) 8182 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),5,2,1,6,4,3,-1.0d0) 8183 END IF 8184 IF ((p4b .le. p5b) .and. (h1b .le. h6b)) THEN 8185 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8186 & - 1 + noab * (h6b_1 - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noa 8187 &b - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 8188 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8189 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+h1b-1) 8190 &,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),4,2,1,6,5,3,1.0d0) 8191 END IF 8192 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_10',3,MA_ERR) 8193 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8194 & ERRQUIT('ccsdt_t2_10',4,MA_ERR) 8195 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8196 &ccsdt_t2_10',5,MA_ERR) 8197 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 8198 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (h6b_ 8199 &2 - 1))))) 8200 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 8201 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1) 8202 &,3,2,1,4,1.0d0) 8203 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_10',6,MA_ERR) 8204 nsubh(1) = 1 8205 nsubh(2) = 1 8206 isubh = 1 8207 IF (h6b .eq. h7b) THEN 8208 nsubh(isubh) = nsubh(isubh) + 1 8209 ELSE 8210 isubh = isubh + 1 8211 END IF 8212 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 8213 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 8214 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 8215 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_10',7,MA_E 8216 &RR) 8217 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_10',8,MA_E 8218 &RR) 8219 END IF 8220 END IF 8221 END IF 8222 END IF !active 8223 END DO 8224 END DO 8225 END DO 8226 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8227 &ccsdt_t2_10',9,MA_ERR) 8228 IF ((h1b .le. h2b)) THEN 8229 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 8230 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 8231 &,4,3,2,1,-1.0d0/2.0d0) 8232 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 8233 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 8234 & - 1))))) 8235 END IF 8236 IF ((h2b .le. h1b)) THEN 8237 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 8238 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 8239 &,4,3,1,2,1.0d0/2.0d0) 8240 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 8241 & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 8242 & - 1))))) 8243 END IF 8244 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_10',10,MA_ERR) 8245 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_10',11,MA_ 8246 &ERR) 8247 END IF 8248 END IF 8249 END IF 8250 next = NXTASK(nprocs,1) 8251 END IF 8252 count = count + 1 8253 END DO 8254 END DO 8255 END DO 8256 END DO 8257 next = NXTASK(-nprocs,1) 8258 call GA_SYNC() 8259 RETURN 8260 END 8261 SUBROUTINE ccsdt_t2a_10_1(d_a,k_a_offset,d_c,k_c_offset) 8262C $Id$ 8263C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8264C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8265C i1 ( h6 h7 h1 p5 )_v + = 1 * v ( h6 h7 h1 p5 )_v 8266 IMPLICIT NONE 8267#include "global.fh" 8268#include "mafdecls.fh" 8269#include "sym.fh" 8270#include "errquit.fh" 8271#include "tce.fh" 8272 INTEGER d_a 8273 INTEGER k_a_offset 8274 INTEGER d_c 8275 INTEGER k_c_offset 8276 INTEGER NXTASK 8277 INTEGER next 8278 INTEGER nprocs 8279 INTEGER count 8280 INTEGER h6b 8281 INTEGER h7b 8282 INTEGER h1b 8283 INTEGER p5b 8284 INTEGER dimc 8285 INTEGER h6b_1 8286 INTEGER h7b_1 8287 INTEGER h1b_1 8288 INTEGER p5b_1 8289 INTEGER dim_common 8290 INTEGER dima_sort 8291 INTEGER dima 8292 INTEGER l_a_sort 8293 INTEGER k_a_sort 8294 INTEGER l_a 8295 INTEGER k_a 8296 INTEGER l_c 8297 INTEGER k_c 8298 LOGICAL ACOLO_1P_2H 8299 EXTERNAL NXTASK 8300 nprocs = GA_NNODES() 8301 count = 0 8302 next = NXTASK(nprocs,1) 8303 DO h6b = 1,noab 8304 DO h7b = h6b,noab 8305 DO h1b = 1,noab 8306 DO p5b = noab+1,noab+nvab 8307 IF (next.eq.count) THEN 8308 IF(acolo_1p_2h(p5b,h6b,h7b)) THEN 8309 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1 8310 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 8311 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 8312 &1b-1)+int_mb(k_spin+p5b-1)) THEN 8313 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 8314 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 8315 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra 8316 &nge+h1b-1) * int_mb(k_range+p5b-1) 8317 CALL TCE_RESTRICTED_4(h6b,h7b,h1b,p5b,h6b_1,h7b_1,h1b_1,p5b_1) 8318 dim_common = 1 8319 dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h7b-1) * int_mb 8320 &(k_range+h1b-1) * int_mb(k_range+p5b-1) 8321 dima = dim_common * dima_sort 8322 IF (dima .gt. 0) THEN 8323 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8324 & ERRQUIT('ccsdt_t2_10_1',0,MA_ERR) 8325 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8326 &ccsdt_t2_10_1',1,MA_ERR) 8327 IF ((h1b .le. p5b)) THEN 8328 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 8329 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h7b_1 - 1 + (noab 8330 &+nvab) * (h6b_1 - 1))))) 8331 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1) 8332 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1) 8333 &,4,3,2,1,1.0d0) 8334 END IF 8335 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_10_1',2,MA_ERR) 8336 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8337 &ccsdt_t2_10_1',3,MA_ERR) 8338 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 8339 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1) 8340 &,4,3,2,1,1.0d0) 8341 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 8342 & noab - 1 + nvab * (h1b - 1 + noab * (h7b - 1 + noab * (h6b - 1))) 8343 &)) 8344 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_10_1',4,MA_ERR) 8345 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_10_1',5,MA 8346 &_ERR) 8347 END IF 8348 END IF 8349 END IF 8350 END IF 8351 END IF !active 8352 next = NXTASK(nprocs,1) 8353 END IF 8354 count = count + 1 8355 END DO 8356 END DO 8357 END DO 8358 END DO 8359 next = NXTASK(-nprocs,1) 8360 call GA_SYNC() 8361 RETURN 8362 END 8363 SUBROUTINE OFFSET_ccsdt_t2a_10_1(l_a_offset,k_a_offset,size) 8364C $Id$ 8365C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8366C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8367C i1 ( h6 h7 h1 p5 )_v 8368 IMPLICIT NONE 8369#include "global.fh" 8370#include "mafdecls.fh" 8371#include "sym.fh" 8372#include "errquit.fh" 8373#include "tce.fh" 8374 INTEGER l_a_offset 8375 INTEGER k_a_offset 8376 INTEGER size 8377 INTEGER length 8378 INTEGER addr 8379 INTEGER h6b 8380 INTEGER h7b 8381 INTEGER h1b 8382 INTEGER p5b 8383 LOGICAL ACOLO_1P_2H 8384 length = 0 8385 DO h6b = 1,noab 8386 DO h7b = h6b,noab 8387 DO h1b = 1,noab 8388 DO p5b = noab+1,noab+nvab 8389 IF(acolo_1p_2h(p5b,h6b,h7b)) THEN 8390 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 8391 &1b-1)+int_mb(k_spin+p5b-1)) THEN 8392 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 8393 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 8394 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1 8395 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 8396 length = length + 1 8397 END IF 8398 END IF 8399 END IF 8400 END IF !active 8401 END DO 8402 END DO 8403 END DO 8404 END DO 8405 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 8406 &set)) CALL ERRQUIT('ccsdt_t2_10_1',0,MA_ERR) 8407 int_mb(k_a_offset) = length 8408 addr = 0 8409 size = 0 8410 DO h6b = 1,noab 8411 DO h7b = h6b,noab 8412 DO h1b = 1,noab 8413 DO p5b = noab+1,noab+nvab 8414 IF(acolo_1p_2h(p5b,h6b,h7b)) THEN 8415 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 8416 &1b-1)+int_mb(k_spin+p5b-1)) THEN 8417 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 8418 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 8419 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1 8420 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 8421 addr = addr + 1 8422 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 8423 &* (h7b - 1 + noab * (h6b - 1))) 8424 int_mb(k_a_offset+length+addr) = size 8425 size = size + int_mb(k_range+h6b-1) * int_mb(k_range+h7b-1) * int_ 8426 &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 8427 END IF 8428 END IF 8429 END IF 8430 END IF !active 8431 END DO 8432 END DO 8433 END DO 8434 END DO 8435 RETURN 8436 END 8437 SUBROUTINE ccsdt_t2a_10_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 8438 &k_c_offset) 8439C $Id$ 8440C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8441C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8442C i1 ( h6 h7 h1 p5 )_vt + = -1 * Sum ( p8 ) * t ( p8 h1 )_t * v ( h6 h7 p5 p8 )_v 8443 IMPLICIT NONE 8444#include "global.fh" 8445#include "mafdecls.fh" 8446#include "sym.fh" 8447#include "errquit.fh" 8448#include "tce.fh" 8449 INTEGER d_a 8450 INTEGER k_a_offset 8451 INTEGER d_b 8452 INTEGER k_b_offset 8453 INTEGER d_c 8454 INTEGER k_c_offset 8455 INTEGER NXTASK 8456 INTEGER next 8457 INTEGER nprocs 8458 INTEGER count 8459 INTEGER h6b 8460 INTEGER h7b 8461 INTEGER h1b 8462 INTEGER p5b 8463 INTEGER dimc 8464 INTEGER l_c_sort 8465 INTEGER k_c_sort 8466 INTEGER p8b 8467 INTEGER p8b_1 8468 INTEGER h1b_1 8469 INTEGER h6b_2 8470 INTEGER h7b_2 8471 INTEGER p5b_2 8472 INTEGER p8b_2 8473 INTEGER dim_common 8474 INTEGER dima_sort 8475 INTEGER dima 8476 INTEGER dimb_sort 8477 INTEGER dimb 8478 INTEGER l_a_sort 8479 INTEGER k_a_sort 8480 INTEGER l_a 8481 INTEGER k_a 8482 INTEGER l_b_sort 8483 INTEGER k_b_sort 8484 INTEGER l_b 8485 INTEGER k_b 8486 INTEGER l_c 8487 INTEGER k_c 8488 LOGICAL ACOLO_1P_2H 8489 EXTERNAL NXTASK 8490 nprocs = GA_NNODES() 8491 count = 0 8492 next = NXTASK(nprocs,1) 8493 DO h6b = 1,noab 8494 DO h7b = h6b,noab 8495 DO h1b = 1,noab 8496 DO p5b = noab+1,noab+nvab 8497 IF (next.eq.count) THEN 8498 IF(acolo_1p_2h(p5b,h6b,h7b)) THEN 8499 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1 8500 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 8501 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 8502 &1b-1)+int_mb(k_spin+p5b-1)) THEN 8503 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 8504 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 8505 &EN 8506 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra 8507 &nge+h1b-1) * int_mb(k_range+p5b-1) 8508 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8509 & ERRQUIT('ccsdt_t2_10_2',0,MA_ERR) 8510 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8511 DO p8b = noab+1,noab+nvab 8512 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 8513 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 8514 &EN 8515 CALL TCE_RESTRICTED_2(p8b,h1b,p8b_1,h1b_1) 8516 CALL TCE_RESTRICTED_4(h6b,h7b,p5b,p8b,h6b_2,h7b_2,p5b_2,p8b_2) 8517 dim_common = int_mb(k_range+p8b-1) 8518 dima_sort = int_mb(k_range+h1b-1) 8519 dima = dim_common * dima_sort 8520 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h7b-1) * int_mb 8521 &(k_range+p5b-1) 8522 dimb = dim_common * dimb_sort 8523 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8524 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8525 & ERRQUIT('ccsdt_t2_10_2',1,MA_ERR) 8526 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8527 &ccsdt_t2_10_2',2,MA_ERR) 8528 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 8529 & - 1 + noab * (p8b_1 - noab - 1))) 8530 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 8531 &,int_mb(k_range+h1b-1),2,1,1.0d0) 8532 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_10_2',3,MA_ERR) 8533 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8534 & ERRQUIT('ccsdt_t2_10_2',4,MA_ERR) 8535 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8536 &ccsdt_t2_10_2',5,MA_ERR) 8537 IF ((p8b .lt. p5b)) THEN 8538 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 8539 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 8540 &+nvab) * (h6b_2 - 1))))) 8541 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 8542 &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1) 8543 &,4,2,1,3,-1.0d0) 8544 END IF 8545 IF ((p5b .le. p8b)) THEN 8546 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 8547 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 8548 &+nvab) * (h6b_2 - 1))))) 8549 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 8550 &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1) 8551 &,3,2,1,4,1.0d0) 8552 END IF 8553 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_10_2',6,MA_ERR) 8554 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 8555 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 8556 &t),dima_sort) 8557 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_10_2',7,MA 8558 &_ERR) 8559 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_10_2',8,MA 8560 &_ERR) 8561 END IF 8562 END IF 8563 END IF 8564 END DO 8565 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8566 &ccsdt_t2_10_2',9,MA_ERR) 8567 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 8568 &,int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 8569 &,3,2,4,1,-1.0d0) 8570 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 8571 & noab - 1 + nvab * (h1b - 1 + noab * (h7b - 1 + noab * (h6b - 1))) 8572 &)) 8573 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_10_2',10,MA_ERR 8574 &) 8575 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_10_2',11,M 8576 &A_ERR) 8577 END IF 8578 END IF 8579 END IF 8580 END IF !active 8581 next = NXTASK(nprocs,1) 8582 END IF 8583 count = count + 1 8584 END DO 8585 END DO 8586 END DO 8587 END DO 8588 next = NXTASK(-nprocs,1) 8589 call GA_SYNC() 8590 RETURN 8591 END 8592 SUBROUTINE ccsdt_t2a_11(d_a,k_a_offset,d_b,k_b_offset,d_c, 8593 &k_c_offset) 8594C $Id$ 8595C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8596C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8597C i0 ( p3 p4 h1 h2 )_vt + = -1/2 * P( 2 ) * Sum ( h7 p5 p6 ) * t ( p3 p5 p6 h1 h2 h7 )_t * v ( h7 p4 p5 p6 )_v 8598 IMPLICIT NONE 8599#include "global.fh" 8600#include "mafdecls.fh" 8601#include "sym.fh" 8602#include "errquit.fh" 8603#include "tce.fh" 8604 INTEGER d_a 8605 INTEGER k_a_offset 8606 INTEGER d_b 8607 INTEGER k_b_offset 8608 INTEGER d_c 8609 INTEGER k_c_offset 8610 INTEGER NXTASK 8611 INTEGER next 8612 INTEGER nprocs 8613 INTEGER count 8614 INTEGER p3b 8615 INTEGER p4b 8616 INTEGER h1b 8617 INTEGER h2b 8618 INTEGER dimc 8619 INTEGER l_c_sort 8620 INTEGER k_c_sort 8621 INTEGER p5b 8622 INTEGER p6b 8623 INTEGER h7b 8624 INTEGER p3b_1 8625 INTEGER p5b_1 8626 INTEGER p6b_1 8627 INTEGER h1b_1 8628 INTEGER h2b_1 8629 INTEGER h7b_1 8630 INTEGER p4b_2 8631 INTEGER h7b_2 8632 INTEGER p5b_2 8633 INTEGER p6b_2 8634 INTEGER dim_common 8635 INTEGER dima_sort 8636 INTEGER dima 8637 INTEGER dimb_sort 8638 INTEGER dimb 8639 INTEGER l_a_sort 8640 INTEGER k_a_sort 8641 INTEGER l_a 8642 INTEGER k_a 8643 INTEGER l_b_sort 8644 INTEGER k_b_sort 8645 INTEGER l_b 8646 INTEGER k_b 8647 INTEGER nsuperp(2) 8648 INTEGER isuperp 8649 INTEGER l_c 8650 INTEGER k_c 8651 LOGICAL ACOLO 8652 DOUBLE PRECISION FACTORIAL 8653 EXTERNAL NXTASK 8654 EXTERNAL FACTORIAL 8655 nprocs = GA_NNODES() 8656 count = 0 8657 next = NXTASK(nprocs,1) 8658 DO p3b = noab+1,noab+nvab 8659 DO p4b = noab+1,noab+nvab 8660 DO h1b = 1,noab 8661 DO h2b = h1b,noab 8662 IF (next.eq.count) THEN 8663 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 8664 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 8665 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 8666 &1b-1)+int_mb(k_spin+h2b-1)) THEN 8667 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 8668 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 8669 &EN 8670 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 8671 &nge+h1b-1) * int_mb(k_range+h2b-1) 8672 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8673 & ERRQUIT('ccsdt_t2_11',0,MA_ERR) 8674 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8675 DO p5b = noab+1,noab+nvab 8676 DO p6b = p5b,noab+nvab 8677 DO h7b = 1,noab 8678 IF(acolo(p3b,p5b,p6b,h1b,h2b,h7b)) THEN 8679 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 8680 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b- 8681 &1)) THEN 8682 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 8683 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 8684 &_mb(k_sym+h7b-1)))))) .eq. irrep_t) THEN 8685 CALL TCE_RESTRICTED_6(p3b,p5b,p6b,h1b,h2b,h7b,p3b_1,p5b_1,p6b_1,h1 8686 &b_1,h2b_1,h7b_1) 8687 CALL TCE_RESTRICTED_4(p4b,h7b,p5b,p6b,p4b_2,h7b_2,p5b_2,p6b_2) 8688 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_m 8689 &b(k_range+h7b-1) 8690 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb 8691 &(k_range+h2b-1) 8692 dima = dim_common * dima_sort 8693 dimb_sort = int_mb(k_range+p4b-1) 8694 dimb = dim_common * dimb_sort 8695 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8696 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8697 & ERRQUIT('ccsdt_t2_11',1,MA_ERR) 8698 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8699 &ccsdt_t2_11',2,MA_ERR) 8700 IF ((p6b .lt. p3b) .and. (h7b .lt. h1b)) THEN 8701 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 8702 & - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noa 8703 &b - 1 + nvab * (p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 8704 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8705 &,int_mb(k_range+p6b-1),int_mb(k_range+p3b-1),int_mb(k_range+h7b-1) 8706 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,3,4,2,1,1.0d0) 8707 END IF 8708 IF ((p6b .lt. p3b) .and. (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 8709 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 8710 & - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noa 8711 &b - 1 + nvab * (p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 8712 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8713 &,int_mb(k_range+p6b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 8714 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),6,4,3,5,2,1,-1.0d0) 8715 END IF 8716 IF ((p6b .lt. p3b) .and. (h2b .le. h7b)) THEN 8717 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8718 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noa 8719 &b - 1 + nvab * (p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 8720 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8721 &,int_mb(k_range+p6b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 8722 &,int_mb(k_range+h2b-1),int_mb(k_range+h7b-1),5,4,3,6,2,1,1.0d0) 8723 END IF 8724 IF ((p5b .lt. p3b) .and. (p3b .le. p6b) .and. (h7b .lt. h1b)) THEN 8725 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 8726 & - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + noab * (p6b_1 - noa 8727 &b - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 8728 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8729 &,int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+h7b-1) 8730 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,2,4,3,1,-1.0d0) 8731 END IF 8732 IF ((p5b .lt. p3b) .and. (p3b .le. p6b) .and. (h1b .le. h7b) .and. 8733 & (h7b .lt. h2b)) THEN 8734 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 8735 & - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noa 8736 &b - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 8737 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8738 &,int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 8739 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),6,4,2,5,3,1,1.0d0) 8740 END IF 8741 IF ((p5b .lt. p3b) .and. (p3b .le. p6b) .and. (h2b .le. h7b)) THEN 8742 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8743 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noa 8744 &b - 1 + nvab * (p3b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))) 8745 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8746 &,int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 8747 &,int_mb(k_range+h2b-1),int_mb(k_range+h7b-1),5,4,2,6,3,1,-1.0d0) 8748 END IF 8749 IF ((p3b .le. p5b) .and. (h7b .lt. h1b)) THEN 8750 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 8751 & - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + noab * (p6b_1 - noa 8752 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 8753 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8754 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h7b-1) 8755 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),6,5,1,4,3,2,1.0d0) 8756 END IF 8757 IF ((p3b .le. p5b) .and. (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 8758 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 8759 & - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noa 8760 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 8761 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8762 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 8763 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),6,4,1,5,3,2,-1.0d0) 8764 END IF 8765 IF ((p3b .le. p5b) .and. (h2b .le. h7b)) THEN 8766 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8767 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noa 8768 &b - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))) 8769 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8770 &,int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+h1b-1) 8771 &,int_mb(k_range+h2b-1),int_mb(k_range+h7b-1),5,4,1,6,3,2,1.0d0) 8772 END IF 8773 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t2_11',3,MA_ERR) 8774 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8775 & ERRQUIT('ccsdt_t2_11',4,MA_ERR) 8776 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8777 &ccsdt_t2_11',5,MA_ERR) 8778 IF ((h7b .le. p4b)) THEN 8779 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 8780 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab 8781 &+nvab) * (h7b_2 - 1))))) 8782 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 8783 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 8784 &,2,1,4,3,1.0d0) 8785 END IF 8786 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_t2_11',6,MA_ERR) 8787 nsuperp(1) = 1 8788 nsuperp(2) = 1 8789 isuperp = 1 8790 IF (p5b .eq. p6b) THEN 8791 nsuperp(isuperp) = nsuperp(isuperp) + 1 8792 ELSE 8793 isuperp = isuperp + 1 8794 END IF 8795 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 8796 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 8797 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 8798 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_t2_11',7,MA_E 8799 &RR) 8800 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t2_11',8,MA_E 8801 &RR) 8802 END IF 8803 END IF 8804 END IF 8805 END IF !active 8806 END DO 8807 END DO 8808 END DO 8809 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8810 &ccsdt_t2_11',9,MA_ERR) 8811 IF ((p3b .le. p4b)) THEN 8812 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 8813 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8814 &,4,1,3,2,-1.0d0/2.0d0) 8815 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 8816 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 8817 & - 1))))) 8818 END IF 8819 IF ((p4b .le. p3b)) THEN 8820 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 8821 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8822 &,1,4,3,2,1.0d0/2.0d0) 8823 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 8824 & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 8825 & - 1))))) 8826 END IF 8827 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t2_11',10,MA_ERR) 8828 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_t2_11',11,MA_ 8829 &ERR) 8830 END IF 8831 END IF 8832 END IF 8833 next = NXTASK(nprocs,1) 8834 END IF 8835 count = count + 1 8836 END DO 8837 END DO 8838 END DO 8839 END DO 8840 next = NXTASK(-nprocs,1) 8841 call GA_SYNC() 8842 RETURN 8843 END 8844