1ckbn Kiran Bhaskaran-Nair EOM-IPCCSD X2 equations 2 SUBROUTINE ipccsd_x2(d_f1,d_i0,d_t1,d_t2,d_v2,d_x1,d_x2,k_f1_offse 3 &t,k_i0_offset,k_t1_offset,k_t2_offset,k_v2_offset,k_x1_offset,k_x2 4 &_offset) 5C $Id$ 6C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8ckbn p3 9C i0 ( p3 p4 h1 h2 )_xv + = -1 * P( 2 ) * Sum ( h9 ) * x ( p3 h9 )_x * i1 ( h9 p4 h1 h2 )_v 10C i1 ( h9 p3 h1 h2 )_v + = 1 * v ( h9 p3 h1 h2 )_v 11C i1 ( h9 p3 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h9 p3 h2 p5 )_v 12C i2 ( h9 p3 h1 p5 )_v + = 1 * v ( h9 p3 h1 p5 )_v 13C i2 ( h9 p3 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 p3 p5 p6 )_v 14C i1 ( h9 p3 h1 h2 )_ft + = -1 * Sum ( p8 ) * t ( p3 p8 h1 h2 )_t * i2 ( h9 p8 )_f 15C i2 ( h9 p8 )_f + = 1 * f ( h9 p8 )_f 16C i2 ( h9 p8 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 p6 p8 )_v 17C i1 ( h9 p3 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i2 ( h6 h9 h2 p5 )_v 18C i2 ( h6 h9 h1 p5 )_v + = 1 * v ( h6 h9 h1 p5 )_v 19C i2 ( h6 h9 h1 p5 )_vt + = -1 * Sum ( p7 ) * t ( p7 h1 )_t * v ( h6 h9 p5 p7 )_v 20C i1 ( h9 p3 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 p3 p5 p6 )_v 21ckbn p4 22C i0 ( p3 p4 h1 h2 )_xf + = -1 * P( 2 ) * Sum ( h8 ) * x ( p3 p4 h1 h8 )_x * i1 ( h8 h2 )_f 23C i1 ( h8 h1 )_f + = 1 * f ( h8 h1 )_f 24C i1 ( h8 h1 )_ft + = 1 * Sum ( p9 ) * t ( p9 h1 )_t * i2 ( h8 p9 )_f 25C i2 ( h8 p9 )_f + = 1 * f ( h8 p9 )_f 26C i2 ( h8 p9 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h8 p6 p9 )_v 27C i1 ( h8 h1 )_vt + = -1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 h8 h1 p5 )_v 28C i1 ( h8 h1 )_vt + = -1/2 * Sum ( h7 p5 p6 ) * t ( p5 p6 h1 h7 )_t * v ( h7 h8 p5 p6 )_v 29ckbn p3 30C i0 ( p3 p4 h1 h2 )_xf + = 1 * P( 2 ) * Sum ( p8 ) * x ( p3 p8 h1 h2 )_x * i1 ( p4 p8 )_f 31C i1 ( p3 p8 )_f + = 1 * f ( p3 p8 )_f 32C i1 ( p3 p8 )_vt + = 1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 p3 p5 p8 )_v 33C i1 ( p3 p8 )_vt + = 1/2 * Sum ( h6 h7 p5 ) * t ( p3 p5 h6 h7 )_t * v ( h6 h7 p5 p8 )_v 34ckbn p4 35C i0 ( p3 p4 h1 h2 )_xv + = 1/2 * Sum ( h9 h10 ) * x ( p3 p4 h9 h10 )_x * i1 ( h9 h10 h1 h2 )_v 36C i1 ( h9 h10 h1 h2 )_v + = 1 * v ( h9 h10 h1 h2 )_v 37C i1 ( h9 h10 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h9 h10 h2 p5 )_v 38C i2 ( h9 h10 h1 p5 )_v + = 1 * v ( h9 h10 h1 p5 )_v 39C i2 ( h9 h10 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 h10 p5 p6 )_v 40C i1 ( h9 h10 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 h10 p5 p6 )_v 41ckbn p3 42C i0 ( p3 p4 h1 h2 )_xv + = -1 * P( 4 ) * Sum ( p8 h7 ) * x ( p3 p8 h1 h7 )_x * i1 ( h7 p4 h2 p8 )_v 43C i1 ( h7 p3 h1 p8 )_v + = 1 * v ( h7 p3 h1 p8 )_v 44C i1 ( h7 p3 h1 p8 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h7 p3 p5 p8 )_v 45ckbn p4 46C i0 ( p3 p4 h1 h2 )_vxt + = 1 * P( 2 ) * Sum ( h10 ) * t ( p3 h10 )_t * i1 ( h10 p4 h1 h2 )_vx 47ckbn p3 48C i1 ( h10 p3 h1 h2 )_vx + = -1 * Sum ( h8 ) * x ( p3 h8 )_x * i2 ( h8 h10 h1 h2 )_v 49C i2 ( h8 h10 h1 h2 )_v + = 1 * v ( h8 h10 h1 h2 )_v 50C i2 ( h8 h10 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i3 ( h8 h10 h2 p5 )_v 51C i3 ( h8 h10 h1 p5 )_v + = 1 * v ( h8 h10 h1 p5 )_v 52C i3 ( h8 h10 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h8 h10 p5 p6 )_v 53C i2 ( h8 h10 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h8 h10 p5 p6 )_v 54ckbn p3 55C i1 ( h10 p3 h1 h2 )_fx + = 1 * Sum ( p5 ) * x ( p3 p5 h1 h2 )_x * i2 ( h10 p5 )_f 56C i2 ( h10 p5 )_f + = 1 * f ( h10 p5 )_f 57C i2 ( h10 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h10 p5 p6 )_v 58ckbn p3 59C i1 ( h10 p3 h1 h2 )_vx + = -1 * P( 2 ) * Sum ( h8 p9 ) * x ( p3 p9 h1 h8 )_x * i2 ( h8 h10 h2 p9 )_v 60C i2 ( h8 h10 h1 p9 )_v + = 1 * v ( h8 h10 h1 p9 )_v 61C i2 ( h8 h10 h1 p9 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h8 h10 p5 p9 )_v 62ckbn p4 m 63C i0 ( p3 p4 h1 h2 )_vxt + = 1/2 * P( 2 ) * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i1 ( p4 p5 )_vx 64ckbn p3 m 65C i1 ( p3 p5 )_vx + = -1 * Sum ( h6 h7 p8 ) * x ( p3 p8 h6 h7 )_x * v ( h6 h7 p5 p8 )_v 66ckbn p4 67C i0 ( p3 p4 h1 h2 )_vxt + = 1 * P( 4 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i1 ( h6 p4 h2 p5 )_vx 68ckbn p3 69C i1 ( h6 p3 h1 p5 )_vx + = 1 * Sum ( h7 p8 ) * x ( p3 p8 h1 h7 )_x * v ( h6 h7 p5 p8 )_v 70 IMPLICIT NONE 71#include "global.fh" 72#include "mafdecls.fh" 73#include "util.fh" 74#include "errquit.fh" 75#include "tce.fh" 76#include "stdio.fh" 77 INTEGER d_i0 78 INTEGER k_i0_offset 79 INTEGER d_x1 80 INTEGER k_x1_offset 81 INTEGER d_i1 82 INTEGER k_i1_offset 83 INTEGER d_x2 84 INTEGER k_x2_offset 85 INTEGER d_t1 86 INTEGER k_t1_offset 87 INTEGER d_t2 88 INTEGER k_t2_offset 89 INTEGER l_i1_offset 90 INTEGER d_v2 91 INTEGER k_v2_offset 92 INTEGER size_i1 93 INTEGER d_i2 94 INTEGER k_i2_offset 95 INTEGER l_i2_offset 96 INTEGER size_i2 97 INTEGER d_f1 98 INTEGER k_f1_offset 99 INTEGER d_i3 100 INTEGER k_i3_offset 101 INTEGER l_i3_offset 102 INTEGER size_i3 103 CHARACTER*255 filename 104 CALL OFFSET_ipccsd_x2_1_1(l_i1_offset,k_i1_offset,size_i1) 105 CALL TCE_FILENAME('ipccsd_x2_1_1_i1',filename) 106 CALL CREATEFILE(filename,d_i1,size_i1) 107 CALL ipccsd_x2_1_1(d_v2,k_v2_offset,d_i1,k_i1_offset) 108 CALL OFFSET_ipccsd_x2_1_2_1(l_i2_offset,k_i2_offset,size_i2) 109 CALL TCE_FILENAME('ipccsd_x2_1_2_1_i2',filename) 110 CALL CREATEFILE(filename,d_i2,size_i2) 111 CALL ipccsd_x2_1_2_1(d_v2,k_v2_offset,d_i2,k_i2_offset) 112 CALL ipccsd_x2_1_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o 113 &ffset) 114 CALL RECONCILEFILE(d_i2,size_i2) 115 CALL ipccsd_x2_1_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k_i1_off 116 &set) 117 CALL DELETEFILE(d_i2) 118 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 119 &_ERR) 120 CALL OFFSET_ipccsd_x2_1_3_1(l_i2_offset,k_i2_offset,size_i2) 121 CALL TCE_FILENAME('ipccsd_x2_1_3_1_i2',filename) 122 CALL CREATEFILE(filename,d_i2,size_i2) 123 CALL ipccsd_x2_1_3_1(d_f1,k_f1_offset,d_i2,k_i2_offset) 124 CALL ipccsd_x2_1_3_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o 125 &ffset) 126 CALL RECONCILEFILE(d_i2,size_i2) 127 CALL ipccsd_x2_1_3(d_t2,k_t2_offset,d_i2,k_i2_offset,d_i1,k_i1_off 128 &set) 129 CALL DELETEFILE(d_i2) 130 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 131 &_ERR) 132 CALL OFFSET_ipccsd_x2_1_4_1(l_i2_offset,k_i2_offset,size_i2) 133 CALL TCE_FILENAME('ipccsd_x2_1_4_1_i2',filename) 134 CALL CREATEFILE(filename,d_i2,size_i2) 135 CALL ipccsd_x2_1_4_1(d_v2,k_v2_offset,d_i2,k_i2_offset) 136 CALL ipccsd_x2_1_4_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o 137 &ffset) 138 CALL RECONCILEFILE(d_i2,size_i2) 139 CALL ipccsd_x2_1_4(d_t2,k_t2_offset,d_i2,k_i2_offset,d_i1,k_i1_off 140 &set) 141 CALL DELETEFILE(d_i2) 142 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 143 &_ERR) 144 CALL ipccsd_x2_1_5(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1,k_i1_off 145 &set) 146 CALL RECONCILEFILE(d_i1,size_i1) 147 CALL ipccsd_x2_1(d_x1,k_x1_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 148 &t) 149 CALL DELETEFILE(d_i1) 150 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 151 &_ERR) 152 CALL OFFSET_ipccsd_x2_2_1(l_i1_offset,k_i1_offset,size_i1) 153 CALL TCE_FILENAME('ipccsd_x2_2_1_i1',filename) 154 CALL CREATEFILE(filename,d_i1,size_i1) 155 CALL ipccsd_x2_2_1(d_f1,k_f1_offset,d_i1,k_i1_offset) 156 CALL OFFSET_ipccsd_x2_2_2_1(l_i2_offset,k_i2_offset,size_i2) 157 CALL TCE_FILENAME('ipccsd_x2_2_2_1_i2',filename) 158 CALL CREATEFILE(filename,d_i2,size_i2) 159 CALL ipccsd_x2_2_2_1(d_f1,k_f1_offset,d_i2,k_i2_offset) 160 CALL ipccsd_x2_2_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o 161 &ffset) 162 CALL RECONCILEFILE(d_i2,size_i2) 163 CALL ipccsd_x2_2_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k_i1_off 164 &set) 165 CALL DELETEFILE(d_i2) 166 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 167 &_ERR) 168 CALL ipccsd_x2_2_3(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_off 169 &set) 170 CALL ipccsd_x2_2_4(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1,k_i1_off 171 &set) 172 CALL RECONCILEFILE(d_i1,size_i1) 173 CALL ipccsd_x2_2(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 174 &t) 175 CALL DELETEFILE(d_i1) 176 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 177 &_ERR) 178 CALL OFFSET_ipccsd_x2_3_1(l_i1_offset,k_i1_offset,size_i1) 179 CALL TCE_FILENAME('ipccsd_x2_3_1_i1',filename) 180 CALL CREATEFILE(filename,d_i1,size_i1) 181 CALL ipccsd_x2_3_1(d_f1,k_f1_offset,d_i1,k_i1_offset) 182 CALL ipccsd_x2_3_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_off 183 &set) 184 CALL ipccsd_x2_3_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1,k_i1_off 185 &set) 186 CALL RECONCILEFILE(d_i1,size_i1) 187 CALL ipccsd_x2_3(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 188 &t) 189 CALL DELETEFILE(d_i1) 190 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 191 &_ERR) 192 CALL OFFSET_ipccsd_x2_4_1(l_i1_offset,k_i1_offset,size_i1) 193 CALL TCE_FILENAME('ipccsd_x2_4_1_i1',filename) 194 CALL CREATEFILE(filename,d_i1,size_i1) 195 CALL ipccsd_x2_4_1(d_v2,k_v2_offset,d_i1,k_i1_offset) 196 CALL OFFSET_ipccsd_x2_4_2_1(l_i2_offset,k_i2_offset,size_i2) 197 CALL TCE_FILENAME('ipccsd_x2_4_2_1_i2',filename) 198 CALL CREATEFILE(filename,d_i2,size_i2) 199 CALL ipccsd_x2_4_2_1(d_v2,k_v2_offset,d_i2,k_i2_offset) 200 CALL ipccsd_x2_4_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o 201 &ffset) 202 CALL RECONCILEFILE(d_i2,size_i2) 203 CALL ipccsd_x2_4_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k_i1_off 204 &set) 205 CALL DELETEFILE(d_i2) 206 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 207 &_ERR) 208 CALL ipccsd_x2_4_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1,k_i1_off 209 &set) 210 CALL RECONCILEFILE(d_i1,size_i1) 211 CALL ipccsd_x2_4(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 212 &t) 213 CALL DELETEFILE(d_i1) 214 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 215 &_ERR) 216 CALL OFFSET_ipccsd_x2_5_1(l_i1_offset,k_i1_offset,size_i1) 217 CALL TCE_FILENAME('ipccsd_x2_5_1_i1',filename) 218 CALL CREATEFILE(filename,d_i1,size_i1) 219 CALL ipccsd_x2_5_1(d_v2,k_v2_offset,d_i1,k_i1_offset) 220 CALL ipccsd_x2_5_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_off 221 &set) 222 CALL RECONCILEFILE(d_i1,size_i1) 223 CALL ipccsd_x2_5(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 224 &t) 225 CALL DELETEFILE(d_i1) 226 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 227 &_ERR) 228 CALL OFFSET_ipccsd_x2_6_1(l_i1_offset,k_i1_offset,size_i1) 229 CALL TCE_FILENAME('ipccsd_x2_6_1_i1',filename) 230 CALL CREATEFILE(filename,d_i1,size_i1) 231 CALL OFFSET_ipccsd_x2_6_1_1(l_i2_offset,k_i2_offset,size_i2) 232 CALL TCE_FILENAME('ipccsd_x2_6_1_1_i2',filename) 233 CALL CREATEFILE(filename,d_i2,size_i2) 234 CALL ipccsd_x2_6_1_1(d_v2,k_v2_offset,d_i2,k_i2_offset) 235 CALL OFFSET_ipccsd_x2_6_1_2_1(l_i3_offset,k_i3_offset,size_i3) 236 CALL TCE_FILENAME('ipccsd_x2_6_1_2_1_i3',filename) 237 CALL CREATEFILE(filename,d_i3,size_i3) 238 CALL ipccsd_x2_6_1_2_1(d_v2,k_v2_offset,d_i3,k_i3_offset) 239 CALL ipccsd_x2_6_1_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i3,k_i3 240 &_offset) 241 CALL RECONCILEFILE(d_i3,size_i3) 242 CALL ipccsd_x2_6_1_2(d_t1,k_t1_offset,d_i3,k_i3_offset,d_i2,k_i2_o 243 &ffset) 244 CALL DELETEFILE(d_i3) 245 IF (.not.MA_POP_STACK(l_i3_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 246 &_ERR) 247 CALL ipccsd_x2_6_1_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i2,k_i2_o 248 &ffset) 249c write(LuOut,*) "I am here 1" 250c call util_flush(LuOut) 251 CALL RECONCILEFILE(d_i2,size_i2) 252 CALL ipccsd_x2_6_1(d_x1,k_x1_offset,d_i2,k_i2_offset,d_i1,k_i1_off 253 &set) 254c write(LuOut,*) "I am here 2" 255c call util_flush(LuOut) 256 CALL DELETEFILE(d_i2) 257 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 258 &_ERR) 259 CALL OFFSET_ipccsd_x2_6_2_1(l_i2_offset,k_i2_offset,size_i2) 260 CALL TCE_FILENAME('ipccsd_x2_6_2_1_i2',filename) 261 CALL CREATEFILE(filename,d_i2,size_i2) 262 CALL ipccsd_x2_6_2_1(d_f1,k_f1_offset,d_i2,k_i2_offset) 263c write(LuOut,*) "I am here 3" 264c call util_flush(LuOut) 265 CALL ipccsd_x2_6_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o 266 &ffset) 267c write(LuOut,*) "I am here 4" 268c call util_flush(LuOut) 269 CALL RECONCILEFILE(d_i2,size_i2) 270 CALL ipccsd_x2_6_2(d_x2,k_x2_offset,d_i2,k_i2_offset,d_i1,k_i1_off 271 &set) 272 CALL DELETEFILE(d_i2) 273 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 274 &_ERR) 275 CALL OFFSET_ipccsd_x2_6_3_1(l_i2_offset,k_i2_offset,size_i2) 276 CALL TCE_FILENAME('ipccsd_x2_6_3_1_i2',filename) 277 CALL CREATEFILE(filename,d_i2,size_i2) 278 CALL ipccsd_x2_6_3_1(d_v2,k_v2_offset,d_i2,k_i2_offset) 279 CALL ipccsd_x2_6_3_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o 280 &ffset) 281 CALL RECONCILEFILE(d_i2,size_i2) 282 CALL ipccsd_x2_6_3(d_x2,k_x2_offset,d_i2,k_i2_offset,d_i1,k_i1_off 283 &set) 284 CALL DELETEFILE(d_i2) 285 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 286 &_ERR) 287 CALL RECONCILEFILE(d_i1,size_i1) 288 CALL ipccsd_x2_6(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 289 &t) 290 CALL DELETEFILE(d_i1) 291 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 292 &_ERR) 293 CALL OFFSET_ipccsd_x2_7_1(l_i1_offset,k_i1_offset,size_i1) 294 CALL TCE_FILENAME('ipccsd_x2_7_1_i1',filename) 295 CALL CREATEFILE(filename,d_i1,size_i1) 296 CALL ipccsd_x2_7_1(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i1,k_i1_off 297 &set) 298 CALL RECONCILEFILE(d_i1,size_i1) 299 CALL ipccsd_x2_7(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 300 &t) 301 CALL DELETEFILE(d_i1) 302 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 303 &_ERR) 304 CALL OFFSET_ipccsd_x2_8_1(l_i1_offset,k_i1_offset,size_i1) 305 CALL TCE_FILENAME('ipccsd_x2_8_1_i1',filename) 306 CALL CREATEFILE(filename,d_i1,size_i1) 307 CALL ipccsd_x2_8_1(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i1,k_i1_off 308 &set) 309 CALL RECONCILEFILE(d_i1,size_i1) 310 CALL ipccsd_x2_8(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse 311 &t) 312 CALL DELETEFILE(d_i1) 313 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA 314 &_ERR) 315 RETURN 316 END 317 SUBROUTINE ipccsd_x2_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 318 &t) 319C $Id$ 320C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 321C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 322C i0 ( p3 p4 h1 h2 )_xv + = -1 * P( 2 ) * Sum ( h9 ) * x ( p3 h9 )_x * i1 ( h9 p4 h1 h2 )_v 323 IMPLICIT NONE 324#include "global.fh" 325#include "mafdecls.fh" 326#include "sym.fh" 327#include "errquit.fh" 328#include "tce.fh" 329#include "stdio.fh" 330 INTEGER d_a 331 INTEGER k_a_offset 332 INTEGER d_b 333 INTEGER k_b_offset 334 INTEGER d_c 335 INTEGER k_c_offset 336 INTEGER NXTASK 337 INTEGER next 338 INTEGER nprocs 339 INTEGER count 340 INTEGER p3b 341 INTEGER p4b 342 INTEGER h1b 343 INTEGER h2b 344 INTEGER dimc 345 INTEGER l_c_sort 346 INTEGER k_c_sort 347 INTEGER h9b 348 INTEGER p3b_1 349 INTEGER h9b_1 350 INTEGER p4b_2 351 INTEGER h9b_2 352 INTEGER h1b_2 353 INTEGER h2b_2 354 INTEGER dim_common 355 INTEGER dima_sort 356 INTEGER dima 357 INTEGER dimb_sort 358 INTEGER dimb 359 INTEGER l_a_sort 360 INTEGER k_a_sort 361 INTEGER l_a 362 INTEGER k_a 363 INTEGER l_b_sort 364 INTEGER k_b_sort 365 INTEGER l_b 366 INTEGER k_b 367 INTEGER l_c 368 INTEGER k_c 369 EXTERNAL NXTASK 370 nprocs = GA_NNODES() 371 count = 0 372 next = NXTASK(nprocs, 1) 373ckbn DO p3b = noab+1,noab+nvab 374 DO p3b = 1,1 375 DO p4b = noab+1,noab+nvab 376 DO h1b = 1,noab 377 DO h2b = h1b,noab 378 IF (next.eq.count) THEN 379ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 380ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 381 IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p4b-1 382 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 383ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 384ckbn &1b-1)+int_mb(k_spin+h2b-1)) THEN 385 IF (ip_unused_spin +int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 386 &1b-1)+int_mb(k_spin+h2b-1)) THEN 387ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 388ckbn &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH 389ckbn &EN 390 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 391 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH 392 &EN 393ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 394ckbn &nge+h1b-1) * int_mb(k_range+h2b-1) 395 dimc = 1 * int_mb(k_range+p4b-1) * int_mb(k_ra 396 &nge+h1b-1) * int_mb(k_range+h2b-1) 397 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 398 & ERRQUIT('ipccsd_x2_1',0,MA_ERR) 399 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 400 DO h9b = 1,noab 401ckbn IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h9b-1)) THEN 402 IF (ip_unused_spin .eq. int_mb(k_spin+h9b-1)) THEN 403ckbn IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h9b-1)) .eq. irrep_x) TH 404ckbn &EN 405 IF (ieor(ip_unused_sym ,int_mb(k_sym+h9b-1)) .eq. irrep_x) TH 406 &EN 407 CALL TCE_RESTRICTED_2(p3b,h9b,p3b_1,h9b_1) 408 CALL TCE_RESTRICTED_4(p4b,h9b,h1b,h2b,p4b_2,h9b_2,h1b_2,h2b_2) 409 dim_common = int_mb(k_range+h9b-1) 410ckbn dima_sort = int_mb(k_range+p3b-1) 411 dima_sort = 1 412 dima = dim_common * dima_sort 413 dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1) * int_mb 414 &(k_range+h2b-1) 415 dimb = dim_common * dimb_sort 416 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 417 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 418 & ERRQUIT('ipccsd_x2_1',1,MA_ERR) 419 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 420 &ipccsd_x2_1',2,MA_ERR) 421c write(LuOut,*) "I am here 1." 422c call util_flush(LuOut) 423 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h9b_1 424 & - 1 + noab * (p3b_1 - noab - 1))) 425ckbn CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 426ckbn &,int_mb(k_range+h9b-1),1,2,1.0d0) 427 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),1 428 &,int_mb(k_range+h9b-1),1,2,1.0d0) 429c write(LuOut,*) "I am here 2." 430c call util_flush(LuOut) 431 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1',3,MA_ERR) 432 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 433 & ERRQUIT('ipccsd_x2_1',4,MA_ERR) 434 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 435 &ipccsd_x2_1',5,MA_ERR) 436 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 437 & - 1 + noab * (h1b_2 - 1 + noab * (h9b_2 - 1 + noab * (p4b_2 - noa 438 &b - 1))))) 439 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 440 &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 441 &,4,3,1,2,1.0d0) 442 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1',6,MA_ERR) 443 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 444 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 445 &t),dima_sort) 446 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1',7,MA_E 447 &RR) 448 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1',8,MA_E 449 &RR) 450 END IF 451 END IF 452 END IF 453 END DO 454 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 455 &ipccsd_x2_1',9,MA_ERR) 456ckbn IF ((p3b .le. p4b)) THEN 457ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 458ckbn &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 459ckbn &,4,3,2,1,-1.0d0) 460c write(LuOut,*) "I am here 3." 461c call util_flush(LuOut) 462ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 463ckbn &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),1 464ckbn &,4,3,2,1,-1.0d0) 465ckbn CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 466ckbn & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 467ckbn & - 1))))) 468ckbn END IF 469ckbn IF ((p4b .le. p3b)) THEN 470ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 471ckbn &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 472ckbn &,3,4,2,1,1.0d0) 473 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 474 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),1 475 &,3,4,2,1,1.0d0) 476c write(LuOut,*) "I am here 3.1" 477c call util_flush(LuOut) 478 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 479 & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 480 & - 1))))) 481c write(LuOut,*) "I am here 4." 482c call util_flush(LuOut) 483ckbn END IF 484 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1',10,MA_ERR) 485 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1',11,MA_ 486 &ERR) 487 END IF 488 END IF 489 END IF 490 next = NXTASK(nprocs, 1) 491 END IF 492 count = count + 1 493 END DO 494 END DO 495 END DO 496 END DO 497 next = NXTASK(-nprocs, 1) 498 call GA_SYNC() 499 RETURN 500 END 501 SUBROUTINE ipccsd_x2_1_1(d_a,k_a_offset,d_c,k_c_offset) 502C $Id$ 503C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 504C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 505C i1 ( h9 p3 h1 h2 )_v + = 1 * v ( h9 p3 h1 h2 )_v 506 IMPLICIT NONE 507#include "global.fh" 508#include "mafdecls.fh" 509#include "sym.fh" 510#include "errquit.fh" 511#include "tce.fh" 512 INTEGER d_a 513 INTEGER k_a_offset 514 INTEGER d_c 515 INTEGER k_c_offset 516 INTEGER NXTASK 517 INTEGER next 518 INTEGER nprocs 519 INTEGER count 520 INTEGER p3b 521 INTEGER h9b 522 INTEGER h1b 523 INTEGER h2b 524 INTEGER dimc 525 INTEGER p3b_1 526 INTEGER h9b_1 527 INTEGER h1b_1 528 INTEGER h2b_1 529 INTEGER dim_common 530 INTEGER dima_sort 531 INTEGER dima 532 INTEGER l_a_sort 533 INTEGER k_a_sort 534 INTEGER l_a 535 INTEGER k_a 536 INTEGER l_c 537 INTEGER k_c 538 EXTERNAL NXTASK 539 nprocs = GA_NNODES() 540 count = 0 541 next = NXTASK(nprocs, 1) 542 DO p3b = noab+1,noab+nvab 543 DO h9b = 1,noab 544 DO h1b = 1,noab 545 DO h2b = h1b,noab 546 IF (next.eq.count) THEN 547 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1 548 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 549 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 550 &1b-1)+int_mb(k_spin+h2b-1)) THEN 551 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 552 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 553 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 554 &nge+h1b-1) * int_mb(k_range+h2b-1) 555 CALL TCE_RESTRICTED_4(p3b,h9b,h1b,h2b,p3b_1,h9b_1,h1b_1,h2b_1) 556 dim_common = 1 557 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb 558 &(k_range+h1b-1) * int_mb(k_range+h2b-1) 559 dima = dim_common * dima_sort 560 IF (dima .gt. 0) THEN 561 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 562 & ERRQUIT('ipccsd_x2_1_1',0,MA_ERR) 563 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 564 &ipccsd_x2_1_1',1,MA_ERR) 565 IF ((h9b .le. p3b)) THEN 566 if(.not.intorb) then 567 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 568 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab 569 &+nvab) * (h9b_1 - 1))))) 570 else 571 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset), 572 &(h2b_1 573 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab 574 &+nvab) * (h9b_1 - 1)))),h2b_1,h1b_1,p3b_1,h9b_1) 575 end if 576 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 577 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 578 &,4,3,1,2,1.0d0) 579 END IF 580 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_1',2,MA_ERR) 581 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 582 &ipccsd_x2_1_1',3,MA_ERR) 583 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 584 &,int_mb(k_range+h1b-1),int_mb(k_range+h9b-1),int_mb(k_range+p3b-1) 585 &,4,3,2,1,1.0d0) 586 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 587 & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1))) 588 &)) 589 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_1',4,MA_ERR) 590 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_1',5,MA 591 &_ERR) 592 END IF 593 END IF 594 END IF 595 END IF 596 next = NXTASK(nprocs, 1) 597 END IF 598 count = count + 1 599 END DO 600 END DO 601 END DO 602 END DO 603 next = NXTASK(-nprocs, 1) 604 call GA_SYNC() 605 RETURN 606 END 607 SUBROUTINE OFFSET_ipccsd_x2_1_1(l_a_offset,k_a_offset,size) 608C $Id$ 609C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 610C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 611C i1 ( h9 p3 h1 h2 )_v 612 IMPLICIT NONE 613#include "global.fh" 614#include "mafdecls.fh" 615#include "sym.fh" 616#include "errquit.fh" 617#include "tce.fh" 618 INTEGER l_a_offset 619 INTEGER k_a_offset 620 INTEGER size 621 INTEGER length 622 INTEGER addr 623 INTEGER p3b 624 INTEGER h9b 625 INTEGER h1b 626 INTEGER h2b 627 length = 0 628 DO p3b = noab+1,noab+nvab 629 DO h9b = 1,noab 630 DO h1b = 1,noab 631 DO h2b = h1b,noab 632 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 633 &1b-1)+int_mb(k_spin+h2b-1)) THEN 634 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 635 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 636 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1 637 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 638 length = length + 1 639 END IF 640 END IF 641 END IF 642 END DO 643 END DO 644 END DO 645 END DO 646 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 647 &set)) CALL ERRQUIT('ipccsd_x2_1_1',0,MA_ERR) 648 int_mb(k_a_offset) = length 649 addr = 0 650 size = 0 651 DO p3b = noab+1,noab+nvab 652 DO h9b = 1,noab 653 DO h1b = 1,noab 654 DO h2b = h1b,noab 655 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 656 &1b-1)+int_mb(k_spin+h2b-1)) THEN 657 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 658 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 659 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1 660 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 661 addr = addr + 1 662 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h9b 663 &- 1 + noab * (p3b - noab - 1))) 664 int_mb(k_a_offset+length+addr) = size 665 size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_ 666 &mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 667 END IF 668 END IF 669 END IF 670 END DO 671 END DO 672 END DO 673 END DO 674 RETURN 675 END 676 SUBROUTINE ipccsd_x2_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 677 &set) 678C $Id$ 679C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 680C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 681C i1 ( h9 p3 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h9 p3 h2 p5 )_v 682 IMPLICIT NONE 683#include "global.fh" 684#include "mafdecls.fh" 685#include "sym.fh" 686#include "errquit.fh" 687#include "tce.fh" 688 INTEGER d_a 689 INTEGER k_a_offset 690 INTEGER d_b 691 INTEGER k_b_offset 692 INTEGER d_c 693 INTEGER k_c_offset 694 INTEGER NXTASK 695 INTEGER next 696 INTEGER nprocs 697 INTEGER count 698 INTEGER p3b 699 INTEGER h9b 700 INTEGER h1b 701 INTEGER h2b 702 INTEGER dimc 703 INTEGER l_c_sort 704 INTEGER k_c_sort 705 INTEGER p5b 706 INTEGER p5b_1 707 INTEGER h1b_1 708 INTEGER p3b_2 709 INTEGER h9b_2 710 INTEGER h2b_2 711 INTEGER p5b_2 712 INTEGER dim_common 713 INTEGER dima_sort 714 INTEGER dima 715 INTEGER dimb_sort 716 INTEGER dimb 717 INTEGER l_a_sort 718 INTEGER k_a_sort 719 INTEGER l_a 720 INTEGER k_a 721 INTEGER l_b_sort 722 INTEGER k_b_sort 723 INTEGER l_b 724 INTEGER k_b 725 INTEGER l_c 726 INTEGER k_c 727 EXTERNAL NXTASK 728 nprocs = GA_NNODES() 729 count = 0 730 next = NXTASK(nprocs, 1) 731 DO p3b = noab+1,noab+nvab 732 DO h9b = 1,noab 733 DO h1b = 1,noab 734 DO h2b = 1,noab 735 IF (next.eq.count) THEN 736 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1 737 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 738 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 739 &1b-1)+int_mb(k_spin+h2b-1)) THEN 740 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 741 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 742 &EN 743 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 744 &nge+h1b-1) * int_mb(k_range+h2b-1) 745 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 746 & ERRQUIT('ipccsd_x2_1_2',0,MA_ERR) 747 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 748 DO p5b = noab+1,noab+nvab 749 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 750 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 751 &EN 752 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 753 CALL TCE_RESTRICTED_4(p3b,h9b,h2b,p5b,p3b_2,h9b_2,h2b_2,p5b_2) 754 dim_common = int_mb(k_range+p5b-1) 755 dima_sort = int_mb(k_range+h1b-1) 756 dima = dim_common * dima_sort 757 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb 758 &(k_range+h2b-1) 759 dimb = dim_common * dimb_sort 760 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 761 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 762 & ERRQUIT('ipccsd_x2_1_2',1,MA_ERR) 763 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 764 &ipccsd_x2_1_2',2,MA_ERR) 765 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 766 & - 1 + noab * (p5b_1 - noab - 1))) 767 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 768 &,int_mb(k_range+h1b-1),2,1,1.0d0) 769 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_2',3,MA_ERR) 770 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 771 & ERRQUIT('ipccsd_x2_1_2',4,MA_ERR) 772 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 773 &ipccsd_x2_1_2',5,MA_ERR) 774 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 775 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h9b_2 - 1 + noab * (p3b_ 776 &2 - noab - 1))))) 777 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1) 778 &,int_mb(k_range+h9b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1) 779 &,3,2,1,4,1.0d0) 780 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_2',6,MA_ERR) 781 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 782 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 783 &t),dima_sort) 784 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_2',7,MA 785 &_ERR) 786 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_2',8,MA 787 &_ERR) 788 END IF 789 END IF 790 END IF 791 END DO 792 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 793 &ipccsd_x2_1_2',9,MA_ERR) 794 IF ((h1b .le. h2b)) THEN 795 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 796 &,int_mb(k_range+h9b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 797 &,3,2,4,1,-1.0d0) 798 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 799 & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1))) 800 &)) 801 END IF 802 IF ((h2b .le. h1b)) THEN 803 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 804 &,int_mb(k_range+h9b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 805 &,3,2,1,4,1.0d0) 806 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 807 & 1 + noab * (h2b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1))) 808 &)) 809 END IF 810 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_2',10,MA_ERR 811 &) 812 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_2',11,M 813 &A_ERR) 814 END IF 815 END IF 816 END IF 817 next = NXTASK(nprocs, 1) 818 END IF 819 count = count + 1 820 END DO 821 END DO 822 END DO 823 END DO 824 next = NXTASK(-nprocs, 1) 825 call GA_SYNC() 826 RETURN 827 END 828 SUBROUTINE ipccsd_x2_1_2_1(d_a,k_a_offset,d_c,k_c_offset) 829C $Id$ 830C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 831C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 832C i2 ( h9 p3 h1 p5 )_v + = 1 * v ( h9 p3 h1 p5 )_v 833 IMPLICIT NONE 834#include "global.fh" 835#include "mafdecls.fh" 836#include "sym.fh" 837#include "errquit.fh" 838#include "tce.fh" 839 INTEGER d_a 840 INTEGER k_a_offset 841 INTEGER d_c 842 INTEGER k_c_offset 843 INTEGER NXTASK 844 INTEGER next 845 INTEGER nprocs 846 INTEGER count 847 INTEGER p3b 848 INTEGER h9b 849 INTEGER h1b 850 INTEGER p5b 851 INTEGER dimc 852 INTEGER p3b_1 853 INTEGER h9b_1 854 INTEGER h1b_1 855 INTEGER p5b_1 856 INTEGER dim_common 857 INTEGER dima_sort 858 INTEGER dima 859 INTEGER l_a_sort 860 INTEGER k_a_sort 861 INTEGER l_a 862 INTEGER k_a 863 INTEGER l_c 864 INTEGER k_c 865 EXTERNAL NXTASK 866 nprocs = GA_NNODES() 867 count = 0 868 next = NXTASK(nprocs, 1) 869 DO p3b = noab+1,noab+nvab 870 DO h9b = 1,noab 871 DO h1b = 1,noab 872 DO p5b = noab+1,noab+nvab 873 IF (next.eq.count) THEN 874 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1 875 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 876 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 877 &1b-1)+int_mb(k_spin+p5b-1)) THEN 878 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 879 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 880 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 881 &nge+h1b-1) * int_mb(k_range+p5b-1) 882 CALL TCE_RESTRICTED_4(p3b,h9b,h1b,p5b,p3b_1,h9b_1,h1b_1,p5b_1) 883 dim_common = 1 884 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb 885 &(k_range+h1b-1) * int_mb(k_range+p5b-1) 886 dima = dim_common * dima_sort 887 IF (dima .gt. 0) THEN 888 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 889 & ERRQUIT('ipccsd_x2_1_2_1',0,MA_ERR) 890 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 891 &ipccsd_x2_1_2_1',1,MA_ERR) 892 IF ((h9b .le. p3b) .and. (h1b .le. p5b)) THEN 893 if(.not.intorb) then 894 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 895 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab 896 &+nvab) * (h9b_1 - 1))))) 897 else 898 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset), 899 &(p5b_1 900 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab 901 &+nvab) * (h9b_1 - 1)))),p5b_1,h1b_1,p3b_1,h9b_1) 902 end if 903 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 904 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1) 905 &,4,3,1,2,1.0d0) 906 END IF 907 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_2_1',2,MA_ER 908 &R) 909 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 910 &ipccsd_x2_1_2_1',3,MA_ERR) 911 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 912 &,int_mb(k_range+h1b-1),int_mb(k_range+h9b-1),int_mb(k_range+p3b-1) 913 &,4,3,2,1,1.0d0) 914 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 915 & noab - 1 + nvab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab 916 & - 1))))) 917 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_2_1',4,MA_ER 918 &R) 919 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_2_1',5, 920 &MA_ERR) 921 END IF 922 END IF 923 END IF 924 END IF 925 next = NXTASK(nprocs, 1) 926 END IF 927 count = count + 1 928 END DO 929 END DO 930 END DO 931 END DO 932 next = NXTASK(-nprocs, 1) 933 call GA_SYNC() 934 RETURN 935 END 936 SUBROUTINE OFFSET_ipccsd_x2_1_2_1(l_a_offset,k_a_offset,size) 937C $Id$ 938C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 939C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 940C i2 ( h9 p3 h1 p5 )_v 941 IMPLICIT NONE 942#include "global.fh" 943#include "mafdecls.fh" 944#include "sym.fh" 945#include "errquit.fh" 946#include "tce.fh" 947 INTEGER l_a_offset 948 INTEGER k_a_offset 949 INTEGER size 950 INTEGER length 951 INTEGER addr 952 INTEGER p3b 953 INTEGER h9b 954 INTEGER h1b 955 INTEGER p5b 956 length = 0 957 DO p3b = noab+1,noab+nvab 958 DO h9b = 1,noab 959 DO h1b = 1,noab 960 DO p5b = noab+1,noab+nvab 961 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 962 &1b-1)+int_mb(k_spin+p5b-1)) THEN 963 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 964 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 965 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1 966 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 967 length = length + 1 968 END IF 969 END IF 970 END IF 971 END DO 972 END DO 973 END DO 974 END DO 975 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 976 &set)) CALL ERRQUIT('ipccsd_x2_1_2_1',0,MA_ERR) 977 int_mb(k_a_offset) = length 978 addr = 0 979 size = 0 980 DO p3b = noab+1,noab+nvab 981 DO h9b = 1,noab 982 DO h1b = 1,noab 983 DO p5b = noab+1,noab+nvab 984 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 985 &1b-1)+int_mb(k_spin+p5b-1)) THEN 986 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 987 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 988 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1 989 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 990 addr = addr + 1 991 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 992 &* (h9b - 1 + noab * (p3b - noab - 1))) 993 int_mb(k_a_offset+length+addr) = size 994 size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_ 995 &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 996 END IF 997 END IF 998 END IF 999 END DO 1000 END DO 1001 END DO 1002 END DO 1003 RETURN 1004 END 1005 SUBROUTINE ipccsd_x2_1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o 1006 &ffset) 1007C $Id$ 1008C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1009C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1010C i2 ( h9 p3 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 p3 p5 p6 )_v 1011 IMPLICIT NONE 1012#include "global.fh" 1013#include "mafdecls.fh" 1014#include "sym.fh" 1015#include "errquit.fh" 1016#include "tce.fh" 1017 INTEGER d_a 1018 INTEGER k_a_offset 1019 INTEGER d_b 1020 INTEGER k_b_offset 1021 INTEGER d_c 1022 INTEGER k_c_offset 1023 INTEGER NXTASK 1024 INTEGER next 1025 INTEGER nprocs 1026 INTEGER count 1027 INTEGER p3b 1028 INTEGER h9b 1029 INTEGER h1b 1030 INTEGER p5b 1031 INTEGER dimc 1032 INTEGER l_c_sort 1033 INTEGER k_c_sort 1034 INTEGER p6b 1035 INTEGER p6b_1 1036 INTEGER h1b_1 1037 INTEGER p3b_2 1038 INTEGER h9b_2 1039 INTEGER p5b_2 1040 INTEGER p6b_2 1041 INTEGER dim_common 1042 INTEGER dima_sort 1043 INTEGER dima 1044 INTEGER dimb_sort 1045 INTEGER dimb 1046 INTEGER l_a_sort 1047 INTEGER k_a_sort 1048 INTEGER l_a 1049 INTEGER k_a 1050 INTEGER l_b_sort 1051 INTEGER k_b_sort 1052 INTEGER l_b 1053 INTEGER k_b 1054 INTEGER l_c 1055 INTEGER k_c 1056 EXTERNAL NXTASK 1057 nprocs = GA_NNODES() 1058 count = 0 1059 next = NXTASK(nprocs, 1) 1060 DO p3b = noab+1,noab+nvab 1061 DO h9b = 1,noab 1062 DO h1b = 1,noab 1063 DO p5b = noab+1,noab+nvab 1064 IF (next.eq.count) THEN 1065 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1 1066 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1067 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 1068 &1b-1)+int_mb(k_spin+p5b-1)) THEN 1069 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 1070 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 1071 &EN 1072 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 1073 &nge+h1b-1) * int_mb(k_range+p5b-1) 1074 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1075 & ERRQUIT('ipccsd_x2_1_2_2',0,MA_ERR) 1076 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1077 DO p6b = noab+1,noab+nvab 1078 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1079 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 1080 &EN 1081 CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1) 1082 CALL TCE_RESTRICTED_4(p3b,h9b,p5b,p6b,p3b_2,h9b_2,p5b_2,p6b_2) 1083 dim_common = int_mb(k_range+p6b-1) 1084 dima_sort = int_mb(k_range+h1b-1) 1085 dima = dim_common * dima_sort 1086 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb 1087 &(k_range+p5b-1) 1088 dimb = dim_common * dimb_sort 1089 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1090 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1091 & ERRQUIT('ipccsd_x2_1_2_2',1,MA_ERR) 1092 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1093 &ipccsd_x2_1_2_2',2,MA_ERR) 1094 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1095 & - 1 + noab * (p6b_1 - noab - 1))) 1096 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 1097 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1098 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_2_2',3,MA_ER 1099 &R) 1100 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1101 & ERRQUIT('ipccsd_x2_1_2_2',4,MA_ERR) 1102 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1103 &ipccsd_x2_1_2_2',5,MA_ERR) 1104 IF ((h9b .le. p3b) .and. (p6b .lt. p5b)) THEN 1105 if(.not.intorb) then 1106 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1107 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 1108 &+nvab) * (h9b_2 - 1))))) 1109 else 1110 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1111 &(p5b_2 1112 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 1113 &+nvab) * (h9b_2 - 1)))),p5b_2,p6b_2,p3b_2,h9b_2) 1114 end if 1115 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 1116 &,int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 1117 &,4,1,2,3,-1.0d0) 1118 END IF 1119 IF ((h9b .le. p3b) .and. (p5b .le. p6b)) THEN 1120 if(.not.intorb) then 1121 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 1122 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 1123 &+nvab) * (h9b_2 - 1))))) 1124 else 1125 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1126 &(p6b_2 1127 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 1128 &+nvab) * (h9b_2 - 1)))),p6b_2,p5b_2,p3b_2,h9b_2) 1129 end if 1130 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 1131 &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 1132 &,3,1,2,4,1.0d0) 1133 END IF 1134 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_2_2',6,MA_ER 1135 &R) 1136 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1137 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1138 &t),dima_sort) 1139 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_2_2',7, 1140 &MA_ERR) 1141 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_2_2',8, 1142 &MA_ERR) 1143 END IF 1144 END IF 1145 END IF 1146 END DO 1147 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1148 &ipccsd_x2_1_2_2',9,MA_ERR) 1149 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 1150 &,int_mb(k_range+h9b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 1151 &,3,2,4,1,-1.0d0/2.0d0) 1152 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 1153 & noab - 1 + nvab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab 1154 & - 1))))) 1155 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_2_2',10,MA_E 1156 &RR) 1157 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_2_2',11 1158 &,MA_ERR) 1159 END IF 1160 END IF 1161 END IF 1162 next = NXTASK(nprocs, 1) 1163 END IF 1164 count = count + 1 1165 END DO 1166 END DO 1167 END DO 1168 END DO 1169 next = NXTASK(-nprocs, 1) 1170 call GA_SYNC() 1171 RETURN 1172 END 1173 SUBROUTINE ipccsd_x2_1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 1174 &set) 1175C $Id$ 1176C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1177C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1178C i1 ( h9 p3 h1 h2 )_ft + = -1 * Sum ( p8 ) * t ( p3 p8 h1 h2 )_t * i2 ( h9 p8 )_f 1179 IMPLICIT NONE 1180#include "global.fh" 1181#include "mafdecls.fh" 1182#include "sym.fh" 1183#include "errquit.fh" 1184#include "tce.fh" 1185 INTEGER d_a 1186 INTEGER k_a_offset 1187 INTEGER d_b 1188 INTEGER k_b_offset 1189 INTEGER d_c 1190 INTEGER k_c_offset 1191 INTEGER NXTASK 1192 INTEGER next 1193 INTEGER nprocs 1194 INTEGER count 1195 INTEGER p3b 1196 INTEGER h9b 1197 INTEGER h1b 1198 INTEGER h2b 1199 INTEGER dimc 1200 INTEGER l_c_sort 1201 INTEGER k_c_sort 1202 INTEGER p8b 1203 INTEGER p3b_1 1204 INTEGER p8b_1 1205 INTEGER h1b_1 1206 INTEGER h2b_1 1207 INTEGER h9b_2 1208 INTEGER p8b_2 1209 INTEGER dim_common 1210 INTEGER dima_sort 1211 INTEGER dima 1212 INTEGER dimb_sort 1213 INTEGER dimb 1214 INTEGER l_a_sort 1215 INTEGER k_a_sort 1216 INTEGER l_a 1217 INTEGER k_a 1218 INTEGER l_b_sort 1219 INTEGER k_b_sort 1220 INTEGER l_b 1221 INTEGER k_b 1222 INTEGER l_c 1223 INTEGER k_c 1224 EXTERNAL NXTASK 1225 nprocs = GA_NNODES() 1226 count = 0 1227 next = NXTASK(nprocs, 1) 1228 DO p3b = noab+1,noab+nvab 1229 DO h9b = 1,noab 1230 DO h1b = 1,noab 1231 DO h2b = h1b,noab 1232 IF (next.eq.count) THEN 1233 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1 1234 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1235 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 1236 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1237 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 1238 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_f,irrep_t)) TH 1239 &EN 1240 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 1241 &nge+h1b-1) * int_mb(k_range+h2b-1) 1242 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1243 & ERRQUIT('ipccsd_x2_1_3',0,MA_ERR) 1244 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1245 DO p8b = noab+1,noab+nvab 1246 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h 1247 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1248 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb( 1249 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 1250 CALL TCE_RESTRICTED_4(p3b,p8b,h1b,h2b,p3b_1,p8b_1,h1b_1,h2b_1) 1251 CALL TCE_RESTRICTED_2(h9b,p8b,h9b_2,p8b_2) 1252 dim_common = int_mb(k_range+p8b-1) 1253 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb 1254 &(k_range+h2b-1) 1255 dima = dim_common * dima_sort 1256 dimb_sort = int_mb(k_range+h9b-1) 1257 dimb = dim_common * dimb_sort 1258 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1259 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1260 & ERRQUIT('ipccsd_x2_1_3',1,MA_ERR) 1261 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1262 &ipccsd_x2_1_3',2,MA_ERR) 1263 IF ((p8b .lt. p3b)) THEN 1264 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 1265 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 1266 &1 - noab - 1))))) 1267 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 1268 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 1269 &,4,3,2,1,-1.0d0) 1270 END IF 1271 IF ((p3b .le. p8b)) THEN 1272 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 1273 & - 1 + noab * (h1b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 1274 &1 - noab - 1))))) 1275 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1276 &,int_mb(k_range+p8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 1277 &,4,3,1,2,1.0d0) 1278 END IF 1279 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_3',3,MA_ERR) 1280 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1281 & ERRQUIT('ipccsd_x2_1_3',4,MA_ERR) 1282 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1283 &ipccsd_x2_1_3',5,MA_ERR) 1284 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 1285 & - noab - 1 + nvab * (h9b_2 - 1))) 1286 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 1287 &,int_mb(k_range+p8b-1),1,2,1.0d0) 1288 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_3',6,MA_ERR) 1289 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1290 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1291 &t),dima_sort) 1292 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_3',7,MA 1293 &_ERR) 1294 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_3',8,MA 1295 &_ERR) 1296 END IF 1297 END IF 1298 END IF 1299 END DO 1300 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1301 &ipccsd_x2_1_3',9,MA_ERR) 1302 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h9b-1) 1303 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1304 &,4,1,3,2,-1.0d0) 1305 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1306 & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1))) 1307 &)) 1308 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_3',10,MA_ERR 1309 &) 1310 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_3',11,M 1311 &A_ERR) 1312 END IF 1313 END IF 1314 END IF 1315 next = NXTASK(nprocs, 1) 1316 END IF 1317 count = count + 1 1318 END DO 1319 END DO 1320 END DO 1321 END DO 1322 next = NXTASK(-nprocs, 1) 1323 call GA_SYNC() 1324 RETURN 1325 END 1326 SUBROUTINE ipccsd_x2_1_3_1(d_a,k_a_offset,d_c,k_c_offset) 1327C $Id$ 1328C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1329C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1330C i2 ( h9 p8 )_f + = 1 * f ( h9 p8 )_f 1331 IMPLICIT NONE 1332#include "global.fh" 1333#include "mafdecls.fh" 1334#include "sym.fh" 1335#include "errquit.fh" 1336#include "tce.fh" 1337 INTEGER d_a 1338 INTEGER k_a_offset 1339 INTEGER d_c 1340 INTEGER k_c_offset 1341 INTEGER NXTASK 1342 INTEGER next 1343 INTEGER nprocs 1344 INTEGER count 1345 INTEGER h9b 1346 INTEGER p8b 1347 INTEGER dimc 1348 INTEGER h9b_1 1349 INTEGER p8b_1 1350 INTEGER dim_common 1351 INTEGER dima_sort 1352 INTEGER dima 1353 INTEGER l_a_sort 1354 INTEGER k_a_sort 1355 INTEGER l_a 1356 INTEGER k_a 1357 INTEGER l_c 1358 INTEGER k_c 1359 EXTERNAL NXTASK 1360 nprocs = GA_NNODES() 1361 count = 0 1362 next = NXTASK(nprocs, 1) 1363 DO h9b = 1,noab 1364 DO p8b = noab+1,noab+nvab 1365 IF (next.eq.count) THEN 1366 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1 1367 &).ne.4)) THEN 1368 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN 1369 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH 1370 &EN 1371 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1) 1372 CALL TCE_RESTRICTED_2(h9b,p8b,h9b_1,p8b_1) 1373 dim_common = 1 1374 dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1) 1375 dima = dim_common * dima_sort 1376 IF (dima .gt. 0) THEN 1377 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1378 & ERRQUIT('ipccsd_x2_1_3_1',0,MA_ERR) 1379 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1380 &ipccsd_x2_1_3_1',1,MA_ERR) 1381 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1 1382 & - 1 + (noab+nvab) * (h9b_1 - 1))) 1383 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 1384 &,int_mb(k_range+p8b-1),2,1,1.0d0) 1385 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_3_1',2,MA_ER 1386 &R) 1387 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1388 &ipccsd_x2_1_3_1',3,MA_ERR) 1389 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 1390 &,int_mb(k_range+h9b-1),2,1,1.0d0) 1391 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 1392 & noab - 1 + nvab * (h9b - 1))) 1393 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_3_1',4,MA_ER 1394 &R) 1395 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_3_1',5, 1396 &MA_ERR) 1397 END IF 1398 END IF 1399 END IF 1400 END IF 1401 next = NXTASK(nprocs, 1) 1402 END IF 1403 count = count + 1 1404 END DO 1405 END DO 1406 next = NXTASK(-nprocs, 1) 1407 call GA_SYNC() 1408 RETURN 1409 END 1410 SUBROUTINE OFFSET_ipccsd_x2_1_3_1(l_a_offset,k_a_offset,size) 1411C $Id$ 1412C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1413C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1414C i2 ( h9 p8 )_f 1415 IMPLICIT NONE 1416#include "global.fh" 1417#include "mafdecls.fh" 1418#include "sym.fh" 1419#include "errquit.fh" 1420#include "tce.fh" 1421 INTEGER l_a_offset 1422 INTEGER k_a_offset 1423 INTEGER size 1424 INTEGER length 1425 INTEGER addr 1426 INTEGER h9b 1427 INTEGER p8b 1428 length = 0 1429 DO h9b = 1,noab 1430 DO p8b = noab+1,noab+nvab 1431 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN 1432 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH 1433 &EN 1434 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1 1435 &).ne.4)) THEN 1436 length = length + 1 1437 END IF 1438 END IF 1439 END IF 1440 END DO 1441 END DO 1442 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1443 &set)) CALL ERRQUIT('ipccsd_x2_1_3_1',0,MA_ERR) 1444 int_mb(k_a_offset) = length 1445 addr = 0 1446 size = 0 1447 DO h9b = 1,noab 1448 DO p8b = noab+1,noab+nvab 1449 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN 1450 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH 1451 &EN 1452 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1 1453 &).ne.4)) THEN 1454 addr = addr + 1 1455 int_mb(k_a_offset+addr) = p8b - noab - 1 + nvab * (h9b - 1) 1456 int_mb(k_a_offset+length+addr) = size 1457 size = size + int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1) 1458 END IF 1459 END IF 1460 END IF 1461 END DO 1462 END DO 1463 RETURN 1464 END 1465 SUBROUTINE ipccsd_x2_1_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o 1466 &ffset) 1467C $Id$ 1468C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1469C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1470C i2 ( h9 p8 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 p6 p8 )_v 1471 IMPLICIT NONE 1472#include "global.fh" 1473#include "mafdecls.fh" 1474#include "sym.fh" 1475#include "errquit.fh" 1476#include "tce.fh" 1477 INTEGER d_a 1478 INTEGER k_a_offset 1479 INTEGER d_b 1480 INTEGER k_b_offset 1481 INTEGER d_c 1482 INTEGER k_c_offset 1483 INTEGER NXTASK 1484 INTEGER next 1485 INTEGER nprocs 1486 INTEGER count 1487 INTEGER h9b 1488 INTEGER p8b 1489 INTEGER dimc 1490 INTEGER l_c_sort 1491 INTEGER k_c_sort 1492 INTEGER p6b 1493 INTEGER h7b 1494 INTEGER p6b_1 1495 INTEGER h7b_1 1496 INTEGER h9b_2 1497 INTEGER h7b_2 1498 INTEGER p8b_2 1499 INTEGER p6b_2 1500 INTEGER dim_common 1501 INTEGER dima_sort 1502 INTEGER dima 1503 INTEGER dimb_sort 1504 INTEGER dimb 1505 INTEGER l_a_sort 1506 INTEGER k_a_sort 1507 INTEGER l_a 1508 INTEGER k_a 1509 INTEGER l_b_sort 1510 INTEGER k_b_sort 1511 INTEGER l_b 1512 INTEGER k_b 1513 INTEGER l_c 1514 INTEGER k_c 1515 EXTERNAL NXTASK 1516 nprocs = GA_NNODES() 1517 count = 0 1518 next = NXTASK(nprocs, 1) 1519 DO h9b = 1,noab 1520 DO p8b = noab+1,noab+nvab 1521 IF (next.eq.count) THEN 1522 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1 1523 &).ne.4)) THEN 1524 IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN 1525 IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. ieor(irrep_ 1526 &v,irrep_t)) THEN 1527 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1) 1528 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1529 & ERRQUIT('ipccsd_x2_1_3_2',0,MA_ERR) 1530 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1531 DO p6b = noab+1,noab+nvab 1532 DO h7b = 1,noab 1533 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN 1534 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 1535 &EN 1536 CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1) 1537 CALL TCE_RESTRICTED_4(h9b,h7b,p8b,p6b,h9b_2,h7b_2,p8b_2,p6b_2) 1538 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1) 1539 dima_sort = 1 1540 dima = dim_common * dima_sort 1541 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1) 1542 dimb = dim_common * dimb_sort 1543 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1544 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1545 & ERRQUIT('ipccsd_x2_1_3_2',1,MA_ERR) 1546 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1547 &ipccsd_x2_1_3_2',2,MA_ERR) 1548 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 1549 & - 1 + noab * (p6b_1 - noab - 1))) 1550 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 1551 &,int_mb(k_range+h7b-1),2,1,1.0d0) 1552 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_3_2',3,MA_ER 1553 &R) 1554 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1555 & ERRQUIT('ipccsd_x2_1_3_2',4,MA_ERR) 1556 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1557 &ipccsd_x2_1_3_2',5,MA_ERR) 1558 IF ((h7b .le. h9b) .and. (p6b .le. p8b)) THEN 1559 if(.not.intorb) then 1560 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 1561 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 1562 &+nvab) * (h7b_2 - 1))))) 1563 else 1564 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1565 &(p8b_2 1566 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 1567 &+nvab) * (h7b_2 - 1)))),p8b_2,p6b_2,h9b_2,h7b_2) 1568 end if 1569 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 1570 &,int_mb(k_range+h9b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1) 1571 &,4,2,1,3,1.0d0) 1572 END IF 1573 IF ((h7b .le. h9b) .and. (p8b .lt. p6b)) THEN 1574 if(.not.intorb) then 1575 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 1576 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 1577 &+nvab) * (h7b_2 - 1))))) 1578 else 1579 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1580 &(p6b_2 1581 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 1582 &+nvab) * (h7b_2 - 1)))),p6b_2,p8b_2,h9b_2,h7b_2) 1583 end if 1584 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 1585 &,int_mb(k_range+h9b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1) 1586 &,3,2,1,4,-1.0d0) 1587 END IF 1588 IF ((h9b .lt. h7b) .and. (p6b .le. p8b)) THEN 1589 if(.not.intorb) then 1590 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 1591 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 1592 &+nvab) * (h9b_2 - 1))))) 1593 else 1594 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1595 &(p8b_2 1596 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 1597 &+nvab) * (h9b_2 - 1)))),p8b_2,p6b_2,h7b_2,h9b_2) 1598 end if 1599 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 1600 &,int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1) 1601 &,4,1,2,3,-1.0d0) 1602 END IF 1603 IF ((h9b .lt. h7b) .and. (p8b .lt. p6b)) THEN 1604 if(.not.intorb) then 1605 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 1606 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 1607 &+nvab) * (h9b_2 - 1))))) 1608 else 1609 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1610 &(p6b_2 1611 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 1612 &+nvab) * (h9b_2 - 1)))),p6b_2,p8b_2,h7b_2,h9b_2) 1613 end if 1614 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 1615 &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1) 1616 &,3,1,2,4,1.0d0) 1617 END IF 1618 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_3_2',6,MA_ER 1619 &R) 1620 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1621 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1622 &t),dima_sort) 1623 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_3_2',7, 1624 &MA_ERR) 1625 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_3_2',8, 1626 &MA_ERR) 1627 END IF 1628 END IF 1629 END IF 1630 END DO 1631 END DO 1632 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1633 &ipccsd_x2_1_3_2',9,MA_ERR) 1634 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 1635 &,int_mb(k_range+h9b-1),2,1,1.0d0) 1636 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 1637 & noab - 1 + nvab * (h9b - 1))) 1638 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_3_2',10,MA_E 1639 &RR) 1640 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_3_2',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 next = NXTASK(-nprocs, 1) 1651 call GA_SYNC() 1652 RETURN 1653 END 1654 SUBROUTINE ipccsd_x2_1_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 1655 &set) 1656C $Id$ 1657C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1658C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1659C i1 ( h9 p3 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i2 ( h6 h9 h2 p5 )_v 1660 IMPLICIT NONE 1661#include "global.fh" 1662#include "mafdecls.fh" 1663#include "sym.fh" 1664#include "errquit.fh" 1665#include "tce.fh" 1666 INTEGER d_a 1667 INTEGER k_a_offset 1668 INTEGER d_b 1669 INTEGER k_b_offset 1670 INTEGER d_c 1671 INTEGER k_c_offset 1672 INTEGER NXTASK 1673 INTEGER next 1674 INTEGER nprocs 1675 INTEGER count 1676 INTEGER p3b 1677 INTEGER h9b 1678 INTEGER h1b 1679 INTEGER h2b 1680 INTEGER dimc 1681 INTEGER l_c_sort 1682 INTEGER k_c_sort 1683 INTEGER p5b 1684 INTEGER h6b 1685 INTEGER p3b_1 1686 INTEGER p5b_1 1687 INTEGER h1b_1 1688 INTEGER h6b_1 1689 INTEGER h9b_2 1690 INTEGER h6b_2 1691 INTEGER h2b_2 1692 INTEGER p5b_2 1693 INTEGER dim_common 1694 INTEGER dima_sort 1695 INTEGER dima 1696 INTEGER dimb_sort 1697 INTEGER dimb 1698 INTEGER l_a_sort 1699 INTEGER k_a_sort 1700 INTEGER l_a 1701 INTEGER k_a 1702 INTEGER l_b_sort 1703 INTEGER k_b_sort 1704 INTEGER l_b 1705 INTEGER k_b 1706 INTEGER l_c 1707 INTEGER k_c 1708 EXTERNAL NXTASK 1709 nprocs = GA_NNODES() 1710 count = 0 1711 next = NXTASK(nprocs, 1) 1712 DO p3b = noab+1,noab+nvab 1713 DO h9b = 1,noab 1714 DO h1b = 1,noab 1715 DO h2b = 1,noab 1716 IF (next.eq.count) THEN 1717 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1 1718 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1719 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 1720 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1721 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 1722 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 1723 &EN 1724 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 1725 &nge+h1b-1) * int_mb(k_range+h2b-1) 1726 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1727 & ERRQUIT('ipccsd_x2_1_4',0,MA_ERR) 1728 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1729 DO p5b = noab+1,noab+nvab 1730 DO h6b = 1,noab 1731 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 1732 &1b-1)+int_mb(k_spin+h6b-1)) THEN 1733 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 1734 &k_sym+h1b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_t) THEN 1735 CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h6b,p3b_1,p5b_1,h1b_1,h6b_1) 1736 CALL TCE_RESTRICTED_4(h9b,h6b,h2b,p5b,h9b_2,h6b_2,h2b_2,p5b_2) 1737 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) 1738 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) 1739 dima = dim_common * dima_sort 1740 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h2b-1) 1741 dimb = dim_common * dimb_sort 1742 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1743 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1744 & ERRQUIT('ipccsd_x2_1_4',1,MA_ERR) 1745 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1746 &ipccsd_x2_1_4',2,MA_ERR) 1747 IF ((p5b .lt. p3b) .and. (h6b .lt. h1b)) THEN 1748 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1749 & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 1750 &1 - noab - 1))))) 1751 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1752 &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 1753 &,4,2,3,1,1.0d0) 1754 END IF 1755 IF ((p5b .lt. p3b) .and. (h1b .le. h6b)) THEN 1756 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 1757 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 1758 &1 - noab - 1))))) 1759 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1760 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1) 1761 &,3,2,4,1,-1.0d0) 1762 END IF 1763 IF ((p3b .le. p5b) .and. (h6b .lt. h1b)) THEN 1764 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1765 & - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 1766 &1 - noab - 1))))) 1767 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1768 &,int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 1769 &,4,1,3,2,-1.0d0) 1770 END IF 1771 IF ((p3b .le. p5b) .and. (h1b .le. h6b)) THEN 1772 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 1773 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 1774 &1 - noab - 1))))) 1775 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1776 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1) 1777 &,3,1,4,2,1.0d0) 1778 END IF 1779 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_4',3,MA_ERR) 1780 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1781 & ERRQUIT('ipccsd_x2_1_4',4,MA_ERR) 1782 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1783 &ipccsd_x2_1_4',5,MA_ERR) 1784 IF ((h6b .le. h9b)) THEN 1785 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1786 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h9b_2 - 1 + noab * (h6b_ 1787 &2 - 1))))) 1788 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 1789 &,int_mb(k_range+h9b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1) 1790 &,3,2,1,4,1.0d0) 1791 END IF 1792 IF ((h9b .lt. h6b)) THEN 1793 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1794 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h6b_2 - 1 + noab * (h9b_ 1795 &2 - 1))))) 1796 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 1797 &,int_mb(k_range+h6b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1) 1798 &,3,1,2,4,-1.0d0) 1799 END IF 1800 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_4',6,MA_ERR) 1801 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1802 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1803 &t),dima_sort) 1804 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_4',7,MA 1805 &_ERR) 1806 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_4',8,MA 1807 &_ERR) 1808 END IF 1809 END IF 1810 END IF 1811 END DO 1812 END DO 1813 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1814 &ipccsd_x2_1_4',9,MA_ERR) 1815 IF ((h1b .le. h2b)) THEN 1816 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 1817 &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1818 &,4,2,3,1,1.0d0) 1819 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1820 & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1))) 1821 &)) 1822 END IF 1823 IF ((h2b .le. h1b)) THEN 1824 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 1825 &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1826 &,4,2,1,3,-1.0d0) 1827 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1828 & 1 + noab * (h2b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1))) 1829 &)) 1830 END IF 1831 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_4',10,MA_ERR 1832 &) 1833 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_4',11,M 1834 &A_ERR) 1835 END IF 1836 END IF 1837 END IF 1838 next = NXTASK(nprocs, 1) 1839 END IF 1840 count = count + 1 1841 END DO 1842 END DO 1843 END DO 1844 END DO 1845 next = NXTASK(-nprocs, 1) 1846 call GA_SYNC() 1847 RETURN 1848 END 1849 SUBROUTINE ipccsd_x2_1_4_1(d_a,k_a_offset,d_c,k_c_offset) 1850C $Id$ 1851C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1852C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1853C i2 ( h6 h9 h1 p5 )_v + = 1 * v ( h6 h9 h1 p5 )_v 1854 IMPLICIT NONE 1855#include "global.fh" 1856#include "mafdecls.fh" 1857#include "sym.fh" 1858#include "errquit.fh" 1859#include "tce.fh" 1860 INTEGER d_a 1861 INTEGER k_a_offset 1862 INTEGER d_c 1863 INTEGER k_c_offset 1864 INTEGER NXTASK 1865 INTEGER next 1866 INTEGER nprocs 1867 INTEGER count 1868 INTEGER h6b 1869 INTEGER h9b 1870 INTEGER h1b 1871 INTEGER p5b 1872 INTEGER dimc 1873 INTEGER h6b_1 1874 INTEGER h9b_1 1875 INTEGER h1b_1 1876 INTEGER p5b_1 1877 INTEGER dim_common 1878 INTEGER dima_sort 1879 INTEGER dima 1880 INTEGER l_a_sort 1881 INTEGER k_a_sort 1882 INTEGER l_a 1883 INTEGER k_a 1884 INTEGER l_c 1885 INTEGER k_c 1886 EXTERNAL NXTASK 1887 nprocs = GA_NNODES() 1888 count = 0 1889 next = NXTASK(nprocs, 1) 1890 DO h6b = 1,noab 1891 DO h9b = h6b,noab 1892 DO h1b = 1,noab 1893 DO p5b = noab+1,noab+nvab 1894 IF (next.eq.count) THEN 1895 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1 1896 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1897 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 1898 &1b-1)+int_mb(k_spin+p5b-1)) THEN 1899 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 1900 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 1901 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 1902 &nge+h1b-1) * int_mb(k_range+p5b-1) 1903 CALL TCE_RESTRICTED_4(h6b,h9b,h1b,p5b,h6b_1,h9b_1,h1b_1,p5b_1) 1904 dim_common = 1 1905 dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h9b-1) * int_mb 1906 &(k_range+h1b-1) * int_mb(k_range+p5b-1) 1907 dima = dim_common * dima_sort 1908 IF (dima .gt. 0) THEN 1909 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1910 & ERRQUIT('ipccsd_x2_1_4_1',0,MA_ERR) 1911 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1912 &ipccsd_x2_1_4_1',1,MA_ERR) 1913 IF ((h1b .le. p5b)) THEN 1914 if(.not.intorb) then 1915 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 1916 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h9b_1 - 1 + (noab 1917 &+nvab) * (h6b_1 - 1))))) 1918 else 1919 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset), 1920 &(p5b_1 1921 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h9b_1 - 1 + (noab 1922 &+nvab) * (h6b_1 - 1)))),p5b_1,h1b_1,h9b_1,h6b_1) 1923 end if 1924 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1) 1925 &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1) 1926 &,4,3,2,1,1.0d0) 1927 END IF 1928 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_4_1',2,MA_ER 1929 &R) 1930 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1931 &ipccsd_x2_1_4_1',3,MA_ERR) 1932 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 1933 &,int_mb(k_range+h1b-1),int_mb(k_range+h9b-1),int_mb(k_range+h6b-1) 1934 &,4,3,2,1,1.0d0) 1935 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 1936 & noab - 1 + nvab * (h1b - 1 + noab * (h9b - 1 + noab * (h6b - 1))) 1937 &)) 1938 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_4_1',4,MA_ER 1939 &R) 1940 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_4_1',5, 1941 &MA_ERR) 1942 END IF 1943 END IF 1944 END IF 1945 END IF 1946 next = NXTASK(nprocs, 1) 1947 END IF 1948 count = count + 1 1949 END DO 1950 END DO 1951 END DO 1952 END DO 1953 next = NXTASK(-nprocs, 1) 1954 call GA_SYNC() 1955 RETURN 1956 END 1957 SUBROUTINE OFFSET_ipccsd_x2_1_4_1(l_a_offset,k_a_offset,size) 1958C $Id$ 1959C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1960C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1961C i2 ( h6 h9 h1 p5 )_v 1962 IMPLICIT NONE 1963#include "global.fh" 1964#include "mafdecls.fh" 1965#include "sym.fh" 1966#include "errquit.fh" 1967#include "tce.fh" 1968 INTEGER l_a_offset 1969 INTEGER k_a_offset 1970 INTEGER size 1971 INTEGER length 1972 INTEGER addr 1973 INTEGER h6b 1974 INTEGER h9b 1975 INTEGER h1b 1976 INTEGER p5b 1977 length = 0 1978 DO h6b = 1,noab 1979 DO h9b = h6b,noab 1980 DO h1b = 1,noab 1981 DO p5b = noab+1,noab+nvab 1982 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 1983 &1b-1)+int_mb(k_spin+p5b-1)) THEN 1984 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 1985 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 1986 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1 1987 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1988 length = length + 1 1989 END IF 1990 END IF 1991 END IF 1992 END DO 1993 END DO 1994 END DO 1995 END DO 1996 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1997 &set)) CALL ERRQUIT('ipccsd_x2_1_4_1',0,MA_ERR) 1998 int_mb(k_a_offset) = length 1999 addr = 0 2000 size = 0 2001 DO h6b = 1,noab 2002 DO h9b = h6b,noab 2003 DO h1b = 1,noab 2004 DO p5b = noab+1,noab+nvab 2005 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 2006 &1b-1)+int_mb(k_spin+p5b-1)) THEN 2007 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 2008 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 2009 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1 2010 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 2011 addr = addr + 1 2012 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 2013 &* (h9b - 1 + noab * (h6b - 1))) 2014 int_mb(k_a_offset+length+addr) = size 2015 size = size + int_mb(k_range+h6b-1) * int_mb(k_range+h9b-1) * int_ 2016 &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 2017 END IF 2018 END IF 2019 END IF 2020 END DO 2021 END DO 2022 END DO 2023 END DO 2024 RETURN 2025 END 2026 SUBROUTINE ipccsd_x2_1_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o 2027 &ffset) 2028C $Id$ 2029C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2030C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2031C i2 ( h6 h9 h1 p5 )_vt + = -1 * Sum ( p7 ) * t ( p7 h1 )_t * v ( h6 h9 p5 p7 )_v 2032 IMPLICIT NONE 2033#include "global.fh" 2034#include "mafdecls.fh" 2035#include "sym.fh" 2036#include "errquit.fh" 2037#include "tce.fh" 2038 INTEGER d_a 2039 INTEGER k_a_offset 2040 INTEGER d_b 2041 INTEGER k_b_offset 2042 INTEGER d_c 2043 INTEGER k_c_offset 2044 INTEGER NXTASK 2045 INTEGER next 2046 INTEGER nprocs 2047 INTEGER count 2048 INTEGER h6b 2049 INTEGER h9b 2050 INTEGER h1b 2051 INTEGER p5b 2052 INTEGER dimc 2053 INTEGER l_c_sort 2054 INTEGER k_c_sort 2055 INTEGER p7b 2056 INTEGER p7b_1 2057 INTEGER h1b_1 2058 INTEGER h6b_2 2059 INTEGER h9b_2 2060 INTEGER p5b_2 2061 INTEGER p7b_2 2062 INTEGER dim_common 2063 INTEGER dima_sort 2064 INTEGER dima 2065 INTEGER dimb_sort 2066 INTEGER dimb 2067 INTEGER l_a_sort 2068 INTEGER k_a_sort 2069 INTEGER l_a 2070 INTEGER k_a 2071 INTEGER l_b_sort 2072 INTEGER k_b_sort 2073 INTEGER l_b 2074 INTEGER k_b 2075 INTEGER l_c 2076 INTEGER k_c 2077 EXTERNAL NXTASK 2078 nprocs = GA_NNODES() 2079 count = 0 2080 next = NXTASK(nprocs, 1) 2081 DO h6b = 1,noab 2082 DO h9b = h6b,noab 2083 DO h1b = 1,noab 2084 DO p5b = noab+1,noab+nvab 2085 IF (next.eq.count) THEN 2086 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1 2087 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 2088 IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 2089 &1b-1)+int_mb(k_spin+p5b-1)) THEN 2090 IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 2091 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 2092 &EN 2093 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 2094 &nge+h1b-1) * int_mb(k_range+p5b-1) 2095 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2096 & ERRQUIT('ipccsd_x2_1_4_2',0,MA_ERR) 2097 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2098 DO p7b = noab+1,noab+nvab 2099 IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2100 IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 2101 &EN 2102 CALL TCE_RESTRICTED_2(p7b,h1b,p7b_1,h1b_1) 2103 CALL TCE_RESTRICTED_4(h6b,h9b,p5b,p7b,h6b_2,h9b_2,p5b_2,p7b_2) 2104 dim_common = int_mb(k_range+p7b-1) 2105 dima_sort = int_mb(k_range+h1b-1) 2106 dima = dim_common * dima_sort 2107 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h9b-1) * int_mb 2108 &(k_range+p5b-1) 2109 dimb = dim_common * dimb_sort 2110 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2111 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2112 & ERRQUIT('ipccsd_x2_1_4_2',1,MA_ERR) 2113 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2114 &ipccsd_x2_1_4_2',2,MA_ERR) 2115 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2116 & - 1 + noab * (p7b_1 - noab - 1))) 2117 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 2118 &,int_mb(k_range+h1b-1),2,1,1.0d0) 2119 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_4_2',3,MA_ER 2120 &R) 2121 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2122 & ERRQUIT('ipccsd_x2_1_4_2',4,MA_ERR) 2123 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2124 &ipccsd_x2_1_4_2',5,MA_ERR) 2125 IF ((p7b .lt. p5b)) THEN 2126 if(.not.intorb) then 2127 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 2128 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 2129 &+nvab) * (h6b_2 - 1))))) 2130 else 2131 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 2132 &(p5b_2 2133 & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 2134 &+nvab) * (h6b_2 - 1)))),p5b_2,p7b_2,h9b_2,h6b_2) 2135 end if 2136 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 2137 &,int_mb(k_range+h9b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) 2138 &,4,2,1,3,-1.0d0) 2139 END IF 2140 IF ((p5b .le. p7b)) THEN 2141 if(.not.intorb) then 2142 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 2143 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 2144 &+nvab) * (h6b_2 - 1))))) 2145 else 2146 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 2147 &(p7b_2 2148 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab 2149 &+nvab) * (h6b_2 - 1)))),p7b_2,p5b_2,h9b_2,h6b_2) 2150 end if 2151 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 2152 &,int_mb(k_range+h9b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) 2153 &,3,2,1,4,1.0d0) 2154 END IF 2155 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_4_2',6,MA_ER 2156 &R) 2157 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2158 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2159 &t),dima_sort) 2160 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_4_2',7, 2161 &MA_ERR) 2162 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_4_2',8, 2163 &MA_ERR) 2164 END IF 2165 END IF 2166 END IF 2167 END DO 2168 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2169 &ipccsd_x2_1_4_2',9,MA_ERR) 2170 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 2171 &,int_mb(k_range+h9b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 2172 &,3,2,4,1,-1.0d0) 2173 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 2174 & noab - 1 + nvab * (h1b - 1 + noab * (h9b - 1 + noab * (h6b - 1))) 2175 &)) 2176 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_4_2',10,MA_E 2177 &RR) 2178 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_4_2',11 2179 &,MA_ERR) 2180 END IF 2181 END IF 2182 END IF 2183 next = NXTASK(nprocs, 1) 2184 END IF 2185 count = count + 1 2186 END DO 2187 END DO 2188 END DO 2189 END DO 2190 next = NXTASK(-nprocs, 1) 2191 call GA_SYNC() 2192 RETURN 2193 END 2194 SUBROUTINE ipccsd_x2_1_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 2195 &set) 2196C $Id$ 2197C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2198C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2199C i1 ( h9 p3 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 p3 p5 p6 )_v 2200 IMPLICIT NONE 2201#include "global.fh" 2202#include "mafdecls.fh" 2203#include "sym.fh" 2204#include "errquit.fh" 2205#include "tce.fh" 2206 INTEGER d_a 2207 INTEGER k_a_offset 2208 INTEGER d_b 2209 INTEGER k_b_offset 2210 INTEGER d_c 2211 INTEGER k_c_offset 2212 INTEGER NXTASK 2213 INTEGER next 2214 INTEGER nprocs 2215 INTEGER count 2216 INTEGER p3b 2217 INTEGER h9b 2218 INTEGER h1b 2219 INTEGER h2b 2220 INTEGER dimc 2221 INTEGER l_c_sort 2222 INTEGER k_c_sort 2223 INTEGER p5b 2224 INTEGER p6b 2225 INTEGER p5b_1 2226 INTEGER p6b_1 2227 INTEGER h1b_1 2228 INTEGER h2b_1 2229 INTEGER p3b_2 2230 INTEGER h9b_2 2231 INTEGER p5b_2 2232 INTEGER p6b_2 2233 INTEGER dim_common 2234 INTEGER dima_sort 2235 INTEGER dima 2236 INTEGER dimb_sort 2237 INTEGER dimb 2238 INTEGER l_a_sort 2239 INTEGER k_a_sort 2240 INTEGER l_a 2241 INTEGER k_a 2242 INTEGER l_b_sort 2243 INTEGER k_b_sort 2244 INTEGER l_b 2245 INTEGER k_b 2246 INTEGER nsuperp(2) 2247 INTEGER isuperp 2248 INTEGER l_c 2249 INTEGER k_c 2250 DOUBLE PRECISION FACTORIAL 2251 EXTERNAL NXTASK 2252 EXTERNAL FACTORIAL 2253 nprocs = GA_NNODES() 2254 count = 0 2255 next = NXTASK(nprocs, 1) 2256 DO p3b = noab+1,noab+nvab 2257 DO h9b = 1,noab 2258 DO h1b = 1,noab 2259 DO h2b = h1b,noab 2260 IF (next.eq.count) THEN 2261 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1 2262 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 2263 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h 2264 &1b-1)+int_mb(k_spin+h2b-1)) THEN 2265 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 2266 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 2267 &EN 2268 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 2269 &nge+h1b-1) * int_mb(k_range+h2b-1) 2270 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2271 & ERRQUIT('ipccsd_x2_1_5',0,MA_ERR) 2272 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2273 DO p5b = noab+1,noab+nvab 2274 DO p6b = p5b,noab+nvab 2275 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 2276 &1b-1)+int_mb(k_spin+h2b-1)) THEN 2277 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 2278 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 2279 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1) 2280 CALL TCE_RESTRICTED_4(p3b,h9b,p5b,p6b,p3b_2,h9b_2,p5b_2,p6b_2) 2281 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) 2282 dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 2283 dima = dim_common * dima_sort 2284 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) 2285 dimb = dim_common * dimb_sort 2286 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2287 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2288 & ERRQUIT('ipccsd_x2_1_5',1,MA_ERR) 2289 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2290 &ipccsd_x2_1_5',2,MA_ERR) 2291 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 2292 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 2293 &1 - noab - 1))))) 2294 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 2295 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 2296 &,4,3,2,1,1.0d0) 2297 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_5',3,MA_ERR) 2298 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2299 & ERRQUIT('ipccsd_x2_1_5',4,MA_ERR) 2300 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2301 &ipccsd_x2_1_5',5,MA_ERR) 2302 IF ((h9b .le. p3b)) THEN 2303 if(.not.intorb) then 2304 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 2305 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 2306 &+nvab) * (h9b_2 - 1))))) 2307 else 2308 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 2309 &(p6b_2 2310 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 2311 &+nvab) * (h9b_2 - 1)))),p6b_2,p5b_2,p3b_2,h9b_2) 2312 end if 2313 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 2314 &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 2315 &,1,2,4,3,1.0d0) 2316 END IF 2317 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_5',6,MA_ERR) 2318 nsuperp(1) = 1 2319 nsuperp(2) = 1 2320 isuperp = 1 2321 IF (p5b .eq. p6b) THEN 2322 nsuperp(isuperp) = nsuperp(isuperp) + 1 2323 ELSE 2324 isuperp = isuperp + 1 2325 END IF 2326 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 2327 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 2328 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 2329 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_5',7,MA 2330 &_ERR) 2331 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_5',8,MA 2332 &_ERR) 2333 END IF 2334 END IF 2335 END IF 2336 END DO 2337 END DO 2338 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2339 &ipccsd_x2_1_5',9,MA_ERR) 2340 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h9b-1) 2341 &,int_mb(k_range+p3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 2342 &,2,1,4,3,1.0d0/2.0d0) 2343 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 2344 & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1))) 2345 &)) 2346 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_5',10,MA_ERR 2347 &) 2348 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_5',11,M 2349 &A_ERR) 2350 END IF 2351 END IF 2352 END IF 2353 next = NXTASK(nprocs, 1) 2354 END IF 2355 count = count + 1 2356 END DO 2357 END DO 2358 END DO 2359 END DO 2360 next = NXTASK(-nprocs, 1) 2361 call GA_SYNC() 2362 RETURN 2363 END 2364 SUBROUTINE ipccsd_x2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 2365 &t) 2366C $Id$ 2367C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2368C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2369C i0 ( p3 p4 h1 h2 )_xf + = -1 * P( 2 ) * Sum ( h8 ) * x ( p3 p4 h1 h8 )_x * i1 ( h8 h2 )_f 2370 IMPLICIT NONE 2371#include "global.fh" 2372#include "mafdecls.fh" 2373#include "sym.fh" 2374#include "errquit.fh" 2375#include "tce.fh" 2376 INTEGER d_a 2377 INTEGER k_a_offset 2378 INTEGER d_b 2379 INTEGER k_b_offset 2380 INTEGER d_c 2381 INTEGER k_c_offset 2382 INTEGER NXTASK 2383 INTEGER next 2384 INTEGER nprocs 2385 INTEGER count 2386 INTEGER p3b 2387 INTEGER p4b 2388 INTEGER h1b 2389 INTEGER h2b 2390 INTEGER dimc 2391 INTEGER l_c_sort 2392 INTEGER k_c_sort 2393 INTEGER h8b 2394 INTEGER p3b_1 2395 INTEGER p4b_1 2396 INTEGER h1b_1 2397 INTEGER h8b_1 2398 INTEGER h8b_2 2399 INTEGER h2b_2 2400 INTEGER dim_common 2401 INTEGER dima_sort 2402 INTEGER dima 2403 INTEGER dimb_sort 2404 INTEGER dimb 2405 INTEGER l_a_sort 2406 INTEGER k_a_sort 2407 INTEGER l_a 2408 INTEGER k_a 2409 INTEGER l_b_sort 2410 INTEGER k_b_sort 2411 INTEGER l_b 2412 INTEGER k_b 2413 INTEGER l_c 2414 INTEGER k_c 2415 EXTERNAL NXTASK 2416 nprocs = GA_NNODES() 2417 count = 0 2418 next = NXTASK(nprocs, 1) 2419 DO p3b = noab+1,noab+nvab 2420ckbn DO p4b = p3b,noab+nvab 2421 DO p4b = 1,1 2422 DO h1b = 1,noab 2423 DO h2b = 1,noab 2424 IF (next.eq.count) THEN 2425ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 2426ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 2427 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ ip_unused_spin 2428 & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 2429ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 2430ckbn &1b-1)+int_mb(k_spin+h2b-1)) THEN 2431 IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h 2432 &1b-1)+int_mb(k_spin+h2b-1)) THEN 2433ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 2434ckbn &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_f)) TH 2435ckbn &EN 2436 IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb( 2437 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_f)) TH 2438 &EN 2439ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 2440ckbn &nge+h1b-1) * int_mb(k_range+h2b-1) 2441 dimc = int_mb(k_range+p3b-1) * 1 * int_mb(k_ra 2442 &nge+h1b-1) * int_mb(k_range+h2b-1) 2443 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2444 & ERRQUIT('ipccsd_x2_2',0,MA_ERR) 2445 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2446 DO h8b = 1,noab 2447ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 2448ckbn &1b-1)+int_mb(k_spin+h8b-1)) THEN 2449 IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h 2450 &1b-1)+int_mb(k_spin+h8b-1)) THEN 2451ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 2452ckbn &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_x) THEN 2453 IF (ieor(int_mb(k_sym+p3b-1),ieor( ip_unused_sym ,ieor(int_mb( 2454 &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_x) THEN 2455 CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h8b,p3b_1,p4b_1,h1b_1,h8b_1) 2456 CALL TCE_RESTRICTED_2(h8b,h2b,h8b_2,h2b_2) 2457 dim_common = int_mb(k_range+h8b-1) 2458ckbn dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb 2459ckbn &(k_range+h1b-1) 2460 dima_sort = int_mb(k_range+p3b-1) * 1 * int_mb 2461 &(k_range+h1b-1) 2462 dima = dim_common * dima_sort 2463 dimb_sort = int_mb(k_range+h2b-1) 2464 dimb = dim_common * dimb_sort 2465 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2466 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2467 & ERRQUIT('ipccsd_x2_2',1,MA_ERR) 2468 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2469 &ipccsd_x2_2',2,MA_ERR) 2470 IF ((h8b .lt. h1b)) THEN 2471 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2472 & - 1 + noab * (h8b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 2473 &1 - noab - 1))))) 2474ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2475ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) 2476ckbn &,4,2,1,3,-1.0d0) 2477 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2478 &,1,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) 2479 &,4,2,1,3,-1.0d0) 2480 END IF 2481 IF ((h1b .le. h8b)) THEN 2482 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 2483 & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 2484 &1 - noab - 1))))) 2485ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2486ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) 2487ckbn &,3,2,1,4,1.0d0) 2488 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2489 &,1,int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) 2490 &,3,2,1,4,1.0d0) 2491 END IF 2492 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2',3,MA_ERR) 2493 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2494 & ERRQUIT('ipccsd_x2_2',4,MA_ERR) 2495 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2496 &ipccsd_x2_2',5,MA_ERR) 2497 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 2498 & - 1 + noab * (h8b_2 - 1))) 2499 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 2500 &,int_mb(k_range+h2b-1),2,1,1.0d0) 2501 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_2',6,MA_ERR) 2502 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2503 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2504 &t),dima_sort) 2505 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_2',7,MA_E 2506 &RR) 2507 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2',8,MA_E 2508 &RR) 2509 END IF 2510 END IF 2511 END IF 2512 END DO 2513 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2514 &ipccsd_x2_2',9,MA_ERR) 2515 IF ((h1b .le. h2b)) THEN 2516ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 2517ckbn &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 2518ckbn &,4,3,2,1,-1.0d0) 2519 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 2520 &,int_mb(k_range+h1b-1),1,int_mb(k_range+p3b-1) 2521 &,4,3,2,1,-1.0d0) 2522 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 2523 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 2524 & - 1))))) 2525 END IF 2526 IF ((h2b .le. h1b)) THEN 2527ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 2528ckbn &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 2529ckbn &,4,3,1,2,1.0d0) 2530 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 2531 &,int_mb(k_range+h1b-1),1,int_mb(k_range+p3b-1) 2532 &,4,3,1,2,1.0d0) 2533 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2534 & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 2535 & - 1))))) 2536 END IF 2537 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2',10,MA_ERR) 2538 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_2',11,MA_ 2539 &ERR) 2540 END IF 2541 END IF 2542 END IF 2543 next = NXTASK(nprocs, 1) 2544 END IF 2545 count = count + 1 2546 END DO 2547 END DO 2548 END DO 2549 END DO 2550 next = NXTASK(-nprocs, 1) 2551 call GA_SYNC() 2552 RETURN 2553 END 2554 SUBROUTINE ipccsd_x2_2_1(d_a,k_a_offset,d_c,k_c_offset) 2555C $Id$ 2556C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2557C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2558C i1 ( h8 h1 )_f + = 1 * f ( h8 h1 )_f 2559 IMPLICIT NONE 2560#include "global.fh" 2561#include "mafdecls.fh" 2562#include "sym.fh" 2563#include "errquit.fh" 2564#include "tce.fh" 2565 INTEGER d_a 2566 INTEGER k_a_offset 2567 INTEGER d_c 2568 INTEGER k_c_offset 2569 INTEGER NXTASK 2570 INTEGER next 2571 INTEGER nprocs 2572 INTEGER count 2573 INTEGER h8b 2574 INTEGER h1b 2575 INTEGER dimc 2576 INTEGER h8b_1 2577 INTEGER h1b_1 2578 INTEGER dim_common 2579 INTEGER dima_sort 2580 INTEGER dima 2581 INTEGER l_a_sort 2582 INTEGER k_a_sort 2583 INTEGER l_a 2584 INTEGER k_a 2585 INTEGER l_c 2586 INTEGER k_c 2587 EXTERNAL NXTASK 2588 nprocs = GA_NNODES() 2589 count = 0 2590 next = NXTASK(nprocs, 1) 2591 DO h8b = 1,noab 2592 DO h1b = 1,noab 2593 IF (next.eq.count) THEN 2594 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 2595 &).ne.4)) THEN 2596 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2597 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 2598 &EN 2599 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 2600 CALL TCE_RESTRICTED_2(h8b,h1b,h8b_1,h1b_1) 2601 dim_common = 1 2602 dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 2603 dima = dim_common * dima_sort 2604 IF (dima .gt. 0) THEN 2605 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2606 & ERRQUIT('ipccsd_x2_2_1',0,MA_ERR) 2607 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2608 &ipccsd_x2_2_1',1,MA_ERR) 2609 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2610 & - 1 + (noab+nvab) * (h8b_1 - 1))) 2611 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1) 2612 &,int_mb(k_range+h1b-1),2,1,1.0d0) 2613 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_1',2,MA_ERR) 2614 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2615 &ipccsd_x2_2_1',3,MA_ERR) 2616 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 2617 &,int_mb(k_range+h8b-1),2,1,1.0d0) 2618 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2619 & 1 + noab * (h8b - 1))) 2620 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_1',4,MA_ERR) 2621 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_1',5,MA 2622 &_ERR) 2623 END IF 2624 END IF 2625 END IF 2626 END IF 2627 next = NXTASK(nprocs, 1) 2628 END IF 2629 count = count + 1 2630 END DO 2631 END DO 2632 next = NXTASK(-nprocs, 1) 2633 call GA_SYNC() 2634 RETURN 2635 END 2636 SUBROUTINE OFFSET_ipccsd_x2_2_1(l_a_offset,k_a_offset,size) 2637C $Id$ 2638C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2639C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2640C i1 ( h8 h1 )_f 2641 IMPLICIT NONE 2642#include "global.fh" 2643#include "mafdecls.fh" 2644#include "sym.fh" 2645#include "errquit.fh" 2646#include "tce.fh" 2647 INTEGER l_a_offset 2648 INTEGER k_a_offset 2649 INTEGER size 2650 INTEGER length 2651 INTEGER addr 2652 INTEGER h8b 2653 INTEGER h1b 2654 length = 0 2655 DO h8b = 1,noab 2656 DO h1b = 1,noab 2657 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2658 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 2659 &EN 2660 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 2661 &).ne.4)) THEN 2662 length = length + 1 2663 END IF 2664 END IF 2665 END IF 2666 END DO 2667 END DO 2668 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2669 &set)) CALL ERRQUIT('ipccsd_x2_2_1',0,MA_ERR) 2670 int_mb(k_a_offset) = length 2671 addr = 0 2672 size = 0 2673 DO h8b = 1,noab 2674 DO h1b = 1,noab 2675 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2676 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 2677 &EN 2678 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 2679 &).ne.4)) THEN 2680 addr = addr + 1 2681 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h8b - 1) 2682 int_mb(k_a_offset+length+addr) = size 2683 size = size + int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 2684 END IF 2685 END IF 2686 END IF 2687 END DO 2688 END DO 2689 RETURN 2690 END 2691 SUBROUTINE ipccsd_x2_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 2692 &set) 2693C $Id$ 2694C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2695C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2696C i1 ( h8 h1 )_ft + = 1 * Sum ( p9 ) * t ( p9 h1 )_t * i2 ( h8 p9 )_f 2697 IMPLICIT NONE 2698#include "global.fh" 2699#include "mafdecls.fh" 2700#include "sym.fh" 2701#include "errquit.fh" 2702#include "tce.fh" 2703 INTEGER d_a 2704 INTEGER k_a_offset 2705 INTEGER d_b 2706 INTEGER k_b_offset 2707 INTEGER d_c 2708 INTEGER k_c_offset 2709 INTEGER NXTASK 2710 INTEGER next 2711 INTEGER nprocs 2712 INTEGER count 2713 INTEGER h8b 2714 INTEGER h1b 2715 INTEGER dimc 2716 INTEGER l_c_sort 2717 INTEGER k_c_sort 2718 INTEGER p9b 2719 INTEGER p9b_1 2720 INTEGER h1b_1 2721 INTEGER h8b_2 2722 INTEGER p9b_2 2723 INTEGER dim_common 2724 INTEGER dima_sort 2725 INTEGER dima 2726 INTEGER dimb_sort 2727 INTEGER dimb 2728 INTEGER l_a_sort 2729 INTEGER k_a_sort 2730 INTEGER l_a 2731 INTEGER k_a 2732 INTEGER l_b_sort 2733 INTEGER k_b_sort 2734 INTEGER l_b 2735 INTEGER k_b 2736 INTEGER l_c 2737 INTEGER k_c 2738 EXTERNAL NXTASK 2739 nprocs = GA_NNODES() 2740 count = 0 2741 next = NXTASK(nprocs, 1) 2742 DO h8b = 1,noab 2743 DO h1b = 1,noab 2744 IF (next.eq.count) THEN 2745 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 2746 &).ne.4)) THEN 2747 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2748 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 2749 &f,irrep_t)) THEN 2750 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 2751 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2752 & ERRQUIT('ipccsd_x2_2_2',0,MA_ERR) 2753 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2754 DO p9b = noab+1,noab+nvab 2755 IF (int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2756 IF (ieor(int_mb(k_sym+p9b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 2757 &EN 2758 CALL TCE_RESTRICTED_2(p9b,h1b,p9b_1,h1b_1) 2759 CALL TCE_RESTRICTED_2(h8b,p9b,h8b_2,p9b_2) 2760 dim_common = int_mb(k_range+p9b-1) 2761 dima_sort = int_mb(k_range+h1b-1) 2762 dima = dim_common * dima_sort 2763 dimb_sort = int_mb(k_range+h8b-1) 2764 dimb = dim_common * dimb_sort 2765 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2766 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2767 & ERRQUIT('ipccsd_x2_2_2',1,MA_ERR) 2768 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2769 &ipccsd_x2_2_2',2,MA_ERR) 2770 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2771 & - 1 + noab * (p9b_1 - noab - 1))) 2772 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 2773 &,int_mb(k_range+h1b-1),2,1,1.0d0) 2774 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_2',3,MA_ERR) 2775 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2776 & ERRQUIT('ipccsd_x2_2_2',4,MA_ERR) 2777 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2778 &ipccsd_x2_2_2',5,MA_ERR) 2779 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 2780 & - noab - 1 + nvab * (h8b_2 - 1))) 2781 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 2782 &,int_mb(k_range+p9b-1),1,2,1.0d0) 2783 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_2_2',6,MA_ERR) 2784 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2785 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2786 &t),dima_sort) 2787 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_2_2',7,MA 2788 &_ERR) 2789 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_2',8,MA 2790 &_ERR) 2791 END IF 2792 END IF 2793 END IF 2794 END DO 2795 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2796 &ipccsd_x2_2_2',9,MA_ERR) 2797 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1) 2798 &,int_mb(k_range+h1b-1),1,2,1.0d0) 2799 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2800 & 1 + noab * (h8b - 1))) 2801 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_2',10,MA_ERR 2802 &) 2803 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_2_2',11,M 2804 &A_ERR) 2805 END IF 2806 END IF 2807 END IF 2808 next = NXTASK(nprocs, 1) 2809 END IF 2810 count = count + 1 2811 END DO 2812 END DO 2813 next = NXTASK(-nprocs, 1) 2814 call GA_SYNC() 2815 RETURN 2816 END 2817 SUBROUTINE ipccsd_x2_2_2_1(d_a,k_a_offset,d_c,k_c_offset) 2818C $Id$ 2819C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2820C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2821C i2 ( h8 p9 )_f + = 1 * f ( h8 p9 )_f 2822 IMPLICIT NONE 2823#include "global.fh" 2824#include "mafdecls.fh" 2825#include "sym.fh" 2826#include "errquit.fh" 2827#include "tce.fh" 2828 INTEGER d_a 2829 INTEGER k_a_offset 2830 INTEGER d_c 2831 INTEGER k_c_offset 2832 INTEGER NXTASK 2833 INTEGER next 2834 INTEGER nprocs 2835 INTEGER count 2836 INTEGER h8b 2837 INTEGER p9b 2838 INTEGER dimc 2839 INTEGER h8b_1 2840 INTEGER p9b_1 2841 INTEGER dim_common 2842 INTEGER dima_sort 2843 INTEGER dima 2844 INTEGER l_a_sort 2845 INTEGER k_a_sort 2846 INTEGER l_a 2847 INTEGER k_a 2848 INTEGER l_c 2849 INTEGER k_c 2850 EXTERNAL NXTASK 2851 nprocs = GA_NNODES() 2852 count = 0 2853 next = NXTASK(nprocs, 1) 2854 DO h8b = 1,noab 2855 DO p9b = noab+1,noab+nvab 2856 IF (next.eq.count) THEN 2857 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p9b-1 2858 &).ne.4)) THEN 2859 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p9b-1)) THEN 2860 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p9b-1)) .eq. irrep_f) TH 2861 &EN 2862 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p9b-1) 2863 CALL TCE_RESTRICTED_2(h8b,p9b,h8b_1,p9b_1) 2864 dim_common = 1 2865 dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p9b-1) 2866 dima = dim_common * dima_sort 2867 IF (dima .gt. 0) THEN 2868 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2869 & ERRQUIT('ipccsd_x2_2_2_1',0,MA_ERR) 2870 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2871 &ipccsd_x2_2_2_1',1,MA_ERR) 2872 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p9b_1 2873 & - 1 + (noab+nvab) * (h8b_1 - 1))) 2874 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1) 2875 &,int_mb(k_range+p9b-1),2,1,1.0d0) 2876 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_2_1',2,MA_ER 2877 &R) 2878 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2879 &ipccsd_x2_2_2_1',3,MA_ERR) 2880 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p9b-1) 2881 &,int_mb(k_range+h8b-1),2,1,1.0d0) 2882 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b - 2883 & noab - 1 + nvab * (h8b - 1))) 2884 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_2_1',4,MA_ER 2885 &R) 2886 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_2_1',5, 2887 &MA_ERR) 2888 END IF 2889 END IF 2890 END IF 2891 END IF 2892 next = NXTASK(nprocs, 1) 2893 END IF 2894 count = count + 1 2895 END DO 2896 END DO 2897 next = NXTASK(-nprocs, 1) 2898 call GA_SYNC() 2899 RETURN 2900 END 2901 SUBROUTINE OFFSET_ipccsd_x2_2_2_1(l_a_offset,k_a_offset,size) 2902C $Id$ 2903C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2904C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2905C i2 ( h8 p9 )_f 2906 IMPLICIT NONE 2907#include "global.fh" 2908#include "mafdecls.fh" 2909#include "sym.fh" 2910#include "errquit.fh" 2911#include "tce.fh" 2912 INTEGER l_a_offset 2913 INTEGER k_a_offset 2914 INTEGER size 2915 INTEGER length 2916 INTEGER addr 2917 INTEGER h8b 2918 INTEGER p9b 2919 length = 0 2920 DO h8b = 1,noab 2921 DO p9b = noab+1,noab+nvab 2922 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p9b-1)) THEN 2923 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p9b-1)) .eq. irrep_f) TH 2924 &EN 2925 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p9b-1 2926 &).ne.4)) THEN 2927 length = length + 1 2928 END IF 2929 END IF 2930 END IF 2931 END DO 2932 END DO 2933 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2934 &set)) CALL ERRQUIT('ipccsd_x2_2_2_1',0,MA_ERR) 2935 int_mb(k_a_offset) = length 2936 addr = 0 2937 size = 0 2938 DO h8b = 1,noab 2939 DO p9b = noab+1,noab+nvab 2940 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p9b-1)) THEN 2941 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p9b-1)) .eq. irrep_f) TH 2942 &EN 2943 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p9b-1 2944 &).ne.4)) THEN 2945 addr = addr + 1 2946 int_mb(k_a_offset+addr) = p9b - noab - 1 + nvab * (h8b - 1) 2947 int_mb(k_a_offset+length+addr) = size 2948 size = size + int_mb(k_range+h8b-1) * int_mb(k_range+p9b-1) 2949 END IF 2950 END IF 2951 END IF 2952 END DO 2953 END DO 2954 RETURN 2955 END 2956 SUBROUTINE ipccsd_x2_2_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o 2957 &ffset) 2958C $Id$ 2959C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2960C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2961C i2 ( h8 p9 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h8 p6 p9 )_v 2962 IMPLICIT NONE 2963#include "global.fh" 2964#include "mafdecls.fh" 2965#include "sym.fh" 2966#include "errquit.fh" 2967#include "tce.fh" 2968 INTEGER d_a 2969 INTEGER k_a_offset 2970 INTEGER d_b 2971 INTEGER k_b_offset 2972 INTEGER d_c 2973 INTEGER k_c_offset 2974 INTEGER NXTASK 2975 INTEGER next 2976 INTEGER nprocs 2977 INTEGER count 2978 INTEGER h8b 2979 INTEGER p9b 2980 INTEGER dimc 2981 INTEGER l_c_sort 2982 INTEGER k_c_sort 2983 INTEGER p6b 2984 INTEGER h7b 2985 INTEGER p6b_1 2986 INTEGER h7b_1 2987 INTEGER h8b_2 2988 INTEGER h7b_2 2989 INTEGER p9b_2 2990 INTEGER p6b_2 2991 INTEGER dim_common 2992 INTEGER dima_sort 2993 INTEGER dima 2994 INTEGER dimb_sort 2995 INTEGER dimb 2996 INTEGER l_a_sort 2997 INTEGER k_a_sort 2998 INTEGER l_a 2999 INTEGER k_a 3000 INTEGER l_b_sort 3001 INTEGER k_b_sort 3002 INTEGER l_b 3003 INTEGER k_b 3004 INTEGER l_c 3005 INTEGER k_c 3006 EXTERNAL NXTASK 3007 nprocs = GA_NNODES() 3008 count = 0 3009 next = NXTASK(nprocs, 1) 3010 DO h8b = 1,noab 3011 DO p9b = noab+1,noab+nvab 3012 IF (next.eq.count) THEN 3013 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p9b-1 3014 &).ne.4)) THEN 3015 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p9b-1)) THEN 3016 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p9b-1)) .eq. ieor(irrep_ 3017 &v,irrep_t)) THEN 3018 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p9b-1) 3019 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3020 & ERRQUIT('ipccsd_x2_2_2_2',0,MA_ERR) 3021 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3022 DO p6b = noab+1,noab+nvab 3023 DO h7b = 1,noab 3024 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN 3025 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 3026 &EN 3027 CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1) 3028 CALL TCE_RESTRICTED_4(h8b,h7b,p9b,p6b,h8b_2,h7b_2,p9b_2,p6b_2) 3029 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1) 3030 dima_sort = 1 3031 dima = dim_common * dima_sort 3032 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p9b-1) 3033 dimb = dim_common * dimb_sort 3034 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3035 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3036 & ERRQUIT('ipccsd_x2_2_2_2',1,MA_ERR) 3037 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3038 &ipccsd_x2_2_2_2',2,MA_ERR) 3039 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 3040 & - 1 + noab * (p6b_1 - noab - 1))) 3041 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 3042 &,int_mb(k_range+h7b-1),2,1,1.0d0) 3043 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_2_2',3,MA_ER 3044 &R) 3045 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3046 & ERRQUIT('ipccsd_x2_2_2_2',4,MA_ERR) 3047 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3048 &ipccsd_x2_2_2_2',5,MA_ERR) 3049 IF ((h7b .le. h8b) .and. (p6b .le. p9b)) THEN 3050 if(.not.intorb) then 3051 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 3052 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3053 &+nvab) * (h7b_2 - 1))))) 3054 else 3055 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3056 &(p9b_2 3057 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3058 &+nvab) * (h7b_2 - 1)))),p9b_2,p6b_2,h8b_2,h7b_2) 3059 end if 3060 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 3061 &,int_mb(k_range+h8b-1),int_mb(k_range+p6b-1),int_mb(k_range+p9b-1) 3062 &,4,2,1,3,1.0d0) 3063 END IF 3064 IF ((h7b .le. h8b) .and. (p9b .lt. p6b)) THEN 3065 if(.not.intorb) then 3066 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 3067 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3068 &+nvab) * (h7b_2 - 1))))) 3069 else 3070 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3071 &(p6b_2 3072 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3073 &+nvab) * (h7b_2 - 1)))),p6b_2,p9b_2,h8b_2,h7b_2) 3074 end if 3075 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 3076 &,int_mb(k_range+h8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p6b-1) 3077 &,3,2,1,4,-1.0d0) 3078 END IF 3079 IF ((h8b .lt. h7b) .and. (p6b .le. p9b)) THEN 3080 if(.not.intorb) then 3081 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 3082 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 3083 &+nvab) * (h8b_2 - 1))))) 3084 else 3085 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3086 &(p9b_2 3087 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 3088 &+nvab) * (h8b_2 - 1)))),p9b_2,p6b_2,h7b_2,h8b_2) 3089 end if 3090 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 3091 &,int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p9b-1) 3092 &,4,1,2,3,-1.0d0) 3093 END IF 3094 IF ((h8b .lt. h7b) .and. (p9b .lt. p6b)) THEN 3095 if(.not.intorb) then 3096 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 3097 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 3098 &+nvab) * (h8b_2 - 1))))) 3099 else 3100 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3101 &(p6b_2 3102 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 3103 &+nvab) * (h8b_2 - 1)))),p6b_2,p9b_2,h7b_2,h8b_2) 3104 end if 3105 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 3106 &,int_mb(k_range+h7b-1),int_mb(k_range+p9b-1),int_mb(k_range+p6b-1) 3107 &,3,1,2,4,1.0d0) 3108 END IF 3109 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_2_2_2',6,MA_ER 3110 &R) 3111 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3112 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3113 &t),dima_sort) 3114 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_2_2_2',7, 3115 &MA_ERR) 3116 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_2_2',8, 3117 &MA_ERR) 3118 END IF 3119 END IF 3120 END IF 3121 END DO 3122 END DO 3123 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3124 &ipccsd_x2_2_2_2',9,MA_ERR) 3125 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p9b-1) 3126 &,int_mb(k_range+h8b-1),2,1,1.0d0) 3127 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b - 3128 & noab - 1 + nvab * (h8b - 1))) 3129 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_2_2',10,MA_E 3130 &RR) 3131 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_2_2_2',11 3132 &,MA_ERR) 3133 END IF 3134 END IF 3135 END IF 3136 next = NXTASK(nprocs, 1) 3137 END IF 3138 count = count + 1 3139 END DO 3140 END DO 3141 next = NXTASK(-nprocs, 1) 3142 call GA_SYNC() 3143 RETURN 3144 END 3145 SUBROUTINE ipccsd_x2_2_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 3146 &set) 3147C $Id$ 3148C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3149C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3150C i1 ( h8 h1 )_vt + = -1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 h8 h1 p5 )_v 3151 IMPLICIT NONE 3152#include "global.fh" 3153#include "mafdecls.fh" 3154#include "sym.fh" 3155#include "errquit.fh" 3156#include "tce.fh" 3157 INTEGER d_a 3158 INTEGER k_a_offset 3159 INTEGER d_b 3160 INTEGER k_b_offset 3161 INTEGER d_c 3162 INTEGER k_c_offset 3163 INTEGER NXTASK 3164 INTEGER next 3165 INTEGER nprocs 3166 INTEGER count 3167 INTEGER h8b 3168 INTEGER h1b 3169 INTEGER dimc 3170 INTEGER l_c_sort 3171 INTEGER k_c_sort 3172 INTEGER p5b 3173 INTEGER h6b 3174 INTEGER p5b_1 3175 INTEGER h6b_1 3176 INTEGER h8b_2 3177 INTEGER h6b_2 3178 INTEGER h1b_2 3179 INTEGER p5b_2 3180 INTEGER dim_common 3181 INTEGER dima_sort 3182 INTEGER dima 3183 INTEGER dimb_sort 3184 INTEGER dimb 3185 INTEGER l_a_sort 3186 INTEGER k_a_sort 3187 INTEGER l_a 3188 INTEGER k_a 3189 INTEGER l_b_sort 3190 INTEGER k_b_sort 3191 INTEGER l_b 3192 INTEGER k_b 3193 INTEGER l_c 3194 INTEGER k_c 3195 EXTERNAL NXTASK 3196 nprocs = GA_NNODES() 3197 count = 0 3198 next = NXTASK(nprocs, 1) 3199 DO h8b = 1,noab 3200 DO h1b = 1,noab 3201 IF (next.eq.count) THEN 3202 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 3203 &).ne.4)) THEN 3204 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3205 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 3206 &v,irrep_t)) THEN 3207 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 3208 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3209 & ERRQUIT('ipccsd_x2_2_3',0,MA_ERR) 3210 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3211 DO p5b = noab+1,noab+nvab 3212 DO h6b = 1,noab 3213 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h6b-1)) THEN 3214 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h6b-1)) .eq. irrep_t) TH 3215 &EN 3216 CALL TCE_RESTRICTED_2(p5b,h6b,p5b_1,h6b_1) 3217 CALL TCE_RESTRICTED_4(h8b,h6b,h1b,p5b,h8b_2,h6b_2,h1b_2,p5b_2) 3218 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) 3219 dima_sort = 1 3220 dima = dim_common * dima_sort 3221 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 3222 dimb = dim_common * dimb_sort 3223 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3224 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3225 & ERRQUIT('ipccsd_x2_2_3',1,MA_ERR) 3226 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3227 &ipccsd_x2_2_3',2,MA_ERR) 3228 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 3229 & - 1 + noab * (p5b_1 - noab - 1))) 3230 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3231 &,int_mb(k_range+h6b-1),2,1,1.0d0) 3232 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_3',3,MA_ERR) 3233 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3234 & ERRQUIT('ipccsd_x2_2_3',4,MA_ERR) 3235 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3236 &ipccsd_x2_2_3',5,MA_ERR) 3237 IF ((h6b .le. h8b) .and. (h1b .le. p5b)) THEN 3238 if(.not.intorb) then 3239 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 3240 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3241 &+nvab) * (h6b_2 - 1))))) 3242 else 3243 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3244 &(p5b_2 3245 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3246 &+nvab) * (h6b_2 - 1)))),p5b_2,h1b_2,h8b_2,h6b_2) 3247 end if 3248 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 3249 &,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1) 3250 &,3,2,1,4,1.0d0) 3251 END IF 3252 IF ((h8b .lt. h6b) .and. (h1b .le. p5b)) THEN 3253 if(.not.intorb) then 3254 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 3255 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 3256 &+nvab) * (h8b_2 - 1))))) 3257 else 3258 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3259 &(p5b_2 3260 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 3261 &+nvab) * (h8b_2 - 1)))),p5b_2,h1b_2,h6b_2,h8b_2) 3262 end if 3263 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 3264 &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1) 3265 &,3,1,2,4,-1.0d0) 3266 END IF 3267 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_2_3',6,MA_ERR) 3268 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3269 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3270 &t),dima_sort) 3271 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_2_3',7,MA 3272 &_ERR) 3273 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_3',8,MA 3274 &_ERR) 3275 END IF 3276 END IF 3277 END IF 3278 END DO 3279 END DO 3280 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3281 &ipccsd_x2_2_3',9,MA_ERR) 3282 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 3283 &,int_mb(k_range+h8b-1),2,1,-1.0d0) 3284 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 3285 & 1 + noab * (h8b - 1))) 3286 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_3',10,MA_ERR 3287 &) 3288 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_2_3',11,M 3289 &A_ERR) 3290 END IF 3291 END IF 3292 END IF 3293 next = NXTASK(nprocs, 1) 3294 END IF 3295 count = count + 1 3296 END DO 3297 END DO 3298 next = NXTASK(-nprocs, 1) 3299 call GA_SYNC() 3300 RETURN 3301 END 3302 SUBROUTINE ipccsd_x2_2_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 3303 &set) 3304C $Id$ 3305C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3306C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3307C i1 ( h8 h1 )_vt + = -1/2 * Sum ( h7 p5 p6 ) * t ( p5 p6 h1 h7 )_t * v ( h7 h8 p5 p6 )_v 3308 IMPLICIT NONE 3309#include "global.fh" 3310#include "mafdecls.fh" 3311#include "sym.fh" 3312#include "errquit.fh" 3313#include "tce.fh" 3314 INTEGER d_a 3315 INTEGER k_a_offset 3316 INTEGER d_b 3317 INTEGER k_b_offset 3318 INTEGER d_c 3319 INTEGER k_c_offset 3320 INTEGER NXTASK 3321 INTEGER next 3322 INTEGER nprocs 3323 INTEGER count 3324 INTEGER h8b 3325 INTEGER h1b 3326 INTEGER dimc 3327 INTEGER l_c_sort 3328 INTEGER k_c_sort 3329 INTEGER p5b 3330 INTEGER p6b 3331 INTEGER h7b 3332 INTEGER p5b_1 3333 INTEGER p6b_1 3334 INTEGER h1b_1 3335 INTEGER h7b_1 3336 INTEGER h8b_2 3337 INTEGER h7b_2 3338 INTEGER p5b_2 3339 INTEGER p6b_2 3340 INTEGER dim_common 3341 INTEGER dima_sort 3342 INTEGER dima 3343 INTEGER dimb_sort 3344 INTEGER dimb 3345 INTEGER l_a_sort 3346 INTEGER k_a_sort 3347 INTEGER l_a 3348 INTEGER k_a 3349 INTEGER l_b_sort 3350 INTEGER k_b_sort 3351 INTEGER l_b 3352 INTEGER k_b 3353 INTEGER nsuperp(2) 3354 INTEGER isuperp 3355 INTEGER l_c 3356 INTEGER k_c 3357 DOUBLE PRECISION FACTORIAL 3358 EXTERNAL NXTASK 3359 EXTERNAL FACTORIAL 3360 nprocs = GA_NNODES() 3361 count = 0 3362 next = NXTASK(nprocs, 1) 3363 DO h8b = 1,noab 3364 DO h1b = 1,noab 3365 IF (next.eq.count) THEN 3366 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1 3367 &).ne.4)) THEN 3368 IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3369 IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 3370 &v,irrep_t)) THEN 3371 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1) 3372 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3373 & ERRQUIT('ipccsd_x2_2_4',0,MA_ERR) 3374 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3375 DO p5b = noab+1,noab+nvab 3376 DO p6b = p5b,noab+nvab 3377 DO h7b = 1,noab 3378 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 3379 &1b-1)+int_mb(k_spin+h7b-1)) THEN 3380 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 3381 &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_t) THEN 3382 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h7b,p5b_1,p6b_1,h1b_1,h7b_1) 3383 CALL TCE_RESTRICTED_4(h8b,h7b,p5b,p6b,h8b_2,h7b_2,p5b_2,p6b_2) 3384 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_m 3385 &b(k_range+h7b-1) 3386 dima_sort = int_mb(k_range+h1b-1) 3387 dima = dim_common * dima_sort 3388 dimb_sort = int_mb(k_range+h8b-1) 3389 dimb = dim_common * dimb_sort 3390 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3391 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3392 & ERRQUIT('ipccsd_x2_2_4',1,MA_ERR) 3393 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3394 &ipccsd_x2_2_4',2,MA_ERR) 3395 IF ((h7b .lt. h1b)) THEN 3396 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 3397 & - 1 + noab * (h7b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 3398 &1 - noab - 1))))) 3399 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3400 &,int_mb(k_range+p6b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 3401 &,4,3,2,1,-1.0d0) 3402 END IF 3403 IF ((h1b .le. h7b)) THEN 3404 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 3405 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 3406 &1 - noab - 1))))) 3407 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3408 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1) 3409 &,3,4,2,1,1.0d0) 3410 END IF 3411 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_4',3,MA_ERR) 3412 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3413 & ERRQUIT('ipccsd_x2_2_4',4,MA_ERR) 3414 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3415 &ipccsd_x2_2_4',5,MA_ERR) 3416 IF ((h7b .le. h8b)) THEN 3417 if(.not.intorb) then 3418 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 3419 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3420 &+nvab) * (h7b_2 - 1))))) 3421 else 3422 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3423 &(p6b_2 3424 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 3425 &+nvab) * (h7b_2 - 1)))),p6b_2,p5b_2,h8b_2,h7b_2) 3426 end if 3427 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 3428 &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 3429 &,2,1,4,3,1.0d0) 3430 END IF 3431 IF ((h8b .lt. h7b)) THEN 3432 if(.not.intorb) then 3433 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 3434 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 3435 &+nvab) * (h8b_2 - 1))))) 3436 else 3437 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3438 &(p6b_2 3439 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 3440 &+nvab) * (h8b_2 - 1)))),p6b_2,p5b_2,h7b_2,h8b_2) 3441 end if 3442 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 3443 &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 3444 &,1,2,4,3,-1.0d0) 3445 END IF 3446 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_2_4',6,MA_ERR) 3447 nsuperp(1) = 1 3448 nsuperp(2) = 1 3449 isuperp = 1 3450 IF (p5b .eq. p6b) THEN 3451 nsuperp(isuperp) = nsuperp(isuperp) + 1 3452 ELSE 3453 isuperp = isuperp + 1 3454 END IF 3455 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 3456 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 3457 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 3458 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_2_4',7,MA 3459 &_ERR) 3460 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_4',8,MA 3461 &_ERR) 3462 END IF 3463 END IF 3464 END IF 3465 END DO 3466 END DO 3467 END DO 3468 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3469 &ipccsd_x2_2_4',9,MA_ERR) 3470 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1) 3471 &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0) 3472 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 3473 & 1 + noab * (h8b - 1))) 3474 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_4',10,MA_ERR 3475 &) 3476 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_2_4',11,M 3477 &A_ERR) 3478 END IF 3479 END IF 3480 END IF 3481 next = NXTASK(nprocs, 1) 3482 END IF 3483 count = count + 1 3484 END DO 3485 END DO 3486 next = NXTASK(-nprocs, 1) 3487 call GA_SYNC() 3488 RETURN 3489 END 3490 SUBROUTINE ipccsd_x2_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 3491 &t) 3492C $Id$ 3493C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3494C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3495C i0 ( p3 p4 h1 h2 )_xf + = 1 * P( 2 ) * Sum ( p8 ) * x ( p3 p8 h1 h2 )_x * i1 ( p4 p8 )_f 3496 IMPLICIT NONE 3497#include "global.fh" 3498#include "mafdecls.fh" 3499#include "sym.fh" 3500#include "errquit.fh" 3501#include "tce.fh" 3502 INTEGER d_a 3503 INTEGER k_a_offset 3504 INTEGER d_b 3505 INTEGER k_b_offset 3506 INTEGER d_c 3507 INTEGER k_c_offset 3508 INTEGER NXTASK 3509 INTEGER next 3510 INTEGER nprocs 3511 INTEGER count 3512 INTEGER p3b 3513 INTEGER p4b 3514 INTEGER h1b 3515 INTEGER h2b 3516 INTEGER dimc 3517 INTEGER l_c_sort 3518 INTEGER k_c_sort 3519 INTEGER p8b 3520 INTEGER p3b_1 3521 INTEGER p8b_1 3522 INTEGER h1b_1 3523 INTEGER h2b_1 3524 INTEGER p4b_2 3525 INTEGER p8b_2 3526 INTEGER dim_common 3527 INTEGER dima_sort 3528 INTEGER dima 3529 INTEGER dimb_sort 3530 INTEGER dimb 3531 INTEGER l_a_sort 3532 INTEGER k_a_sort 3533 INTEGER l_a 3534 INTEGER k_a 3535 INTEGER l_b_sort 3536 INTEGER k_b_sort 3537 INTEGER l_b 3538 INTEGER k_b 3539 INTEGER l_c 3540 INTEGER k_c 3541 EXTERNAL NXTASK 3542 nprocs = GA_NNODES() 3543 count = 0 3544 next = NXTASK(nprocs, 1) 3545ckbn DO p3b = noab+1,noab+nvab 3546 DO p3b = 1,1 3547 DO p4b = noab+1,noab+nvab 3548 DO h1b = 1,noab 3549 DO h2b = h1b,noab 3550 IF (next.eq.count) THEN 3551ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 3552ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 3553 IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p4b-1 3554 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 3555ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 3556ckbn &1b-1)+int_mb(k_spin+h2b-1)) THEN 3557 IF (ip_unused_spin +int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 3558 &1b-1)+int_mb(k_spin+h2b-1)) THEN 3559ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 3560ckbn &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_f)) TH 3561ckbn &EN 3562 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 3563 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_f)) TH 3564 &EN 3565ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 3566ckbn &nge+h1b-1) * int_mb(k_range+h2b-1) 3567 dimc = 1 * int_mb(k_range+p4b-1) * int_mb(k_ra 3568 &nge+h1b-1) * int_mb(k_range+h2b-1) 3569 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3570 & ERRQUIT('ipccsd_x2_3',0,MA_ERR) 3571 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3572 DO p8b = noab+1,noab+nvab 3573ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h 3574ckbn &1b-1)+int_mb(k_spin+h2b-1)) THEN 3575 IF (ip_unused_spin +int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h 3576 &1b-1)+int_mb(k_spin+h2b-1)) THEN 3577ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb( 3578ckbn &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN 3579 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p8b-1),ieor(int_mb( 3580 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN 3581 CALL TCE_RESTRICTED_4(p3b,p8b,h1b,h2b,p3b_1,p8b_1,h1b_1,h2b_1) 3582 CALL TCE_RESTRICTED_2(p4b,p8b,p4b_2,p8b_2) 3583 dim_common = int_mb(k_range+p8b-1) 3584ckbn dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb 3585ckbn &(k_range+h2b-1) 3586 dima_sort = 1 * int_mb(k_range+h1b-1) * int_mb 3587 &(k_range+h2b-1) 3588 dima = dim_common * dima_sort 3589 dimb_sort = int_mb(k_range+p4b-1) 3590 dimb = dim_common * dimb_sort 3591 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3592 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3593 & ERRQUIT('ipccsd_x2_3',1,MA_ERR) 3594 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3595 &ipccsd_x2_3',2,MA_ERR) 3596ckbn IF ((p8b .lt. p3b)) THEN 3597 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 3598 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 3599 &1 - noab - 1))))) 3600ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 3601ckbn &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 3602ckbn &,4,3,2,1,-1.0d0) 3603 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 3604 &,1,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 3605 &,4,3,2,1,-1.0d0) 3606ckbn END IF 3607ckbn IF ((p3b .le. p8b)) THEN 3608ckbn CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 3609ckbn & - 1 + noab * (h1b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 3610ckbn &1 - noab - 1))))) 3611ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 3612ckbn &,int_mb(k_range+p8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 3613ckbn &,4,3,1,2,1.0d0) 3614ckbn END IF 3615 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_3',3,MA_ERR) 3616 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3617 & ERRQUIT('ipccsd_x2_3',4,MA_ERR) 3618 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3619 &ipccsd_x2_3',5,MA_ERR) 3620 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 3621 & - noab - 1 + nvab * (p4b_2 - noab - 1))) 3622 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 3623 &,int_mb(k_range+p8b-1),1,2,1.0d0) 3624 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_3',6,MA_ERR) 3625 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3626 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3627 &t),dima_sort) 3628 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_3',7,MA_E 3629 &RR) 3630 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_3',8,MA_E 3631 &RR) 3632 END IF 3633 END IF 3634 END IF 3635 END DO 3636 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3637 &ipccsd_x2_3',9,MA_ERR) 3638ckbn IF ((p3b .le. p4b)) THEN 3639ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 3640ckbn &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 3641ckbn &,4,1,3,2,1.0d0) 3642ckbn CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 3643ckbn & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 3644ckbn & - 1))))) 3645ckbn END IF 3646ckbn IF ((p4b .le. p3b)) THEN 3647ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 3648ckbn &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 3649ckbn &,1,4,3,2,-1.0d0) 3650 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 3651 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),1 3652 &,1,4,3,2,-1.0d0) 3653 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 3654 & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 3655 & - 1))))) 3656ckbn END IF 3657 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_3',10,MA_ERR) 3658 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_3',11,MA_ 3659 &ERR) 3660 END IF 3661 END IF 3662 END IF 3663 next = NXTASK(nprocs, 1) 3664 END IF 3665 count = count + 1 3666 END DO 3667 END DO 3668 END DO 3669 END DO 3670 next = NXTASK(-nprocs, 1) 3671 call GA_SYNC() 3672 RETURN 3673 END 3674 SUBROUTINE ipccsd_x2_3_1(d_a,k_a_offset,d_c,k_c_offset) 3675C $Id$ 3676C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3677C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3678C i1 ( p3 p8 )_f + = 1 * f ( p3 p8 )_f 3679 IMPLICIT NONE 3680#include "global.fh" 3681#include "mafdecls.fh" 3682#include "sym.fh" 3683#include "errquit.fh" 3684#include "tce.fh" 3685 INTEGER d_a 3686 INTEGER k_a_offset 3687 INTEGER d_c 3688 INTEGER k_c_offset 3689 INTEGER NXTASK 3690 INTEGER next 3691 INTEGER nprocs 3692 INTEGER count 3693 INTEGER p3b 3694 INTEGER p8b 3695 INTEGER dimc 3696 INTEGER p3b_1 3697 INTEGER p8b_1 3698 INTEGER dim_common 3699 INTEGER dima_sort 3700 INTEGER dima 3701 INTEGER l_a_sort 3702 INTEGER k_a_sort 3703 INTEGER l_a 3704 INTEGER k_a 3705 INTEGER l_c 3706 INTEGER k_c 3707 EXTERNAL NXTASK 3708 nprocs = GA_NNODES() 3709 count = 0 3710 next = NXTASK(nprocs, 1) 3711 DO p3b = noab+1,noab+nvab 3712 DO p8b = noab+1,noab+nvab 3713 IF (next.eq.count) THEN 3714 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1 3715 &).ne.4)) THEN 3716 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p8b-1)) THEN 3717 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH 3718 &EN 3719 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1) 3720 CALL TCE_RESTRICTED_2(p3b,p8b,p3b_1,p8b_1) 3721 dim_common = 1 3722 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1) 3723 dima = dim_common * dima_sort 3724 IF (dima .gt. 0) THEN 3725 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3726 & ERRQUIT('ipccsd_x2_3_1',0,MA_ERR) 3727 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3728 &ipccsd_x2_3_1',1,MA_ERR) 3729 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1 3730 & - 1 + (noab+nvab) * (p3b_1 - 1))) 3731 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 3732 &,int_mb(k_range+p8b-1),2,1,1.0d0) 3733 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_3_1',2,MA_ERR) 3734 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3735 &ipccsd_x2_3_1',3,MA_ERR) 3736 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 3737 &,int_mb(k_range+p3b-1),2,1,1.0d0) 3738 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 3739 & noab - 1 + nvab * (p3b - noab - 1))) 3740 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_3_1',4,MA_ERR) 3741 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_3_1',5,MA 3742 &_ERR) 3743 END IF 3744 END IF 3745 END IF 3746 END IF 3747 next = NXTASK(nprocs, 1) 3748 END IF 3749 count = count + 1 3750 END DO 3751 END DO 3752 next = NXTASK(-nprocs, 1) 3753 call GA_SYNC() 3754 RETURN 3755 END 3756 SUBROUTINE OFFSET_ipccsd_x2_3_1(l_a_offset,k_a_offset,size) 3757C $Id$ 3758C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3759C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3760C i1 ( p3 p8 )_f 3761 IMPLICIT NONE 3762#include "global.fh" 3763#include "mafdecls.fh" 3764#include "sym.fh" 3765#include "errquit.fh" 3766#include "tce.fh" 3767 INTEGER l_a_offset 3768 INTEGER k_a_offset 3769 INTEGER size 3770 INTEGER length 3771 INTEGER addr 3772 INTEGER p3b 3773 INTEGER p8b 3774 length = 0 3775 DO p3b = noab+1,noab+nvab 3776 DO p8b = noab+1,noab+nvab 3777 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p8b-1)) THEN 3778 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH 3779 &EN 3780 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1 3781 &).ne.4)) THEN 3782 length = length + 1 3783 END IF 3784 END IF 3785 END IF 3786 END DO 3787 END DO 3788 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 3789 &set)) CALL ERRQUIT('ipccsd_x2_3_1',0,MA_ERR) 3790 int_mb(k_a_offset) = length 3791 addr = 0 3792 size = 0 3793 DO p3b = noab+1,noab+nvab 3794 DO p8b = noab+1,noab+nvab 3795 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p8b-1)) THEN 3796 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH 3797 &EN 3798 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1 3799 &).ne.4)) THEN 3800 addr = addr + 1 3801 int_mb(k_a_offset+addr) = p8b - noab - 1 + nvab * (p3b - noab - 1) 3802 int_mb(k_a_offset+length+addr) = size 3803 size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1) 3804 END IF 3805 END IF 3806 END IF 3807 END DO 3808 END DO 3809 RETURN 3810 END 3811 SUBROUTINE ipccsd_x2_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 3812 &set) 3813C $Id$ 3814C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3815C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3816C i1 ( p3 p8 )_vt + = 1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 p3 p5 p8 )_v 3817 IMPLICIT NONE 3818#include "global.fh" 3819#include "mafdecls.fh" 3820#include "sym.fh" 3821#include "errquit.fh" 3822#include "tce.fh" 3823 INTEGER d_a 3824 INTEGER k_a_offset 3825 INTEGER d_b 3826 INTEGER k_b_offset 3827 INTEGER d_c 3828 INTEGER k_c_offset 3829 INTEGER NXTASK 3830 INTEGER next 3831 INTEGER nprocs 3832 INTEGER count 3833 INTEGER p3b 3834 INTEGER p8b 3835 INTEGER dimc 3836 INTEGER l_c_sort 3837 INTEGER k_c_sort 3838 INTEGER p5b 3839 INTEGER h6b 3840 INTEGER p5b_1 3841 INTEGER h6b_1 3842 INTEGER p3b_2 3843 INTEGER h6b_2 3844 INTEGER p8b_2 3845 INTEGER p5b_2 3846 INTEGER dim_common 3847 INTEGER dima_sort 3848 INTEGER dima 3849 INTEGER dimb_sort 3850 INTEGER dimb 3851 INTEGER l_a_sort 3852 INTEGER k_a_sort 3853 INTEGER l_a 3854 INTEGER k_a 3855 INTEGER l_b_sort 3856 INTEGER k_b_sort 3857 INTEGER l_b 3858 INTEGER k_b 3859 INTEGER l_c 3860 INTEGER k_c 3861 EXTERNAL NXTASK 3862 nprocs = GA_NNODES() 3863 count = 0 3864 next = NXTASK(nprocs, 1) 3865 DO p3b = noab+1,noab+nvab 3866 DO p8b = noab+1,noab+nvab 3867 IF (next.eq.count) THEN 3868 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1 3869 &).ne.4)) THEN 3870 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p8b-1)) THEN 3871 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p8b-1)) .eq. ieor(irrep_ 3872 &v,irrep_t)) THEN 3873 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1) 3874 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3875 & ERRQUIT('ipccsd_x2_3_2',0,MA_ERR) 3876 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3877 DO p5b = noab+1,noab+nvab 3878 DO h6b = 1,noab 3879 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h6b-1)) THEN 3880 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h6b-1)) .eq. irrep_t) TH 3881 &EN 3882 CALL TCE_RESTRICTED_2(p5b,h6b,p5b_1,h6b_1) 3883 CALL TCE_RESTRICTED_4(p3b,h6b,p8b,p5b,p3b_2,h6b_2,p8b_2,p5b_2) 3884 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) 3885 dima_sort = 1 3886 dima = dim_common * dima_sort 3887 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1) 3888 dimb = dim_common * dimb_sort 3889 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3890 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3891 & ERRQUIT('ipccsd_x2_3_2',1,MA_ERR) 3892 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3893 &ipccsd_x2_3_2',2,MA_ERR) 3894 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 3895 & - 1 + noab * (p5b_1 - noab - 1))) 3896 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 3897 &,int_mb(k_range+h6b-1),2,1,1.0d0) 3898 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_3_2',3,MA_ERR) 3899 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3900 & ERRQUIT('ipccsd_x2_3_2',4,MA_ERR) 3901 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3902 &ipccsd_x2_3_2',5,MA_ERR) 3903 IF ((h6b .le. p3b) .and. (p5b .le. p8b)) THEN 3904 if(.not.intorb) then 3905 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 3906 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 3907 &+nvab) * (h6b_2 - 1))))) 3908 else 3909 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3910 &(p8b_2 3911 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 3912 &+nvab) * (h6b_2 - 1)))),p8b_2,p5b_2,p3b_2,h6b_2) 3913 end if 3914 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 3915 &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1) 3916 &,4,2,1,3,1.0d0) 3917 END IF 3918 IF ((h6b .le. p3b) .and. (p8b .lt. p5b)) THEN 3919 if(.not.intorb) then 3920 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 3921 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 3922 &+nvab) * (h6b_2 - 1))))) 3923 else 3924 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 3925 &(p5b_2 3926 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 3927 &+nvab) * (h6b_2 - 1)))),p5b_2,p8b_2,p3b_2,h6b_2) 3928 end if 3929 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 3930 &,int_mb(k_range+p3b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1) 3931 &,3,2,1,4,-1.0d0) 3932 END IF 3933 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_3_2',6,MA_ERR) 3934 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3935 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3936 &t),dima_sort) 3937 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_3_2',7,MA 3938 &_ERR) 3939 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_3_2',8,MA 3940 &_ERR) 3941 END IF 3942 END IF 3943 END IF 3944 END DO 3945 END DO 3946 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3947 &ipccsd_x2_3_2',9,MA_ERR) 3948 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 3949 &,int_mb(k_range+p3b-1),2,1,1.0d0) 3950 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 3951 & noab - 1 + nvab * (p3b - noab - 1))) 3952 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_3_2',10,MA_ERR 3953 &) 3954 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_3_2',11,M 3955 &A_ERR) 3956 END IF 3957 END IF 3958 END IF 3959 next = NXTASK(nprocs, 1) 3960 END IF 3961 count = count + 1 3962 END DO 3963 END DO 3964 next = NXTASK(-nprocs, 1) 3965 call GA_SYNC() 3966 RETURN 3967 END 3968 SUBROUTINE ipccsd_x2_3_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 3969 &set) 3970C $Id$ 3971C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3972C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3973C i1 ( p3 p8 )_vt + = 1/2 * Sum ( h6 h7 p5 ) * t ( p3 p5 h6 h7 )_t * v ( h6 h7 p5 p8 )_v 3974 IMPLICIT NONE 3975#include "global.fh" 3976#include "mafdecls.fh" 3977#include "sym.fh" 3978#include "errquit.fh" 3979#include "tce.fh" 3980 INTEGER d_a 3981 INTEGER k_a_offset 3982 INTEGER d_b 3983 INTEGER k_b_offset 3984 INTEGER d_c 3985 INTEGER k_c_offset 3986 INTEGER NXTASK 3987 INTEGER next 3988 INTEGER nprocs 3989 INTEGER count 3990 INTEGER p3b 3991 INTEGER p8b 3992 INTEGER dimc 3993 INTEGER l_c_sort 3994 INTEGER k_c_sort 3995 INTEGER p5b 3996 INTEGER h6b 3997 INTEGER h7b 3998 INTEGER p3b_1 3999 INTEGER p5b_1 4000 INTEGER h6b_1 4001 INTEGER h7b_1 4002 INTEGER h6b_2 4003 INTEGER h7b_2 4004 INTEGER p8b_2 4005 INTEGER p5b_2 4006 INTEGER dim_common 4007 INTEGER dima_sort 4008 INTEGER dima 4009 INTEGER dimb_sort 4010 INTEGER dimb 4011 INTEGER l_a_sort 4012 INTEGER k_a_sort 4013 INTEGER l_a 4014 INTEGER k_a 4015 INTEGER l_b_sort 4016 INTEGER k_b_sort 4017 INTEGER l_b 4018 INTEGER k_b 4019 INTEGER nsubh(2) 4020 INTEGER isubh 4021 INTEGER l_c 4022 INTEGER k_c 4023 DOUBLE PRECISION FACTORIAL 4024 EXTERNAL NXTASK 4025 EXTERNAL FACTORIAL 4026 nprocs = GA_NNODES() 4027 count = 0 4028 next = NXTASK(nprocs, 1) 4029 DO p3b = noab+1,noab+nvab 4030 DO p8b = noab+1,noab+nvab 4031 IF (next.eq.count) THEN 4032 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1 4033 &).ne.4)) THEN 4034 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p8b-1)) THEN 4035 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p8b-1)) .eq. ieor(irrep_ 4036 &v,irrep_t)) THEN 4037 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1) 4038 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4039 & ERRQUIT('ipccsd_x2_3_3',0,MA_ERR) 4040 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4041 DO p5b = noab+1,noab+nvab 4042 DO h6b = 1,noab 4043 DO h7b = h6b,noab 4044 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 4045 &6b-1)+int_mb(k_spin+h7b-1)) THEN 4046 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 4047 &k_sym+h6b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_t) THEN 4048 CALL TCE_RESTRICTED_4(p3b,p5b,h6b,h7b,p3b_1,p5b_1,h6b_1,h7b_1) 4049 CALL TCE_RESTRICTED_4(h6b,h7b,p8b,p5b,h6b_2,h7b_2,p8b_2,p5b_2) 4050 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) * int_m 4051 &b(k_range+h7b-1) 4052 dima_sort = int_mb(k_range+p3b-1) 4053 dima = dim_common * dima_sort 4054 dimb_sort = int_mb(k_range+p8b-1) 4055 dimb = dim_common * dimb_sort 4056 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4057 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4058 & ERRQUIT('ipccsd_x2_3_3',1,MA_ERR) 4059 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4060 &ipccsd_x2_3_3',2,MA_ERR) 4061 IF ((p5b .lt. p3b)) THEN 4062 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 4063 & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 4064 &1 - noab - 1))))) 4065 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 4066 &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h7b-1) 4067 &,2,4,3,1,-1.0d0) 4068 END IF 4069 IF ((p3b .le. p5b)) THEN 4070 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 4071 & - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 4072 &1 - noab - 1))))) 4073 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4074 &,int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h7b-1) 4075 &,1,4,3,2,1.0d0) 4076 END IF 4077 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_3_3',3,MA_ERR) 4078 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4079 & ERRQUIT('ipccsd_x2_3_3',4,MA_ERR) 4080 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4081 &ipccsd_x2_3_3',5,MA_ERR) 4082 IF ((p5b .le. p8b)) THEN 4083 if(.not.intorb) then 4084 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 4085 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 4086 &+nvab) * (h6b_2 - 1))))) 4087 else 4088 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4089 &(p8b_2 4090 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 4091 &+nvab) * (h6b_2 - 1)))),p8b_2,p5b_2,h7b_2,h6b_2) 4092 end if 4093 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 4094 &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1) 4095 &,4,2,1,3,1.0d0) 4096 END IF 4097 IF ((p8b .lt. p5b)) THEN 4098 if(.not.intorb) then 4099 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 4100 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 4101 &+nvab) * (h6b_2 - 1))))) 4102 else 4103 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4104 &(p5b_2 4105 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 4106 &+nvab) * (h6b_2 - 1)))),p5b_2,p8b_2,h7b_2,h6b_2) 4107 end if 4108 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 4109 &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1) 4110 &,3,2,1,4,-1.0d0) 4111 END IF 4112 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_3_3',6,MA_ERR) 4113 nsubh(1) = 1 4114 nsubh(2) = 1 4115 isubh = 1 4116 IF (h6b .eq. h7b) THEN 4117 nsubh(isubh) = nsubh(isubh) + 1 4118 ELSE 4119 isubh = isubh + 1 4120 END IF 4121 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 4122 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 4123 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 4124 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_3_3',7,MA 4125 &_ERR) 4126 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_3_3',8,MA 4127 &_ERR) 4128 END IF 4129 END IF 4130 END IF 4131 END DO 4132 END DO 4133 END DO 4134 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4135 &ipccsd_x2_3_3',9,MA_ERR) 4136 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 4137 &,int_mb(k_range+p3b-1),2,1,1.0d0/2.0d0) 4138 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 4139 & noab - 1 + nvab * (p3b - noab - 1))) 4140 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_3_3',10,MA_ERR 4141 &) 4142 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_3_3',11,M 4143 &A_ERR) 4144 END IF 4145 END IF 4146 END IF 4147 next = NXTASK(nprocs, 1) 4148 END IF 4149 count = count + 1 4150 END DO 4151 END DO 4152 next = NXTASK(-nprocs, 1) 4153 call GA_SYNC() 4154 RETURN 4155 END 4156 SUBROUTINE ipccsd_x2_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 4157 &t) 4158C $Id$ 4159C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4160C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4161C i0 ( p3 p4 h1 h2 )_xv + = 1/2 * Sum ( h9 h10 ) * x ( p3 p4 h9 h10 )_x * i1 ( h9 h10 h1 h2 )_v 4162 IMPLICIT NONE 4163#include "global.fh" 4164#include "mafdecls.fh" 4165#include "sym.fh" 4166#include "errquit.fh" 4167#include "tce.fh" 4168 INTEGER d_a 4169 INTEGER k_a_offset 4170 INTEGER d_b 4171 INTEGER k_b_offset 4172 INTEGER d_c 4173 INTEGER k_c_offset 4174 INTEGER NXTASK 4175 INTEGER next 4176 INTEGER nprocs 4177 INTEGER count 4178 INTEGER p3b 4179 INTEGER p4b 4180 INTEGER h1b 4181 INTEGER h2b 4182 INTEGER dimc 4183 INTEGER l_c_sort 4184 INTEGER k_c_sort 4185 INTEGER h9b 4186 INTEGER h10b 4187 INTEGER p3b_1 4188 INTEGER p4b_1 4189 INTEGER h9b_1 4190 INTEGER h10b_1 4191 INTEGER h9b_2 4192 INTEGER h10b_2 4193 INTEGER h1b_2 4194 INTEGER h2b_2 4195 INTEGER dim_common 4196 INTEGER dima_sort 4197 INTEGER dima 4198 INTEGER dimb_sort 4199 INTEGER dimb 4200 INTEGER l_a_sort 4201 INTEGER k_a_sort 4202 INTEGER l_a 4203 INTEGER k_a 4204 INTEGER l_b_sort 4205 INTEGER k_b_sort 4206 INTEGER l_b 4207 INTEGER k_b 4208 INTEGER nsubh(2) 4209 INTEGER isubh 4210 INTEGER l_c 4211 INTEGER k_c 4212 DOUBLE PRECISION FACTORIAL 4213 EXTERNAL NXTASK 4214 EXTERNAL FACTORIAL 4215 nprocs = GA_NNODES() 4216 count = 0 4217 next = NXTASK(nprocs, 1) 4218 DO p3b = noab+1,noab+nvab 4219ckbn DO p4b = p3b,noab+nvab 4220 DO p4b = 1,1 4221 DO h1b = 1,noab 4222 DO h2b = h1b,noab 4223 IF (next.eq.count) THEN 4224ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 4225ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 4226 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ ip_unused_spin 4227 & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 4228ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 4229ckbn &1b-1)+int_mb(k_spin+h2b-1)) THEN 4230 IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h 4231 &1b-1)+int_mb(k_spin+h2b-1)) THEN 4232ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 4233ckbn &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH 4234ckbn &EN 4235 IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb( 4236 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH 4237 &EN 4238ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 4239ckbn &nge+h1b-1) * int_mb(k_range+h2b-1) 4240 dimc = int_mb(k_range+p3b-1) * 1 * int_mb(k_ra 4241 &nge+h1b-1) * int_mb(k_range+h2b-1) 4242 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4243 & ERRQUIT('ipccsd_x2_4',0,MA_ERR) 4244 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4245 DO h9b = 1,noab 4246 DO h10b = h9b,noab 4247ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 4248ckbn &9b-1)+int_mb(k_spin+h10b-1)) THEN 4249 IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h 4250 &9b-1)+int_mb(k_spin+h10b-1)) THEN 4251ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 4252ckbn &k_sym+h9b-1),int_mb(k_sym+h10b-1)))) .eq. irrep_x) THEN 4253 IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb( 4254 &k_sym+h9b-1),int_mb(k_sym+h10b-1)))) .eq. irrep_x) THEN 4255 CALL TCE_RESTRICTED_4(p3b,p4b,h9b,h10b,p3b_1,p4b_1,h9b_1,h10b_1) 4256 CALL TCE_RESTRICTED_4(h9b,h10b,h1b,h2b,h9b_2,h10b_2,h1b_2,h2b_2) 4257 dim_common = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) 4258ckbn dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) 4259 dima_sort = int_mb(k_range+p3b-1) * 1 4260 dima = dim_common * dima_sort 4261 dimb_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 4262 dimb = dim_common * dimb_sort 4263 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4264 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4265 & ERRQUIT('ipccsd_x2_4',1,MA_ERR) 4266 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4267 &ipccsd_x2_4',2,MA_ERR) 4268 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_ 4269 &1 - 1 + noab * (h9b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b 4270 &_1 - noab - 1))))) 4271ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4272ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h9b-1),int_mb(k_range+h10b-1 4273ckbn &),2,1,4,3,1.0d0) 4274 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4275 &,1,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1 4276 &),2,1,4,3,1.0d0) 4277 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4',3,MA_ERR) 4278 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4279 & ERRQUIT('ipccsd_x2_4',4,MA_ERR) 4280 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4281 &ipccsd_x2_4',5,MA_ERR) 4282 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 4283 & - 1 + noab * (h1b_2 - 1 + noab * (h10b_2 - 1 + noab * (h9b_2 - 1) 4284 &)))) 4285 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 4286 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 4287 &),4,3,2,1,1.0d0) 4288 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_4',6,MA_ERR) 4289 nsubh(1) = 1 4290 nsubh(2) = 1 4291 isubh = 1 4292 IF (h9b .eq. h10b) THEN 4293 nsubh(isubh) = nsubh(isubh) + 1 4294 ELSE 4295 isubh = isubh + 1 4296 END IF 4297 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 4298 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 4299 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 4300 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_4',7,MA_E 4301 &RR) 4302 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4',8,MA_E 4303 &RR) 4304 END IF 4305 END IF 4306 END IF 4307 END DO 4308 END DO 4309 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4310 &ipccsd_x2_4',9,MA_ERR) 4311ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 4312ckbn &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 4313ckbn &,4,3,2,1,1.0d0/2.0d0) 4314 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 4315 &,int_mb(k_range+h1b-1),1,int_mb(k_range+p3b-1) 4316 &,4,3,2,1,1.0d0/2.0d0) 4317 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 4318 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 4319 & - 1))))) 4320 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4',10,MA_ERR) 4321 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_4',11,MA_ 4322 &ERR) 4323 END IF 4324 END IF 4325 END IF 4326 next = NXTASK(nprocs, 1) 4327 END IF 4328 count = count + 1 4329 END DO 4330 END DO 4331 END DO 4332 END DO 4333 next = NXTASK(-nprocs, 1) 4334 call GA_SYNC() 4335 RETURN 4336 END 4337 SUBROUTINE ipccsd_x2_4_1(d_a,k_a_offset,d_c,k_c_offset) 4338C $Id$ 4339C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4340C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4341C i1 ( h9 h10 h1 h2 )_v + = 1 * v ( h9 h10 h1 h2 )_v 4342 IMPLICIT NONE 4343#include "global.fh" 4344#include "mafdecls.fh" 4345#include "sym.fh" 4346#include "errquit.fh" 4347#include "tce.fh" 4348 INTEGER d_a 4349 INTEGER k_a_offset 4350 INTEGER d_c 4351 INTEGER k_c_offset 4352 INTEGER NXTASK 4353 INTEGER next 4354 INTEGER nprocs 4355 INTEGER count 4356 INTEGER h9b 4357 INTEGER h10b 4358 INTEGER h1b 4359 INTEGER h2b 4360 INTEGER dimc 4361 INTEGER h9b_1 4362 INTEGER h10b_1 4363 INTEGER h1b_1 4364 INTEGER h2b_1 4365 INTEGER dim_common 4366 INTEGER dima_sort 4367 INTEGER dima 4368 INTEGER l_a_sort 4369 INTEGER k_a_sort 4370 INTEGER l_a 4371 INTEGER k_a 4372 INTEGER l_c 4373 INTEGER k_c 4374 EXTERNAL NXTASK 4375 nprocs = GA_NNODES() 4376 count = 0 4377 next = NXTASK(nprocs, 1) 4378 DO h9b = 1,noab 4379 DO h10b = h9b,noab 4380 DO h1b = 1,noab 4381 DO h2b = h1b,noab 4382 IF (next.eq.count) THEN 4383 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b- 4384 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 4385 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 4386 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 4387 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 4388 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 4389 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 4390 &ange+h1b-1) * int_mb(k_range+h2b-1) 4391 CALL TCE_RESTRICTED_4(h9b,h10b,h1b,h2b,h9b_1,h10b_1,h1b_1,h2b_1) 4392 dim_common = 1 4393 dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_m 4394 &b(k_range+h1b-1) * int_mb(k_range+h2b-1) 4395 dima = dim_common * dima_sort 4396 IF (dima .gt. 0) THEN 4397 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4398 & ERRQUIT('ipccsd_x2_4_1',0,MA_ERR) 4399 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4400 &ipccsd_x2_4_1',1,MA_ERR) 4401 if(.not.intorb) then 4402 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 4403 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 4404 &b+nvab) * (h9b_1 - 1))))) 4405 else 4406 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset), 4407 &(h2b_1 4408 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 4409 &b+nvab) * (h9b_1 - 1)))),h2b_1,h1b_1,h10b_1,h9b_1) 4410 end if 4411 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 4412 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 4413 &),4,3,2,1,1.0d0) 4414 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4_1',2,MA_ERR) 4415 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4416 &ipccsd_x2_4_1',3,MA_ERR) 4417 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 4418 &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h9b-1 4419 &),4,3,2,1,1.0d0) 4420 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 4421 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h9b - 1))))) 4422 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4_1',4,MA_ERR) 4423 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4_1',5,MA 4424 &_ERR) 4425 END IF 4426 END IF 4427 END IF 4428 END IF 4429 next = NXTASK(nprocs, 1) 4430 END IF 4431 count = count + 1 4432 END DO 4433 END DO 4434 END DO 4435 END DO 4436 next = NXTASK(-nprocs, 1) 4437 call GA_SYNC() 4438 RETURN 4439 END 4440 SUBROUTINE OFFSET_ipccsd_x2_4_1(l_a_offset,k_a_offset,size) 4441C $Id$ 4442C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4443C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4444C i1 ( h9 h10 h1 h2 )_v 4445 IMPLICIT NONE 4446#include "global.fh" 4447#include "mafdecls.fh" 4448#include "sym.fh" 4449#include "errquit.fh" 4450#include "tce.fh" 4451 INTEGER l_a_offset 4452 INTEGER k_a_offset 4453 INTEGER size 4454 INTEGER length 4455 INTEGER addr 4456 INTEGER h9b 4457 INTEGER h10b 4458 INTEGER h1b 4459 INTEGER h2b 4460 length = 0 4461 DO h9b = 1,noab 4462 DO h10b = h9b,noab 4463 DO h1b = 1,noab 4464 DO h2b = h1b,noab 4465 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 4466 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 4467 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 4468 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 4469 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b- 4470 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 4471 length = length + 1 4472 END IF 4473 END IF 4474 END IF 4475 END DO 4476 END DO 4477 END DO 4478 END DO 4479 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 4480 &set)) CALL ERRQUIT('ipccsd_x2_4_1',0,MA_ERR) 4481 int_mb(k_a_offset) = length 4482 addr = 0 4483 size = 0 4484 DO h9b = 1,noab 4485 DO h10b = h9b,noab 4486 DO h1b = 1,noab 4487 DO h2b = h1b,noab 4488 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 4489 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 4490 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 4491 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 4492 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b- 4493 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 4494 addr = addr + 1 4495 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h10b 4496 & - 1 + noab * (h9b - 1))) 4497 int_mb(k_a_offset+length+addr) = size 4498 size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int 4499 &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 4500 END IF 4501 END IF 4502 END IF 4503 END DO 4504 END DO 4505 END DO 4506 END DO 4507 RETURN 4508 END 4509 SUBROUTINE ipccsd_x2_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 4510 &set) 4511C $Id$ 4512C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4513C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4514C i1 ( h9 h10 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h9 h10 h2 p5 )_v 4515 IMPLICIT NONE 4516#include "global.fh" 4517#include "mafdecls.fh" 4518#include "sym.fh" 4519#include "errquit.fh" 4520#include "tce.fh" 4521 INTEGER d_a 4522 INTEGER k_a_offset 4523 INTEGER d_b 4524 INTEGER k_b_offset 4525 INTEGER d_c 4526 INTEGER k_c_offset 4527 INTEGER NXTASK 4528 INTEGER next 4529 INTEGER nprocs 4530 INTEGER count 4531 INTEGER h9b 4532 INTEGER h10b 4533 INTEGER h1b 4534 INTEGER h2b 4535 INTEGER dimc 4536 INTEGER l_c_sort 4537 INTEGER k_c_sort 4538 INTEGER p5b 4539 INTEGER p5b_1 4540 INTEGER h1b_1 4541 INTEGER h9b_2 4542 INTEGER h10b_2 4543 INTEGER h2b_2 4544 INTEGER p5b_2 4545 INTEGER dim_common 4546 INTEGER dima_sort 4547 INTEGER dima 4548 INTEGER dimb_sort 4549 INTEGER dimb 4550 INTEGER l_a_sort 4551 INTEGER k_a_sort 4552 INTEGER l_a 4553 INTEGER k_a 4554 INTEGER l_b_sort 4555 INTEGER k_b_sort 4556 INTEGER l_b 4557 INTEGER k_b 4558 INTEGER l_c 4559 INTEGER k_c 4560 EXTERNAL NXTASK 4561 nprocs = GA_NNODES() 4562 count = 0 4563 next = NXTASK(nprocs, 1) 4564 DO h9b = 1,noab 4565 DO h10b = h9b,noab 4566 DO h1b = 1,noab 4567 DO h2b = 1,noab 4568 IF (next.eq.count) THEN 4569 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b- 4570 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 4571 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 4572 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 4573 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 4574 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 4575 &HEN 4576 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 4577 &ange+h1b-1) * int_mb(k_range+h2b-1) 4578 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4579 & ERRQUIT('ipccsd_x2_4_2',0,MA_ERR) 4580 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4581 DO p5b = noab+1,noab+nvab 4582 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4583 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 4584 &EN 4585 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 4586 CALL TCE_RESTRICTED_4(h9b,h10b,h2b,p5b,h9b_2,h10b_2,h2b_2,p5b_2) 4587 dim_common = int_mb(k_range+p5b-1) 4588 dima_sort = int_mb(k_range+h1b-1) 4589 dima = dim_common * dima_sort 4590 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_m 4591 &b(k_range+h2b-1) 4592 dimb = dim_common * dimb_sort 4593 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4594 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4595 & ERRQUIT('ipccsd_x2_4_2',1,MA_ERR) 4596 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4597 &ipccsd_x2_4_2',2,MA_ERR) 4598 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 4599 & - 1 + noab * (p5b_1 - noab - 1))) 4600 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 4601 &,int_mb(k_range+h1b-1),2,1,1.0d0) 4602 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4_2',3,MA_ERR) 4603 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4604 & ERRQUIT('ipccsd_x2_4_2',4,MA_ERR) 4605 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4606 &ipccsd_x2_4_2',5,MA_ERR) 4607 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 4608 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h10b_2 - 1 + noab * (h9b 4609 &_2 - 1))))) 4610 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 4611 &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1 4612 &),3,2,1,4,1.0d0) 4613 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_4_2',6,MA_ERR) 4614 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4615 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4616 &t),dima_sort) 4617 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_4_2',7,MA 4618 &_ERR) 4619 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4_2',8,MA 4620 &_ERR) 4621 END IF 4622 END IF 4623 END IF 4624 END DO 4625 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4626 &ipccsd_x2_4_2',9,MA_ERR) 4627 IF ((h1b .le. h2b)) THEN 4628 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 4629 &,int_mb(k_range+h10b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1 4630 &),3,2,4,1,-1.0d0) 4631 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 4632 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h9b - 1))))) 4633 END IF 4634 IF ((h2b .le. h1b)) THEN 4635 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 4636 &,int_mb(k_range+h10b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1 4637 &),3,2,1,4,1.0d0) 4638 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 4639 & 1 + noab * (h2b - 1 + noab * (h10b - 1 + noab * (h9b - 1))))) 4640 END IF 4641 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4_2',10,MA_ERR 4642 &) 4643 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_4_2',11,M 4644 &A_ERR) 4645 END IF 4646 END IF 4647 END IF 4648 next = NXTASK(nprocs, 1) 4649 END IF 4650 count = count + 1 4651 END DO 4652 END DO 4653 END DO 4654 END DO 4655 next = NXTASK(-nprocs, 1) 4656 call GA_SYNC() 4657 RETURN 4658 END 4659 SUBROUTINE ipccsd_x2_4_2_1(d_a,k_a_offset,d_c,k_c_offset) 4660C $Id$ 4661C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4662C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4663C i2 ( h9 h10 h1 p5 )_v + = 1 * v ( h9 h10 h1 p5 )_v 4664 IMPLICIT NONE 4665#include "global.fh" 4666#include "mafdecls.fh" 4667#include "sym.fh" 4668#include "errquit.fh" 4669#include "tce.fh" 4670 INTEGER d_a 4671 INTEGER k_a_offset 4672 INTEGER d_c 4673 INTEGER k_c_offset 4674 INTEGER NXTASK 4675 INTEGER next 4676 INTEGER nprocs 4677 INTEGER count 4678 INTEGER h9b 4679 INTEGER h10b 4680 INTEGER h1b 4681 INTEGER p5b 4682 INTEGER dimc 4683 INTEGER h9b_1 4684 INTEGER h10b_1 4685 INTEGER h1b_1 4686 INTEGER p5b_1 4687 INTEGER dim_common 4688 INTEGER dima_sort 4689 INTEGER dima 4690 INTEGER l_a_sort 4691 INTEGER k_a_sort 4692 INTEGER l_a 4693 INTEGER k_a 4694 INTEGER l_c 4695 INTEGER k_c 4696 EXTERNAL NXTASK 4697 nprocs = GA_NNODES() 4698 count = 0 4699 next = NXTASK(nprocs, 1) 4700 DO h9b = 1,noab 4701 DO h10b = h9b,noab 4702 DO h1b = 1,noab 4703 DO p5b = noab+1,noab+nvab 4704 IF (next.eq.count) THEN 4705 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b- 4706 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 4707 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 4708 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 4709 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 4710 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 4711 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 4712 &ange+h1b-1) * int_mb(k_range+p5b-1) 4713 CALL TCE_RESTRICTED_4(h9b,h10b,h1b,p5b,h9b_1,h10b_1,h1b_1,p5b_1) 4714 dim_common = 1 4715 dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_m 4716 &b(k_range+h1b-1) * int_mb(k_range+p5b-1) 4717 dima = dim_common * dima_sort 4718 IF (dima .gt. 0) THEN 4719 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4720 & ERRQUIT('ipccsd_x2_4_2_1',0,MA_ERR) 4721 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4722 &ipccsd_x2_4_2_1',1,MA_ERR) 4723 IF ((h1b .le. p5b)) THEN 4724 if(.not.intorb) then 4725 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 4726 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 4727 &b+nvab) * (h9b_1 - 1))))) 4728 else 4729 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset), 4730 &(p5b_1 4731 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 4732 &b+nvab) * (h9b_1 - 1)))),p5b_1,h1b_1,h10b_1,h9b_1) 4733 end if 4734 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1) 4735 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1 4736 &),4,3,2,1,1.0d0) 4737 END IF 4738 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4_2_1',2,MA_ER 4739 &R) 4740 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4741 &ipccsd_x2_4_2_1',3,MA_ERR) 4742 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 4743 &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h9b-1 4744 &),4,3,2,1,1.0d0) 4745 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 4746 & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h9b - 1)) 4747 &))) 4748 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4_2_1',4,MA_ER 4749 &R) 4750 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4_2_1',5, 4751 &MA_ERR) 4752 END IF 4753 END IF 4754 END IF 4755 END IF 4756 next = NXTASK(nprocs, 1) 4757 END IF 4758 count = count + 1 4759 END DO 4760 END DO 4761 END DO 4762 END DO 4763 next = NXTASK(-nprocs, 1) 4764 call GA_SYNC() 4765 RETURN 4766 END 4767 SUBROUTINE OFFSET_ipccsd_x2_4_2_1(l_a_offset,k_a_offset,size) 4768C $Id$ 4769C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4770C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4771C i2 ( h9 h10 h1 p5 )_v 4772 IMPLICIT NONE 4773#include "global.fh" 4774#include "mafdecls.fh" 4775#include "sym.fh" 4776#include "errquit.fh" 4777#include "tce.fh" 4778 INTEGER l_a_offset 4779 INTEGER k_a_offset 4780 INTEGER size 4781 INTEGER length 4782 INTEGER addr 4783 INTEGER h9b 4784 INTEGER h10b 4785 INTEGER h1b 4786 INTEGER p5b 4787 length = 0 4788 DO h9b = 1,noab 4789 DO h10b = h9b,noab 4790 DO h1b = 1,noab 4791 DO p5b = noab+1,noab+nvab 4792 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 4793 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 4794 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 4795 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 4796 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b- 4797 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 4798 length = length + 1 4799 END IF 4800 END IF 4801 END IF 4802 END DO 4803 END DO 4804 END DO 4805 END DO 4806 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 4807 &set)) CALL ERRQUIT('ipccsd_x2_4_2_1',0,MA_ERR) 4808 int_mb(k_a_offset) = length 4809 addr = 0 4810 size = 0 4811 DO h9b = 1,noab 4812 DO h10b = h9b,noab 4813 DO h1b = 1,noab 4814 DO p5b = noab+1,noab+nvab 4815 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 4816 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 4817 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 4818 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 4819 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b- 4820 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 4821 addr = addr + 1 4822 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 4823 &* (h10b - 1 + noab * (h9b - 1))) 4824 int_mb(k_a_offset+length+addr) = size 4825 size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int 4826 &_mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 4827 END IF 4828 END IF 4829 END IF 4830 END DO 4831 END DO 4832 END DO 4833 END DO 4834 RETURN 4835 END 4836 SUBROUTINE ipccsd_x2_4_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o 4837 &ffset) 4838C $Id$ 4839C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4840C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4841C i2 ( h9 h10 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 h10 p5 p6 )_v 4842 IMPLICIT NONE 4843#include "global.fh" 4844#include "mafdecls.fh" 4845#include "sym.fh" 4846#include "errquit.fh" 4847#include "tce.fh" 4848 INTEGER d_a 4849 INTEGER k_a_offset 4850 INTEGER d_b 4851 INTEGER k_b_offset 4852 INTEGER d_c 4853 INTEGER k_c_offset 4854 INTEGER NXTASK 4855 INTEGER next 4856 INTEGER nprocs 4857 INTEGER count 4858 INTEGER h9b 4859 INTEGER h10b 4860 INTEGER h1b 4861 INTEGER p5b 4862 INTEGER dimc 4863 INTEGER l_c_sort 4864 INTEGER k_c_sort 4865 INTEGER p6b 4866 INTEGER p6b_1 4867 INTEGER h1b_1 4868 INTEGER h9b_2 4869 INTEGER h10b_2 4870 INTEGER p5b_2 4871 INTEGER p6b_2 4872 INTEGER dim_common 4873 INTEGER dima_sort 4874 INTEGER dima 4875 INTEGER dimb_sort 4876 INTEGER dimb 4877 INTEGER l_a_sort 4878 INTEGER k_a_sort 4879 INTEGER l_a 4880 INTEGER k_a 4881 INTEGER l_b_sort 4882 INTEGER k_b_sort 4883 INTEGER l_b 4884 INTEGER k_b 4885 INTEGER l_c 4886 INTEGER k_c 4887 EXTERNAL NXTASK 4888 nprocs = GA_NNODES() 4889 count = 0 4890 next = NXTASK(nprocs, 1) 4891 DO h9b = 1,noab 4892 DO h10b = h9b,noab 4893 DO h1b = 1,noab 4894 DO p5b = noab+1,noab+nvab 4895 IF (next.eq.count) THEN 4896 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b- 4897 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 4898 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 4899 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 4900 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 4901 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) T 4902 &HEN 4903 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 4904 &ange+h1b-1) * int_mb(k_range+p5b-1) 4905 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4906 & ERRQUIT('ipccsd_x2_4_2_2',0,MA_ERR) 4907 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4908 DO p6b = noab+1,noab+nvab 4909 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4910 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 4911 &EN 4912 CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1) 4913 CALL TCE_RESTRICTED_4(h9b,h10b,p5b,p6b,h9b_2,h10b_2,p5b_2,p6b_2) 4914 dim_common = int_mb(k_range+p6b-1) 4915 dima_sort = int_mb(k_range+h1b-1) 4916 dima = dim_common * dima_sort 4917 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_m 4918 &b(k_range+p5b-1) 4919 dimb = dim_common * dimb_sort 4920 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4921 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4922 & ERRQUIT('ipccsd_x2_4_2_2',1,MA_ERR) 4923 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4924 &ipccsd_x2_4_2_2',2,MA_ERR) 4925 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 4926 & - 1 + noab * (p6b_1 - noab - 1))) 4927 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 4928 &,int_mb(k_range+h1b-1),2,1,1.0d0) 4929 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4_2_2',3,MA_ER 4930 &R) 4931 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4932 & ERRQUIT('ipccsd_x2_4_2_2',4,MA_ERR) 4933 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4934 &ipccsd_x2_4_2_2',5,MA_ERR) 4935 IF ((p6b .lt. p5b)) THEN 4936 if(.not.intorb) then 4937 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 4938 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 4939 &b+nvab) * (h9b_2 - 1))))) 4940 else 4941 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4942 &(p5b_2 4943 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 4944 &b+nvab) * (h9b_2 - 1)))),p5b_2,p6b_2,h10b_2,h9b_2) 4945 end if 4946 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 4947 &,int_mb(k_range+h10b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1 4948 &),4,2,1,3,-1.0d0) 4949 END IF 4950 IF ((p5b .le. p6b)) THEN 4951 if(.not.intorb) then 4952 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 4953 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 4954 &b+nvab) * (h9b_2 - 1))))) 4955 else 4956 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 4957 &(p6b_2 4958 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 4959 &b+nvab) * (h9b_2 - 1)))),p6b_2,p5b_2,h10b_2,h9b_2) 4960 end if 4961 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 4962 &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 4963 &),3,2,1,4,1.0d0) 4964 END IF 4965 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_4_2_2',6,MA_ER 4966 &R) 4967 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4968 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4969 &t),dima_sort) 4970 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_4_2_2',7, 4971 &MA_ERR) 4972 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4_2_2',8, 4973 &MA_ERR) 4974 END IF 4975 END IF 4976 END IF 4977 END DO 4978 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4979 &ipccsd_x2_4_2_2',9,MA_ERR) 4980 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 4981 &,int_mb(k_range+h10b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1 4982 &),3,2,4,1,-1.0d0/2.0d0) 4983 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 4984 & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h9b - 1)) 4985 &))) 4986 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4_2_2',10,MA_E 4987 &RR) 4988 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_4_2_2',11 4989 &,MA_ERR) 4990 END IF 4991 END IF 4992 END IF 4993 next = NXTASK(nprocs, 1) 4994 END IF 4995 count = count + 1 4996 END DO 4997 END DO 4998 END DO 4999 END DO 5000 next = NXTASK(-nprocs, 1) 5001 call GA_SYNC() 5002 RETURN 5003 END 5004 SUBROUTINE ipccsd_x2_4_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 5005 &set) 5006C $Id$ 5007C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5008C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5009C i1 ( h9 h10 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 h10 p5 p6 )_v 5010 IMPLICIT NONE 5011#include "global.fh" 5012#include "mafdecls.fh" 5013#include "sym.fh" 5014#include "errquit.fh" 5015#include "tce.fh" 5016 INTEGER d_a 5017 INTEGER k_a_offset 5018 INTEGER d_b 5019 INTEGER k_b_offset 5020 INTEGER d_c 5021 INTEGER k_c_offset 5022 INTEGER NXTASK 5023 INTEGER next 5024 INTEGER nprocs 5025 INTEGER count 5026 INTEGER h9b 5027 INTEGER h10b 5028 INTEGER h1b 5029 INTEGER h2b 5030 INTEGER dimc 5031 INTEGER l_c_sort 5032 INTEGER k_c_sort 5033 INTEGER p5b 5034 INTEGER p6b 5035 INTEGER p5b_1 5036 INTEGER p6b_1 5037 INTEGER h1b_1 5038 INTEGER h2b_1 5039 INTEGER h9b_2 5040 INTEGER h10b_2 5041 INTEGER p5b_2 5042 INTEGER p6b_2 5043 INTEGER dim_common 5044 INTEGER dima_sort 5045 INTEGER dima 5046 INTEGER dimb_sort 5047 INTEGER dimb 5048 INTEGER l_a_sort 5049 INTEGER k_a_sort 5050 INTEGER l_a 5051 INTEGER k_a 5052 INTEGER l_b_sort 5053 INTEGER k_b_sort 5054 INTEGER l_b 5055 INTEGER k_b 5056 INTEGER nsuperp(2) 5057 INTEGER isuperp 5058 INTEGER l_c 5059 INTEGER k_c 5060 DOUBLE PRECISION FACTORIAL 5061 EXTERNAL NXTASK 5062 EXTERNAL FACTORIAL 5063 nprocs = GA_NNODES() 5064 count = 0 5065 next = NXTASK(nprocs, 1) 5066 DO h9b = 1,noab 5067 DO h10b = h9b,noab 5068 DO h1b = 1,noab 5069 DO h2b = h1b,noab 5070 IF (next.eq.count) THEN 5071 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b- 5072 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5073 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 5074 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 5075 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 5076 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 5077 &HEN 5078 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 5079 &ange+h1b-1) * int_mb(k_range+h2b-1) 5080 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5081 & ERRQUIT('ipccsd_x2_4_3',0,MA_ERR) 5082 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5083 DO p5b = noab+1,noab+nvab 5084 DO p6b = p5b,noab+nvab 5085 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 5086 &1b-1)+int_mb(k_spin+h2b-1)) THEN 5087 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 5088 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 5089 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1) 5090 CALL TCE_RESTRICTED_4(h9b,h10b,p5b,p6b,h9b_2,h10b_2,p5b_2,p6b_2) 5091 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) 5092 dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 5093 dima = dim_common * dima_sort 5094 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) 5095 dimb = dim_common * dimb_sort 5096 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5097 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5098 & ERRQUIT('ipccsd_x2_4_3',1,MA_ERR) 5099 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5100 &ipccsd_x2_4_3',2,MA_ERR) 5101 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 5102 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 5103 &1 - noab - 1))))) 5104 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 5105 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 5106 &,4,3,2,1,1.0d0) 5107 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4_3',3,MA_ERR) 5108 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5109 & ERRQUIT('ipccsd_x2_4_3',4,MA_ERR) 5110 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5111 &ipccsd_x2_4_3',5,MA_ERR) 5112 if(.not.intorb) then 5113 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 5114 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 5115 &b+nvab) * (h9b_2 - 1))))) 5116 else 5117 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 5118 &(p6b_2 5119 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 5120 &b+nvab) * (h9b_2 - 1)))),p6b_2,p5b_2,h10b_2,h9b_2) 5121 end if 5122 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 5123 &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 5124 &),2,1,4,3,1.0d0) 5125 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_4_3',6,MA_ERR) 5126 nsuperp(1) = 1 5127 nsuperp(2) = 1 5128 isuperp = 1 5129 IF (p5b .eq. p6b) THEN 5130 nsuperp(isuperp) = nsuperp(isuperp) + 1 5131 ELSE 5132 isuperp = isuperp + 1 5133 END IF 5134 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 5135 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 5136 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 5137 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_4_3',7,MA 5138 &_ERR) 5139 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4_3',8,MA 5140 &_ERR) 5141 END IF 5142 END IF 5143 END IF 5144 END DO 5145 END DO 5146 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5147 &ipccsd_x2_4_3',9,MA_ERR) 5148 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1 5149 &),int_mb(k_range+h9b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1 5150 &),2,1,4,3,1.0d0/2.0d0) 5151 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 5152 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h9b - 1))))) 5153 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4_3',10,MA_ERR 5154 &) 5155 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_4_3',11,M 5156 &A_ERR) 5157 END IF 5158 END IF 5159 END IF 5160 next = NXTASK(nprocs, 1) 5161 END IF 5162 count = count + 1 5163 END DO 5164 END DO 5165 END DO 5166 END DO 5167 next = NXTASK(-nprocs, 1) 5168 call GA_SYNC() 5169 RETURN 5170 END 5171 SUBROUTINE ipccsd_x2_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 5172 &t) 5173C $Id$ 5174C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5175C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5176C i0 ( p3 p4 h1 h2 )_xv + = -1 * P( 4 ) * Sum ( p8 h7 ) * x ( p3 p8 h1 h7 )_x * i1 ( h7 p4 h2 p8 )_v 5177 IMPLICIT NONE 5178#include "global.fh" 5179#include "mafdecls.fh" 5180#include "sym.fh" 5181#include "errquit.fh" 5182#include "tce.fh" 5183#include "stdio.fh" 5184 INTEGER d_a 5185 INTEGER k_a_offset 5186 INTEGER d_b 5187 INTEGER k_b_offset 5188 INTEGER d_c 5189 INTEGER k_c_offset 5190 INTEGER NXTASK 5191 INTEGER next 5192 INTEGER nprocs 5193 INTEGER count 5194 INTEGER p3b 5195 INTEGER p4b 5196 INTEGER h1b 5197 INTEGER h2b 5198 INTEGER dimc 5199 INTEGER l_c_sort 5200 INTEGER k_c_sort 5201 INTEGER p8b 5202 INTEGER h7b 5203 INTEGER p3b_1 5204 INTEGER p8b_1 5205 INTEGER h1b_1 5206 INTEGER h7b_1 5207 INTEGER p4b_2 5208 INTEGER h7b_2 5209 INTEGER h2b_2 5210 INTEGER p8b_2 5211 INTEGER dim_common 5212 INTEGER dima_sort 5213 INTEGER dima 5214 INTEGER dimb_sort 5215 INTEGER dimb 5216 INTEGER l_a_sort 5217 INTEGER k_a_sort 5218 INTEGER l_a 5219 INTEGER k_a 5220 INTEGER l_b_sort 5221 INTEGER k_b_sort 5222 INTEGER l_b 5223 INTEGER k_b 5224 INTEGER l_c 5225 INTEGER k_c 5226 EXTERNAL NXTASK 5227 nprocs = GA_NNODES() 5228 count = 0 5229 next = NXTASK(nprocs, 1) 5230ckbn DO p3b = noab+1,noab+nvab 5231 DO p3b = 1,1 5232 DO p4b = noab+1,noab+nvab 5233 DO h1b = 1,noab 5234 DO h2b = 1,noab 5235 IF (next.eq.count) THEN 5236ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 5237ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5238 IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p4b-1 5239 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5240ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 5241ckbn &1b-1)+int_mb(k_spin+h2b-1)) THEN 5242 IF (ip_unused_spin +int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 5243 &1b-1)+int_mb(k_spin+h2b-1)) THEN 5244ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 5245ckbn &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH 5246ckbn &EN 5247 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 5248 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH 5249 &EN 5250ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 5251ckbn &nge+h1b-1) * int_mb(k_range+h2b-1) 5252 dimc = 1 * int_mb(k_range+p4b-1) * int_mb(k_ra 5253 &nge+h1b-1) * int_mb(k_range+h2b-1) 5254 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5255 & ERRQUIT('ipccsd_x2_5',0,MA_ERR) 5256 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5257 DO p8b = noab+1,noab+nvab 5258 DO h7b = 1,noab 5259ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h 5260ckbn &1b-1)+int_mb(k_spin+h7b-1)) THEN 5261 IF (ip_unused_spin +int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h 5262 &1b-1)+int_mb(k_spin+h7b-1)) THEN 5263ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb( 5264ckbn &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN 5265 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p8b-1),ieor(int_mb( 5266 &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN 5267 CALL TCE_RESTRICTED_4(p3b,p8b,h1b,h7b,p3b_1,p8b_1,h1b_1,h7b_1) 5268 CALL TCE_RESTRICTED_4(p4b,h7b,h2b,p8b,p4b_2,h7b_2,h2b_2,p8b_2) 5269 dim_common = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 5270ckbn dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) 5271 dima_sort = 1 * int_mb(k_range+h1b-1) 5272 dima = dim_common * dima_sort 5273 dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h2b-1) 5274 dimb = dim_common * dimb_sort 5275 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5276 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5277 & ERRQUIT('ipccsd_x2_5',1,MA_ERR) 5278 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5279 &ipccsd_x2_5',2,MA_ERR) 5280c write(LuOut,*) "I am here 1." 5281c call util_flush(LuOut) 5282ckbn IF ((p8b .lt. p3b) .and. (h7b .lt. h1b)) THEN 5283 IF ( (h7b .lt. h1b)) THEN 5284 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 5285 & - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 5286 &1 - noab - 1))))) 5287ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 5288ckbn &,int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 5289ckbn &,4,2,3,1,1.0d0) 5290 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 5291 &,1,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 5292 &,4,2,3,1,1.0d0) 5293 END IF 5294c write(LuOut,*) "I am here 2." 5295c call util_flush(LuOut) 5296ckbn` IF ((p8b .lt. p3b) .and. (h1b .le. h7b)) THEN 5297 IF ( (h1b .le. h7b)) THEN 5298 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 5299 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 5300 &1 - noab - 1))))) 5301ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 5302ckbn &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1) 5303ckbn &,3,2,4,1,-1.0d0) 5304 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 5305 &,1,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1) 5306 &,3,2,4,1,-1.0d0) 5307 END IF 5308c write(LuOut,*) "I am here 2.1" 5309c call util_flush(LuOut) 5310ckbn IF ((p3b .le. p8b) .and. (h7b .lt. h1b)) THEN 5311ckbn CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 5312ckbn & - 1 + noab * (h7b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 5313ckbn &1 - noab - 1))))) 5314ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5315ckbn &,int_mb(k_range+p8b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 5316ckbn &,4,1,3,2,-1.0d0) 5317ckbn END IF 5318ckbn IF ((p3b .le. p8b) .and. (h1b .le. h7b)) THEN 5319ckbn CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 5320ckbn & - 1 + noab * (h1b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 5321ckbn &1 - noab - 1))))) 5322ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5323ckbn &,int_mb(k_range+p8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1) 5324ckbn &,3,1,4,2,1.0d0) 5325ckbn END IF 5326 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_5',3,MA_ERR) 5327 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5328 & ERRQUIT('ipccsd_x2_5',4,MA_ERR) 5329 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5330 &ipccsd_x2_5',5,MA_ERR) 5331 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 5332 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (p4b_ 5333 &2 - noab - 1))))) 5334 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 5335 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1) 5336 &,3,1,2,4,1.0d0) 5337 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_5',6,MA_ERR) 5338 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 5339 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 5340 &t),dima_sort) 5341 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_5',7,MA_E 5342 &RR) 5343 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_5',8,MA_E 5344 &RR) 5345 END IF 5346 END IF 5347 END IF 5348 END DO 5349 END DO 5350 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5351 &ipccsd_x2_5',9,MA_ERR) 5352ckbn IF ((p3b .le. p4b) .and. (h1b .le. h2b)) THEN 5353ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5354ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 5355ckbn &,4,2,3,1,-1.0d0) 5356ckbn CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 5357ckbn & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 5358ckbn & - 1))))) 5359ckbn END IF 5360ckbn IF ((p3b .le. p4b) .and. (h2b .le. h1b)) THEN 5361ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5362ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 5363ckbn &,4,2,1,3,1.0d0) 5364ckbn CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 5365ckbn & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 5366ckbn & - 1))))) 5367ckbn END IF 5368ckbn IF ((p4b .le. p3b) .and. (h1b .le. h2b)) THEN 5369c write(LuOut,*) "I am here 3." 5370c call util_flush(LuOut) 5371 IF ((h1b .le. h2b)) THEN 5372ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5373ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 5374ckbn &,2,4,3,1,1.0d0) 5375 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5376 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),1 5377 &,2,4,3,1,1.0d0) 5378 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 5379 & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 5380 & - 1))))) 5381 END IF 5382ckbn IF ((p4b .le. p3b) .and. (h2b .le. h1b)) THEN 5383 IF ( (h2b .le. h1b)) THEN 5384ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5385ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 5386ckbn &,2,4,1,3,-1.0d0) 5387 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5388 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),1 5389 &,2,4,1,3,-1.0d0) 5390 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 5391 & 1 + noab * (h2b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 5392 & - 1))))) 5393 END IF 5394c write(LuOut,*) "I am here 4." 5395c call util_flush(LuOut) 5396 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_5',10,MA_ERR) 5397 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_5',11,MA_ 5398 &ERR) 5399 END IF 5400 END IF 5401 END IF 5402 next = NXTASK(nprocs, 1) 5403 END IF 5404 count = count + 1 5405 END DO 5406 END DO 5407 END DO 5408 END DO 5409 next = NXTASK(-nprocs, 1) 5410 call GA_SYNC() 5411 RETURN 5412 END 5413 SUBROUTINE ipccsd_x2_5_1(d_a,k_a_offset,d_c,k_c_offset) 5414C $Id$ 5415C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5416C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5417C i1 ( h7 p3 h1 p8 )_v + = 1 * v ( h7 p3 h1 p8 )_v 5418 IMPLICIT NONE 5419#include "global.fh" 5420#include "mafdecls.fh" 5421#include "sym.fh" 5422#include "errquit.fh" 5423#include "tce.fh" 5424 INTEGER d_a 5425 INTEGER k_a_offset 5426 INTEGER d_c 5427 INTEGER k_c_offset 5428 INTEGER NXTASK 5429 INTEGER next 5430 INTEGER nprocs 5431 INTEGER count 5432 INTEGER p3b 5433 INTEGER h7b 5434 INTEGER h1b 5435 INTEGER p8b 5436 INTEGER dimc 5437 INTEGER p3b_1 5438 INTEGER h7b_1 5439 INTEGER h1b_1 5440 INTEGER p8b_1 5441 INTEGER dim_common 5442 INTEGER dima_sort 5443 INTEGER dima 5444 INTEGER l_a_sort 5445 INTEGER k_a_sort 5446 INTEGER l_a 5447 INTEGER k_a 5448 INTEGER l_c 5449 INTEGER k_c 5450 EXTERNAL NXTASK 5451 nprocs = GA_NNODES() 5452 count = 0 5453 next = NXTASK(nprocs, 1) 5454 DO p3b = noab+1,noab+nvab 5455 DO h7b = 1,noab 5456 DO h1b = 1,noab 5457 DO p8b = noab+1,noab+nvab 5458 IF (next.eq.count) THEN 5459 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h7b-1 5460 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN 5461 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 5462 &1b-1)+int_mb(k_spin+p8b-1)) THEN 5463 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 5464 &k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN 5465 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra 5466 &nge+h1b-1) * int_mb(k_range+p8b-1) 5467 CALL TCE_RESTRICTED_4(p3b,h7b,h1b,p8b,p3b_1,h7b_1,h1b_1,p8b_1) 5468 dim_common = 1 5469 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h7b-1) * int_mb 5470 &(k_range+h1b-1) * int_mb(k_range+p8b-1) 5471 dima = dim_common * dima_sort 5472 IF (dima .gt. 0) THEN 5473 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5474 & ERRQUIT('ipccsd_x2_5_1',0,MA_ERR) 5475 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5476 &ipccsd_x2_5_1',1,MA_ERR) 5477 IF ((h7b .le. p3b) .and. (h1b .le. p8b)) THEN 5478 if(.not.intorb) then 5479 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1 5480 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab 5481 &+nvab) * (h7b_1 - 1))))) 5482 else 5483 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset), 5484 &(p8b_1 5485 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab 5486 &+nvab) * (h7b_1 - 1)))),p8b_1,h1b_1,p3b_1,h7b_1) 5487 end if 5488 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 5489 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+p8b-1) 5490 &,4,3,1,2,1.0d0) 5491 END IF 5492 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_5_1',2,MA_ERR) 5493 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5494 &ipccsd_x2_5_1',3,MA_ERR) 5495 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 5496 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1) 5497 &,4,3,2,1,1.0d0) 5498 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 5499 & noab - 1 + nvab * (h1b - 1 + noab * (h7b - 1 + noab * (p3b - noab 5500 & - 1))))) 5501 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_5_1',4,MA_ERR) 5502 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_5_1',5,MA 5503 &_ERR) 5504 END IF 5505 END IF 5506 END IF 5507 END IF 5508 next = NXTASK(nprocs, 1) 5509 END IF 5510 count = count + 1 5511 END DO 5512 END DO 5513 END DO 5514 END DO 5515 next = NXTASK(-nprocs, 1) 5516 call GA_SYNC() 5517 RETURN 5518 END 5519 SUBROUTINE OFFSET_ipccsd_x2_5_1(l_a_offset,k_a_offset,size) 5520C $Id$ 5521C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5522C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5523C i1 ( h7 p3 h1 p8 )_v 5524 IMPLICIT NONE 5525#include "global.fh" 5526#include "mafdecls.fh" 5527#include "sym.fh" 5528#include "errquit.fh" 5529#include "tce.fh" 5530 INTEGER l_a_offset 5531 INTEGER k_a_offset 5532 INTEGER size 5533 INTEGER length 5534 INTEGER addr 5535 INTEGER p3b 5536 INTEGER h7b 5537 INTEGER h1b 5538 INTEGER p8b 5539 length = 0 5540 DO p3b = noab+1,noab+nvab 5541 DO h7b = 1,noab 5542 DO h1b = 1,noab 5543 DO p8b = noab+1,noab+nvab 5544 IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 5545 &1b-1)+int_mb(k_spin+p8b-1)) THEN 5546 IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 5547 &k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN 5548 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1 5549 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN 5550 length = length + 1 5551 END IF 5552 END IF 5553 END IF 5554 END DO 5555 END DO 5556 END DO 5557 END DO 5558 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 5559 &set)) CALL ERRQUIT('ipccsd_x2_5_1',0,MA_ERR) 5560 int_mb(k_a_offset) = length 5561 addr = 0 5562 size = 0 5563 DO p3b = noab+1,noab+nvab 5564 DO h7b = 1,noab 5565 DO h1b = 1,noab 5566 DO p8b = noab+1,noab+nvab 5567 IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 5568 &1b-1)+int_mb(k_spin+p8b-1)) THEN 5569 IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 5570 &k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN 5571 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1 5572 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN 5573 addr = addr + 1 5574 int_mb(k_a_offset+addr) = p8b - noab - 1 + nvab * (h1b - 1 + noab 5575 &* (h7b - 1 + noab * (p3b - noab - 1))) 5576 int_mb(k_a_offset+length+addr) = size 5577 size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h7b-1) * int_ 5578 &mb(k_range+h1b-1) * int_mb(k_range+p8b-1) 5579 END IF 5580 END IF 5581 END IF 5582 END DO 5583 END DO 5584 END DO 5585 END DO 5586 RETURN 5587 END 5588 SUBROUTINE ipccsd_x2_5_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 5589 &set) 5590C $Id$ 5591C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5592C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5593C i1 ( h7 p3 h1 p8 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h7 p3 p5 p8 )_v 5594 IMPLICIT NONE 5595#include "global.fh" 5596#include "mafdecls.fh" 5597#include "sym.fh" 5598#include "errquit.fh" 5599#include "tce.fh" 5600 INTEGER d_a 5601 INTEGER k_a_offset 5602 INTEGER d_b 5603 INTEGER k_b_offset 5604 INTEGER d_c 5605 INTEGER k_c_offset 5606 INTEGER NXTASK 5607 INTEGER next 5608 INTEGER nprocs 5609 INTEGER count 5610 INTEGER p3b 5611 INTEGER h7b 5612 INTEGER h1b 5613 INTEGER p8b 5614 INTEGER dimc 5615 INTEGER l_c_sort 5616 INTEGER k_c_sort 5617 INTEGER p5b 5618 INTEGER p5b_1 5619 INTEGER h1b_1 5620 INTEGER p3b_2 5621 INTEGER h7b_2 5622 INTEGER p8b_2 5623 INTEGER p5b_2 5624 INTEGER dim_common 5625 INTEGER dima_sort 5626 INTEGER dima 5627 INTEGER dimb_sort 5628 INTEGER dimb 5629 INTEGER l_a_sort 5630 INTEGER k_a_sort 5631 INTEGER l_a 5632 INTEGER k_a 5633 INTEGER l_b_sort 5634 INTEGER k_b_sort 5635 INTEGER l_b 5636 INTEGER k_b 5637 INTEGER l_c 5638 INTEGER k_c 5639 EXTERNAL NXTASK 5640 nprocs = GA_NNODES() 5641 count = 0 5642 next = NXTASK(nprocs, 1) 5643 DO p3b = noab+1,noab+nvab 5644 DO h7b = 1,noab 5645 DO h1b = 1,noab 5646 DO p8b = noab+1,noab+nvab 5647 IF (next.eq.count) THEN 5648 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h7b-1 5649 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN 5650 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 5651 &1b-1)+int_mb(k_spin+p8b-1)) THEN 5652 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 5653 &k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 5654 &EN 5655 dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra 5656 &nge+h1b-1) * int_mb(k_range+p8b-1) 5657 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5658 & ERRQUIT('ipccsd_x2_5_2',0,MA_ERR) 5659 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5660 DO p5b = noab+1,noab+nvab 5661 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 5662 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 5663 &EN 5664 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 5665 CALL TCE_RESTRICTED_4(p3b,h7b,p8b,p5b,p3b_2,h7b_2,p8b_2,p5b_2) 5666 dim_common = int_mb(k_range+p5b-1) 5667 dima_sort = int_mb(k_range+h1b-1) 5668 dima = dim_common * dima_sort 5669 dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h7b-1) * int_mb 5670 &(k_range+p8b-1) 5671 dimb = dim_common * dimb_sort 5672 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5673 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5674 & ERRQUIT('ipccsd_x2_5_2',1,MA_ERR) 5675 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5676 &ipccsd_x2_5_2',2,MA_ERR) 5677 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 5678 & - 1 + noab * (p5b_1 - noab - 1))) 5679 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 5680 &,int_mb(k_range+h1b-1),2,1,1.0d0) 5681 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_5_2',3,MA_ERR) 5682 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5683 & ERRQUIT('ipccsd_x2_5_2',4,MA_ERR) 5684 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5685 &ipccsd_x2_5_2',5,MA_ERR) 5686 IF ((h7b .le. p3b) .and. (p5b .le. p8b)) THEN 5687 if(.not.intorb) then 5688 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 5689 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 5690 &+nvab) * (h7b_2 - 1))))) 5691 else 5692 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 5693 &(p8b_2 5694 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 5695 &+nvab) * (h7b_2 - 1)))),p8b_2,p5b_2,p3b_2,h7b_2) 5696 end if 5697 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 5698 &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1) 5699 &,4,1,2,3,1.0d0) 5700 END IF 5701 IF ((h7b .le. p3b) .and. (p8b .lt. p5b)) THEN 5702 if(.not.intorb) then 5703 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 5704 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 5705 &+nvab) * (h7b_2 - 1))))) 5706 else 5707 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 5708 &(p5b_2 5709 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab 5710 &+nvab) * (h7b_2 - 1)))),p5b_2,p8b_2,p3b_2,h7b_2) 5711 end if 5712 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 5713 &,int_mb(k_range+p3b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1) 5714 &,3,1,2,4,-1.0d0) 5715 END IF 5716 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_5_2',6,MA_ERR) 5717 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 5718 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 5719 &t),dima_sort) 5720 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_5_2',7,MA 5721 &_ERR) 5722 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_5_2',8,MA 5723 &_ERR) 5724 END IF 5725 END IF 5726 END IF 5727 END DO 5728 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5729 &ipccsd_x2_5_2',9,MA_ERR) 5730 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1) 5731 &,int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) 5732 &,3,2,4,1,1.0d0) 5733 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b - 5734 & noab - 1 + nvab * (h1b - 1 + noab * (h7b - 1 + noab * (p3b - noab 5735 & - 1))))) 5736 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_5_2',10,MA_ERR 5737 &) 5738 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_5_2',11,M 5739 &A_ERR) 5740 END IF 5741 END IF 5742 END IF 5743 next = NXTASK(nprocs, 1) 5744 END IF 5745 count = count + 1 5746 END DO 5747 END DO 5748 END DO 5749 END DO 5750 next = NXTASK(-nprocs, 1) 5751 call GA_SYNC() 5752 RETURN 5753 END 5754 SUBROUTINE ipccsd_x2_6(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 5755 &t) 5756C $Id$ 5757C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5758C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5759C i0 ( p3 p4 h1 h2 )_vxt + = 1 * P( 2 ) * Sum ( h10 ) * t ( p3 h10 )_t * i1 ( h10 p4 h1 h2 )_vx 5760 IMPLICIT NONE 5761#include "global.fh" 5762#include "mafdecls.fh" 5763#include "sym.fh" 5764#include "errquit.fh" 5765#include "tce.fh" 5766 INTEGER d_a 5767 INTEGER k_a_offset 5768 INTEGER d_b 5769 INTEGER k_b_offset 5770 INTEGER d_c 5771 INTEGER k_c_offset 5772 INTEGER NXTASK 5773 INTEGER next 5774 INTEGER nprocs 5775 INTEGER count 5776 INTEGER p3b 5777 INTEGER p4b 5778 INTEGER h1b 5779 INTEGER h2b 5780 INTEGER dimc 5781 INTEGER l_c_sort 5782 INTEGER k_c_sort 5783 INTEGER h10b 5784 INTEGER p3b_1 5785 INTEGER h10b_1 5786 INTEGER p4b_2 5787 INTEGER h10b_2 5788 INTEGER h1b_2 5789 INTEGER h2b_2 5790 INTEGER dim_common 5791 INTEGER dima_sort 5792 INTEGER dima 5793 INTEGER dimb_sort 5794 INTEGER dimb 5795 INTEGER l_a_sort 5796 INTEGER k_a_sort 5797 INTEGER l_a 5798 INTEGER k_a 5799 INTEGER l_b_sort 5800 INTEGER k_b_sort 5801 INTEGER l_b 5802 INTEGER k_b 5803 INTEGER l_c 5804 INTEGER k_c 5805 EXTERNAL NXTASK 5806 nprocs = GA_NNODES() 5807 count = 0 5808 next = NXTASK(nprocs, 1) 5809 DO p3b = noab+1,noab+nvab 5810ckbn DO p4b = noab+1,noab+nvab 5811 DO p4b = 1,1 5812 DO h1b = 1,noab 5813 DO h2b = h1b,noab 5814 IF (next.eq.count) THEN 5815ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 5816ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5817 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ip_unused_spin 5818 & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5819ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 5820ckbn &1b-1)+int_mb(k_spin+h2b-1)) THEN 5821 IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h 5822 &1b-1)+int_mb(k_spin+h2b-1)) THEN 5823ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 5824ckbn &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x 5825ckbn &,irrep_t))) THEN 5826 IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb( 5827 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x 5828 &,irrep_t))) THEN 5829ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 5830ckbn &nge+h1b-1) * int_mb(k_range+h2b-1) 5831 dimc = int_mb(k_range+p3b-1) * 1 * int_mb(k_ra 5832 &nge+h1b-1) * int_mb(k_range+h2b-1) 5833 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5834 & ERRQUIT('ipccsd_x2_6',0,MA_ERR) 5835 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5836 DO h10b = 1,noab 5837 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h10b-1)) THEN 5838 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h10b-1)) .eq. irrep_t) T 5839 &HEN 5840 CALL TCE_RESTRICTED_2(p3b,h10b,p3b_1,h10b_1) 5841 CALL TCE_RESTRICTED_4(p4b,h10b,h1b,h2b,p4b_2,h10b_2,h1b_2,h2b_2) 5842 dim_common = int_mb(k_range+h10b-1) 5843 dima_sort = int_mb(k_range+p3b-1) 5844 dima = dim_common * dima_sort 5845ckbn dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1) * int_mb 5846ckbn &(k_range+h2b-1) 5847 dimb_sort = 1 * int_mb(k_range+h1b-1) * int_mb 5848 &(k_range+h2b-1) 5849 dimb = dim_common * dimb_sort 5850 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5851 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5852 & ERRQUIT('ipccsd_x2_6',1,MA_ERR) 5853 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5854 &ipccsd_x2_6',2,MA_ERR) 5855 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_ 5856 &1 - 1 + noab * (p3b_1 - noab - 1))) 5857 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5858 &,int_mb(k_range+h10b-1),1,2,1.0d0) 5859 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6',3,MA_ERR) 5860 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5861 & ERRQUIT('ipccsd_x2_6',4,MA_ERR) 5862 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5863 &ipccsd_x2_6',5,MA_ERR) 5864 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 5865 & - 1 + noab * (h1b_2 - 1 + noab * (h10b_2 - 1 + noab * (p4b_2 - no 5866 &ab - 1))))) 5867ckbn CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 5868ckbn &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 5869ckbn &),4,3,1,2,1.0d0) 5870 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),1 5871 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 5872 &),4,3,1,2,1.0d0) 5873 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6',6,MA_ERR) 5874 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 5875 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 5876 &t),dima_sort) 5877 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6',7,MA_E 5878 &RR) 5879 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6',8,MA_E 5880 &RR) 5881 END IF 5882 END IF 5883 END IF 5884 END DO 5885 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5886 &ipccsd_x2_6',9,MA_ERR) 5887ckbn IF ((p3b .le. p4b)) THEN 5888ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5889ckbn &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 5890ckbn &,4,3,2,1,1.0d0) 5891 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5892 &,int_mb(k_range+h1b-1),1,int_mb(k_range+p3b-1) 5893 &,4,3,2,1,1.0d0) 5894 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 5895 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 5896 & - 1))))) 5897ckbn END IF 5898ckbn IF ((p4b .le. p3b)) THEN 5899ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 5900ckbn &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 5901ckbn &,3,4,2,1,-1.0d0) 5902ckbn CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 5903ckbn & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 5904ckbn & - 1))))) 5905ckbn END IF 5906 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6',10,MA_ERR) 5907 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6',11,MA_ 5908 &ERR) 5909 END IF 5910 END IF 5911 END IF 5912 next = NXTASK(nprocs, 1) 5913 END IF 5914 count = count + 1 5915 END DO 5916 END DO 5917 END DO 5918 END DO 5919 next = NXTASK(-nprocs, 1) 5920 call GA_SYNC() 5921 RETURN 5922 END 5923 SUBROUTINE ipccsd_x2_6_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 5924 &set) 5925C $Id$ 5926C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5927C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5928C i1 ( h10 p3 h1 h2 )_vx + = -1 * Sum ( h8 ) * x ( p3 h8 )_x * i2 ( h8 h10 h1 h2 )_v 5929 IMPLICIT NONE 5930#include "global.fh" 5931#include "mafdecls.fh" 5932#include "sym.fh" 5933#include "errquit.fh" 5934#include "tce.fh" 5935 INTEGER d_a 5936 INTEGER k_a_offset 5937 INTEGER d_b 5938 INTEGER k_b_offset 5939 INTEGER d_c 5940 INTEGER k_c_offset 5941 INTEGER NXTASK 5942 INTEGER next 5943 INTEGER nprocs 5944 INTEGER count 5945 INTEGER p3b 5946 INTEGER h10b 5947 INTEGER h1b 5948 INTEGER h2b 5949 INTEGER dimc 5950 INTEGER l_c_sort 5951 INTEGER k_c_sort 5952 INTEGER h8b 5953 INTEGER p3b_1 5954 INTEGER h8b_1 5955 INTEGER h10b_2 5956 INTEGER h8b_2 5957 INTEGER h1b_2 5958 INTEGER h2b_2 5959 INTEGER dim_common 5960 INTEGER dima_sort 5961 INTEGER dima 5962 INTEGER dimb_sort 5963 INTEGER dimb 5964 INTEGER l_a_sort 5965 INTEGER k_a_sort 5966 INTEGER l_a 5967 INTEGER k_a 5968 INTEGER l_b_sort 5969 INTEGER k_b_sort 5970 INTEGER l_b 5971 INTEGER k_b 5972 INTEGER l_c 5973 INTEGER k_c 5974 EXTERNAL NXTASK 5975 nprocs = GA_NNODES() 5976 count = 0 5977 next = NXTASK(nprocs, 1) 5978ckbn DO p3b = noab+1,noab+nvab 5979 DO p3b = 1,1 5980 DO h10b = 1,noab 5981 DO h1b = 1,noab 5982 DO h2b = h1b,noab 5983 IF (next.eq.count) THEN 5984ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 5985ckbn &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5986 IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+h10b- 5987 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 5988ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 5989ckbn &h1b-1)+int_mb(k_spin+h2b-1)) THEN 5990 IF (ip_unused_spin +int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 5991 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 5992ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 5993ckbn &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T 5994ckbn &HEN 5995 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+h10b-1),ieor(int_mb 5996 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T 5997 &HEN 5998ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 5999ckbn &ange+h1b-1) * int_mb(k_range+h2b-1) 6000 dimc = 1 * int_mb(k_range+h10b-1) * int_mb(k_r 6001 &ange+h1b-1) * int_mb(k_range+h2b-1) 6002 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6003 & ERRQUIT('ipccsd_x2_6_1',0,MA_ERR) 6004 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6005 DO h8b = 1,noab 6006ckbn IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h8b-1)) THEN 6007 IF (ip_unused_spin .eq. int_mb(k_spin+h8b-1)) THEN 6008ckbn IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h8b-1)) .eq. irrep_x) TH 6009ckbn &EN 6010 IF (ieor(ip_unused_sym ,int_mb(k_sym+h8b-1)) .eq. irrep_x) TH 6011 &EN 6012 CALL TCE_RESTRICTED_2(p3b,h8b,p3b_1,h8b_1) 6013 CALL TCE_RESTRICTED_4(h10b,h8b,h1b,h2b,h10b_2,h8b_2,h1b_2,h2b_2) 6014 dim_common = int_mb(k_range+h8b-1) 6015ckbn dima_sort = int_mb(k_range+p3b-1) 6016 dima_sort = 1 6017 dima = dim_common * dima_sort 6018 dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h1b-1) * int_m 6019 &b(k_range+h2b-1) 6020 dimb = dim_common * dimb_sort 6021 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6022 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6023 & ERRQUIT('ipccsd_x2_6_1',1,MA_ERR) 6024 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6025 &ipccsd_x2_6_1',2,MA_ERR) 6026 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 6027 & - 1 + noab * (p3b_1 - noab - 1))) 6028ckbn CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 6029ckbn &,int_mb(k_range+h8b-1),1,2,1.0d0) 6030 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),1 6031 &,int_mb(k_range+h8b-1),1,2,1.0d0) 6032 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1',3,MA_ERR) 6033 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6034 & ERRQUIT('ipccsd_x2_6_1',4,MA_ERR) 6035 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6036 &ipccsd_x2_6_1',5,MA_ERR) 6037 IF ((h8b .le. h10b)) THEN 6038 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 6039 & - 1 + noab * (h1b_2 - 1 + noab * (h10b_2 - 1 + noab * (h8b_2 - 1) 6040 &)))) 6041 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 6042 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 6043 &),4,3,2,1,1.0d0) 6044 END IF 6045 IF ((h10b .lt. h8b)) THEN 6046 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2 6047 & - 1 + noab * (h1b_2 - 1 + noab * (h8b_2 - 1 + noab * (h10b_2 - 1) 6048 &)))) 6049 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 6050 &),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 6051 &),4,3,1,2,-1.0d0) 6052 END IF 6053 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_1',6,MA_ERR) 6054 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6055 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6056 &t),dima_sort) 6057 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_1',7,MA 6058 &_ERR) 6059 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1',8,MA 6060 &_ERR) 6061 END IF 6062 END IF 6063 END IF 6064 END DO 6065 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6066 &ipccsd_x2_6_1',9,MA_ERR) 6067ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6068ckbn &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+p3b-1 6069ckbn &),4,3,2,1,-1.0d0) 6070 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6071 &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),1 6072 & ,4,3,2,1,-1.0d0) 6073 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 6074 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 6075 &))) 6076 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1',10,MA_ERR 6077 &) 6078 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_1',11,M 6079 &A_ERR) 6080 END IF 6081 END IF 6082 END IF 6083 next = NXTASK(nprocs, 1) 6084 END IF 6085 count = count + 1 6086 END DO 6087 END DO 6088 END DO 6089 END DO 6090 next = NXTASK(-nprocs, 1) 6091 call GA_SYNC() 6092 RETURN 6093 END 6094 SUBROUTINE OFFSET_ipccsd_x2_6_1(l_a_offset,k_a_offset,size) 6095C $Id$ 6096C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6097C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6098C i1 ( h10 p3 h1 h2 )_vx 6099 IMPLICIT NONE 6100#include "global.fh" 6101#include "mafdecls.fh" 6102#include "sym.fh" 6103#include "errquit.fh" 6104#include "tce.fh" 6105 INTEGER l_a_offset 6106 INTEGER k_a_offset 6107 INTEGER size 6108 INTEGER length 6109 INTEGER addr 6110 INTEGER p3b 6111 INTEGER h10b 6112 INTEGER h1b 6113 INTEGER h2b 6114 length = 0 6115ckbn DO p3b = noab+1,noab+nvab 6116 DO p3b = 1,1 6117 DO h10b = 1,noab 6118 DO h1b = 1,noab 6119 DO h2b = h1b,noab 6120ckbn IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+ 6121ckbn &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6122 IF (int_mb(k_spin+h10b-1)+ ip_unused_spin .eq. int_mb(k_spin+ 6123 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6124ckbn IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb 6125ckbn &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T 6126ckbn &HEN 6127 IF (ieor(int_mb(k_sym+h10b-1),ieor(ip_unused_sym ,ieor(int_mb 6128 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T 6129 &HEN 6130ckbn IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b- 6131ckbn &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6132 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+ ip_unused_spin 6133 & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6134 length = length + 1 6135 END IF 6136 END IF 6137 END IF 6138 END DO 6139 END DO 6140 END DO 6141 END DO 6142 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 6143 &set)) CALL ERRQUIT('ipccsd_x2_6_1',0,MA_ERR) 6144 int_mb(k_a_offset) = length 6145 addr = 0 6146 size = 0 6147ckbn DO p3b = noab+1,noab+nvab 6148 DO p3b = 1,1 6149 DO h10b = 1,noab 6150 DO h1b = 1,noab 6151 DO h2b = h1b,noab 6152ckbn IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+ 6153ckbn &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6154 IF (int_mb(k_spin+h10b-1)+ip_unused_spin .eq. int_mb(k_spin+ 6155 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6156ckbn IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb 6157ckbn &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T 6158ckbn &HEN 6159 IF (ieor(int_mb(k_sym+h10b-1),ieor(ip_unused_sym ,ieor(int_mb 6160 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T 6161 &HEN 6162ckbn IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b- 6163ckbn &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6164 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+ip_unused_spin 6165 & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6166 addr = addr + 1 6167 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h10b 6168 & - 1 + noab * (p3b - noab - 1))) 6169 int_mb(k_a_offset+length+addr) = size 6170ckbn size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int 6171ckbn &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 6172 size = size + 1 * int_mb(k_range+h10b-1) * int 6173 &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 6174 END IF 6175 END IF 6176 END IF 6177 END DO 6178 END DO 6179 END DO 6180 END DO 6181 RETURN 6182 END 6183 SUBROUTINE ipccsd_x2_6_1_1(d_a,k_a_offset,d_c,k_c_offset) 6184C $Id$ 6185C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6186C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6187C i2 ( h8 h10 h1 h2 )_v + = 1 * v ( h8 h10 h1 h2 )_v 6188 IMPLICIT NONE 6189#include "global.fh" 6190#include "mafdecls.fh" 6191#include "sym.fh" 6192#include "errquit.fh" 6193#include "tce.fh" 6194 INTEGER d_a 6195 INTEGER k_a_offset 6196 INTEGER d_c 6197 INTEGER k_c_offset 6198 INTEGER NXTASK 6199 INTEGER next 6200 INTEGER nprocs 6201 INTEGER count 6202 INTEGER h8b 6203 INTEGER h10b 6204 INTEGER h1b 6205 INTEGER h2b 6206 INTEGER dimc 6207 INTEGER h8b_1 6208 INTEGER h10b_1 6209 INTEGER h1b_1 6210 INTEGER h2b_1 6211 INTEGER dim_common 6212 INTEGER dima_sort 6213 INTEGER dima 6214 INTEGER l_a_sort 6215 INTEGER k_a_sort 6216 INTEGER l_a 6217 INTEGER k_a 6218 INTEGER l_c 6219 INTEGER k_c 6220 EXTERNAL NXTASK 6221 nprocs = GA_NNODES() 6222 count = 0 6223 next = NXTASK(nprocs, 1) 6224 DO h8b = 1,noab 6225 DO h10b = h8b,noab 6226 DO h1b = 1,noab 6227 DO h2b = h1b,noab 6228 IF (next.eq.count) THEN 6229 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 6230 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6231 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 6232 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6233 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 6234 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 6235 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 6236 &ange+h1b-1) * int_mb(k_range+h2b-1) 6237 CALL TCE_RESTRICTED_4(h8b,h10b,h1b,h2b,h8b_1,h10b_1,h1b_1,h2b_1) 6238 dim_common = 1 6239 dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m 6240 &b(k_range+h1b-1) * int_mb(k_range+h2b-1) 6241 dima = dim_common * dima_sort 6242 IF (dima .gt. 0) THEN 6243 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6244 & ERRQUIT('ipccsd_x2_6_1_1',0,MA_ERR) 6245 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6246 &ipccsd_x2_6_1_1',1,MA_ERR) 6247 if(.not.intorb) then 6248 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 6249 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 6250 &b+nvab) * (h8b_1 - 1))))) 6251 else 6252 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset), 6253 &(h2b_1 6254 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 6255 &b+nvab) * (h8b_1 - 1)))),h2b_1,h1b_1,h10b_1,h8b_1) 6256 end if 6257 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1) 6258 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1 6259 &),4,3,2,1,1.0d0) 6260 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1_1',2,MA_ER 6261 &R) 6262 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6263 &ipccsd_x2_6_1_1',3,MA_ERR) 6264 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6265 &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h8b-1 6266 &),4,3,2,1,1.0d0) 6267 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 6268 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1))))) 6269 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1_1',4,MA_ER 6270 &R) 6271 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1_1',5, 6272 &MA_ERR) 6273 END IF 6274 END IF 6275 END IF 6276 END IF 6277 next = NXTASK(nprocs, 1) 6278 END IF 6279 count = count + 1 6280 END DO 6281 END DO 6282 END DO 6283 END DO 6284 next = NXTASK(-nprocs, 1) 6285 call GA_SYNC() 6286 RETURN 6287 END 6288 SUBROUTINE OFFSET_ipccsd_x2_6_1_1(l_a_offset,k_a_offset,size) 6289C $Id$ 6290C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6291C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6292C i2 ( h8 h10 h1 h2 )_v 6293 IMPLICIT NONE 6294#include "global.fh" 6295#include "mafdecls.fh" 6296#include "sym.fh" 6297#include "errquit.fh" 6298#include "tce.fh" 6299 INTEGER l_a_offset 6300 INTEGER k_a_offset 6301 INTEGER size 6302 INTEGER length 6303 INTEGER addr 6304 INTEGER h8b 6305 INTEGER h10b 6306 INTEGER h1b 6307 INTEGER h2b 6308 length = 0 6309 DO h8b = 1,noab 6310 DO h10b = h8b,noab 6311 DO h1b = 1,noab 6312 DO h2b = h1b,noab 6313 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 6314 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6315 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 6316 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 6317 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 6318 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6319 length = length + 1 6320 END IF 6321 END IF 6322 END IF 6323 END DO 6324 END DO 6325 END DO 6326 END DO 6327 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 6328 &set)) CALL ERRQUIT('ipccsd_x2_6_1_1',0,MA_ERR) 6329 int_mb(k_a_offset) = length 6330 addr = 0 6331 size = 0 6332 DO h8b = 1,noab 6333 DO h10b = h8b,noab 6334 DO h1b = 1,noab 6335 DO h2b = h1b,noab 6336 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 6337 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6338 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 6339 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN 6340 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 6341 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6342 addr = addr + 1 6343 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h10b 6344 & - 1 + noab * (h8b - 1))) 6345 int_mb(k_a_offset+length+addr) = size 6346 size = size + int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int 6347 &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 6348 END IF 6349 END IF 6350 END IF 6351 END DO 6352 END DO 6353 END DO 6354 END DO 6355 RETURN 6356 END 6357 SUBROUTINE ipccsd_x2_6_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o 6358 &ffset) 6359C $Id$ 6360C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6361C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6362C i2 ( h8 h10 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i3 ( h8 h10 h2 p5 )_v 6363 IMPLICIT NONE 6364#include "global.fh" 6365#include "mafdecls.fh" 6366#include "sym.fh" 6367#include "errquit.fh" 6368#include "tce.fh" 6369 INTEGER d_a 6370 INTEGER k_a_offset 6371 INTEGER d_b 6372 INTEGER k_b_offset 6373 INTEGER d_c 6374 INTEGER k_c_offset 6375 INTEGER NXTASK 6376 INTEGER next 6377 INTEGER nprocs 6378 INTEGER count 6379 INTEGER h8b 6380 INTEGER h10b 6381 INTEGER h1b 6382 INTEGER h2b 6383 INTEGER dimc 6384 INTEGER l_c_sort 6385 INTEGER k_c_sort 6386 INTEGER p5b 6387 INTEGER p5b_1 6388 INTEGER h1b_1 6389 INTEGER h8b_2 6390 INTEGER h10b_2 6391 INTEGER h2b_2 6392 INTEGER p5b_2 6393 INTEGER dim_common 6394 INTEGER dima_sort 6395 INTEGER dima 6396 INTEGER dimb_sort 6397 INTEGER dimb 6398 INTEGER l_a_sort 6399 INTEGER k_a_sort 6400 INTEGER l_a 6401 INTEGER k_a 6402 INTEGER l_b_sort 6403 INTEGER k_b_sort 6404 INTEGER l_b 6405 INTEGER k_b 6406 INTEGER l_c 6407 INTEGER k_c 6408 EXTERNAL NXTASK 6409 nprocs = GA_NNODES() 6410 count = 0 6411 next = NXTASK(nprocs, 1) 6412 DO h8b = 1,noab 6413 DO h10b = h8b,noab 6414 DO h1b = 1,noab 6415 DO h2b = 1,noab 6416 IF (next.eq.count) THEN 6417 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 6418 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6419 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 6420 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6421 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 6422 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 6423 &HEN 6424 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 6425 &ange+h1b-1) * int_mb(k_range+h2b-1) 6426 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6427 & ERRQUIT('ipccsd_x2_6_1_2',0,MA_ERR) 6428 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6429 DO p5b = noab+1,noab+nvab 6430 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 6431 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 6432 &EN 6433 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 6434 CALL TCE_RESTRICTED_4(h8b,h10b,h2b,p5b,h8b_2,h10b_2,h2b_2,p5b_2) 6435 dim_common = int_mb(k_range+p5b-1) 6436 dima_sort = int_mb(k_range+h1b-1) 6437 dima = dim_common * dima_sort 6438 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m 6439 &b(k_range+h2b-1) 6440 dimb = dim_common * dimb_sort 6441 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6442 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6443 & ERRQUIT('ipccsd_x2_6_1_2',1,MA_ERR) 6444 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6445 &ipccsd_x2_6_1_2',2,MA_ERR) 6446 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 6447 & - 1 + noab * (p5b_1 - noab - 1))) 6448 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 6449 &,int_mb(k_range+h1b-1),2,1,1.0d0) 6450 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1_2',3,MA_ER 6451 &R) 6452 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6453 & ERRQUIT('ipccsd_x2_6_1_2',4,MA_ERR) 6454 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6455 &ipccsd_x2_6_1_2',5,MA_ERR) 6456 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 6457 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h10b_2 - 1 + noab * (h8b 6458 &_2 - 1))))) 6459 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 6460 &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1 6461 &),3,2,1,4,1.0d0) 6462 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_1_2',6,MA_ER 6463 &R) 6464 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6465 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6466 &t),dima_sort) 6467 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2',7, 6468 &MA_ERR) 6469 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2',8, 6470 &MA_ERR) 6471 END IF 6472 END IF 6473 END IF 6474 END DO 6475 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6476 &ipccsd_x2_6_1_2',9,MA_ERR) 6477 IF ((h1b .le. h2b)) THEN 6478 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6479 &,int_mb(k_range+h10b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1 6480 &),3,2,4,1,-1.0d0) 6481 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 6482 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1))))) 6483 END IF 6484 IF ((h2b .le. h1b)) THEN 6485 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 6486 &,int_mb(k_range+h10b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1 6487 &),3,2,1,4,1.0d0) 6488 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 6489 & 1 + noab * (h2b - 1 + noab * (h10b - 1 + noab * (h8b - 1))))) 6490 END IF 6491 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1_2',10,MA_E 6492 &RR) 6493 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2',11 6494 &,MA_ERR) 6495 END IF 6496 END IF 6497 END IF 6498 next = NXTASK(nprocs, 1) 6499 END IF 6500 count = count + 1 6501 END DO 6502 END DO 6503 END DO 6504 END DO 6505 next = NXTASK(-nprocs, 1) 6506 call GA_SYNC() 6507 RETURN 6508 END 6509 SUBROUTINE ipccsd_x2_6_1_2_1(d_a,k_a_offset,d_c,k_c_offset) 6510C $Id$ 6511C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6512C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6513C i3 ( h8 h10 h1 p5 )_v + = 1 * v ( h8 h10 h1 p5 )_v 6514 IMPLICIT NONE 6515#include "global.fh" 6516#include "mafdecls.fh" 6517#include "sym.fh" 6518#include "errquit.fh" 6519#include "tce.fh" 6520 INTEGER d_a 6521 INTEGER k_a_offset 6522 INTEGER d_c 6523 INTEGER k_c_offset 6524 INTEGER NXTASK 6525 INTEGER next 6526 INTEGER nprocs 6527 INTEGER count 6528 INTEGER h8b 6529 INTEGER h10b 6530 INTEGER h1b 6531 INTEGER p5b 6532 INTEGER dimc 6533 INTEGER h8b_1 6534 INTEGER h10b_1 6535 INTEGER h1b_1 6536 INTEGER p5b_1 6537 INTEGER dim_common 6538 INTEGER dima_sort 6539 INTEGER dima 6540 INTEGER l_a_sort 6541 INTEGER k_a_sort 6542 INTEGER l_a 6543 INTEGER k_a 6544 INTEGER l_c 6545 INTEGER k_c 6546 EXTERNAL NXTASK 6547 nprocs = GA_NNODES() 6548 count = 0 6549 next = NXTASK(nprocs, 1) 6550 DO h8b = 1,noab 6551 DO h10b = h8b,noab 6552 DO h1b = 1,noab 6553 DO p5b = noab+1,noab+nvab 6554 IF (next.eq.count) THEN 6555 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 6556 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 6557 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 6558 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 6559 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 6560 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 6561 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 6562 &ange+h1b-1) * int_mb(k_range+p5b-1) 6563 CALL TCE_RESTRICTED_4(h8b,h10b,h1b,p5b,h8b_1,h10b_1,h1b_1,p5b_1) 6564 dim_common = 1 6565 dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m 6566 &b(k_range+h1b-1) * int_mb(k_range+p5b-1) 6567 dima = dim_common * dima_sort 6568 IF (dima .gt. 0) THEN 6569 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6570 & ERRQUIT('ipccsd_x2_6_1_2_1',0,MA_ERR) 6571 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6572 &ipccsd_x2_6_1_2_1',1,MA_ERR) 6573 IF ((h1b .le. p5b)) THEN 6574 if(.not.intorb) then 6575 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 6576 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 6577 &b+nvab) * (h8b_1 - 1))))) 6578 else 6579 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset), 6580 &(p5b_1 6581 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 6582 &b+nvab) * (h8b_1 - 1)))),p5b_1,h1b_1,h10b_1,h8b_1) 6583 end if 6584 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1) 6585 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1 6586 &),4,3,2,1,1.0d0) 6587 END IF 6588 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1_2_1',2,MA_ 6589 &ERR) 6590 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6591 &ipccsd_x2_6_1_2_1',3,MA_ERR) 6592 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 6593 &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h8b-1 6594 &),4,3,2,1,1.0d0) 6595 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 6596 & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1)) 6597 &))) 6598 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1_2_1',4,MA_ 6599 &ERR) 6600 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2_1', 6601 &5,MA_ERR) 6602 END IF 6603 END IF 6604 END IF 6605 END IF 6606 next = NXTASK(nprocs, 1) 6607 END IF 6608 count = count + 1 6609 END DO 6610 END DO 6611 END DO 6612 END DO 6613 next = NXTASK(-nprocs, 1) 6614 call GA_SYNC() 6615 RETURN 6616 END 6617 SUBROUTINE OFFSET_ipccsd_x2_6_1_2_1(l_a_offset,k_a_offset,size) 6618C $Id$ 6619C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6620C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6621C i3 ( h8 h10 h1 p5 )_v 6622 IMPLICIT NONE 6623#include "global.fh" 6624#include "mafdecls.fh" 6625#include "sym.fh" 6626#include "errquit.fh" 6627#include "tce.fh" 6628 INTEGER l_a_offset 6629 INTEGER k_a_offset 6630 INTEGER size 6631 INTEGER length 6632 INTEGER addr 6633 INTEGER h8b 6634 INTEGER h10b 6635 INTEGER h1b 6636 INTEGER p5b 6637 length = 0 6638 DO h8b = 1,noab 6639 DO h10b = h8b,noab 6640 DO h1b = 1,noab 6641 DO p5b = noab+1,noab+nvab 6642 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 6643 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 6644 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 6645 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 6646 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 6647 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 6648 length = length + 1 6649 END IF 6650 END IF 6651 END IF 6652 END DO 6653 END DO 6654 END DO 6655 END DO 6656 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 6657 &set)) CALL ERRQUIT('ipccsd_x2_6_1_2_1',0,MA_ERR) 6658 int_mb(k_a_offset) = length 6659 addr = 0 6660 size = 0 6661 DO h8b = 1,noab 6662 DO h10b = h8b,noab 6663 DO h1b = 1,noab 6664 DO p5b = noab+1,noab+nvab 6665 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 6666 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 6667 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 6668 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN 6669 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 6670 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 6671 addr = addr + 1 6672 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 6673 &* (h10b - 1 + noab * (h8b - 1))) 6674 int_mb(k_a_offset+length+addr) = size 6675 size = size + int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int 6676 &_mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 6677 END IF 6678 END IF 6679 END IF 6680 END DO 6681 END DO 6682 END DO 6683 END DO 6684 RETURN 6685 END 6686 SUBROUTINE ipccsd_x2_6_1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c 6687 &_offset) 6688C $Id$ 6689C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6690C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6691C i3 ( h8 h10 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h8 h10 p5 p6 )_v 6692 IMPLICIT NONE 6693#include "global.fh" 6694#include "mafdecls.fh" 6695#include "sym.fh" 6696#include "errquit.fh" 6697#include "tce.fh" 6698 INTEGER d_a 6699 INTEGER k_a_offset 6700 INTEGER d_b 6701 INTEGER k_b_offset 6702 INTEGER d_c 6703 INTEGER k_c_offset 6704 INTEGER NXTASK 6705 INTEGER next 6706 INTEGER nprocs 6707 INTEGER count 6708 INTEGER h8b 6709 INTEGER h10b 6710 INTEGER h1b 6711 INTEGER p5b 6712 INTEGER dimc 6713 INTEGER l_c_sort 6714 INTEGER k_c_sort 6715 INTEGER p6b 6716 INTEGER p6b_1 6717 INTEGER h1b_1 6718 INTEGER h8b_2 6719 INTEGER h10b_2 6720 INTEGER p5b_2 6721 INTEGER p6b_2 6722 INTEGER dim_common 6723 INTEGER dima_sort 6724 INTEGER dima 6725 INTEGER dimb_sort 6726 INTEGER dimb 6727 INTEGER l_a_sort 6728 INTEGER k_a_sort 6729 INTEGER l_a 6730 INTEGER k_a 6731 INTEGER l_b_sort 6732 INTEGER k_b_sort 6733 INTEGER l_b 6734 INTEGER k_b 6735 INTEGER l_c 6736 INTEGER k_c 6737 EXTERNAL NXTASK 6738 nprocs = GA_NNODES() 6739 count = 0 6740 next = NXTASK(nprocs, 1) 6741 DO h8b = 1,noab 6742 DO h10b = h8b,noab 6743 DO h1b = 1,noab 6744 DO p5b = noab+1,noab+nvab 6745 IF (next.eq.count) THEN 6746 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 6747 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 6748 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 6749 &h1b-1)+int_mb(k_spin+p5b-1)) THEN 6750 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 6751 &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) T 6752 &HEN 6753 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 6754 &ange+h1b-1) * int_mb(k_range+p5b-1) 6755 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6756 & ERRQUIT('ipccsd_x2_6_1_2_2',0,MA_ERR) 6757 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6758 DO p6b = noab+1,noab+nvab 6759 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 6760 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 6761 &EN 6762 CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1) 6763 CALL TCE_RESTRICTED_4(h8b,h10b,p5b,p6b,h8b_2,h10b_2,p5b_2,p6b_2) 6764 dim_common = int_mb(k_range+p6b-1) 6765 dima_sort = int_mb(k_range+h1b-1) 6766 dima = dim_common * dima_sort 6767 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m 6768 &b(k_range+p5b-1) 6769 dimb = dim_common * dimb_sort 6770 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6771 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6772 & ERRQUIT('ipccsd_x2_6_1_2_2',1,MA_ERR) 6773 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6774 &ipccsd_x2_6_1_2_2',2,MA_ERR) 6775 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 6776 & - 1 + noab * (p6b_1 - noab - 1))) 6777 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 6778 &,int_mb(k_range+h1b-1),2,1,1.0d0) 6779 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1_2_2',3,MA_ 6780 &ERR) 6781 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6782 & ERRQUIT('ipccsd_x2_6_1_2_2',4,MA_ERR) 6783 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6784 &ipccsd_x2_6_1_2_2',5,MA_ERR) 6785 IF ((p6b .lt. p5b)) THEN 6786 if(.not.intorb) then 6787 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 6788 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 6789 &b+nvab) * (h8b_2 - 1))))) 6790 else 6791 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 6792 &(p5b_2 6793 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 6794 &b+nvab) * (h8b_2 - 1)))),p5b_2,p6b_2,h10b_2,h8b_2) 6795 end if 6796 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 6797 &,int_mb(k_range+h10b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1 6798 &),4,2,1,3,-1.0d0) 6799 END IF 6800 IF ((p5b .le. p6b)) THEN 6801 if(.not.intorb) then 6802 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 6803 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 6804 &b+nvab) * (h8b_2 - 1))))) 6805 else 6806 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 6807 &(p6b_2 6808 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 6809 &b+nvab) * (h8b_2 - 1)))),p6b_2,p5b_2,h10b_2,h8b_2) 6810 end if 6811 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 6812 &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 6813 &),3,2,1,4,1.0d0) 6814 END IF 6815 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_1_2_2',6,MA_ 6816 &ERR) 6817 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6818 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6819 &t),dima_sort) 6820 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2_2', 6821 &7,MA_ERR) 6822 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2_2', 6823 &8,MA_ERR) 6824 END IF 6825 END IF 6826 END IF 6827 END DO 6828 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6829 &ipccsd_x2_6_1_2_2',9,MA_ERR) 6830 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 6831 &,int_mb(k_range+h10b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1 6832 &),3,2,4,1,-1.0d0/2.0d0) 6833 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 6834 & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1)) 6835 &))) 6836 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1_2_2',10,MA 6837 &_ERR) 6838 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2_2', 6839 &11,MA_ERR) 6840 END IF 6841 END IF 6842 END IF 6843 next = NXTASK(nprocs, 1) 6844 END IF 6845 count = count + 1 6846 END DO 6847 END DO 6848 END DO 6849 END DO 6850 next = NXTASK(-nprocs, 1) 6851 call GA_SYNC() 6852 RETURN 6853 END 6854 SUBROUTINE ipccsd_x2_6_1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o 6855 &ffset) 6856C $Id$ 6857C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6858C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6859C i2 ( h8 h10 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h8 h10 p5 p6 )_v 6860 IMPLICIT NONE 6861#include "global.fh" 6862#include "mafdecls.fh" 6863#include "sym.fh" 6864#include "errquit.fh" 6865#include "tce.fh" 6866 INTEGER d_a 6867 INTEGER k_a_offset 6868 INTEGER d_b 6869 INTEGER k_b_offset 6870 INTEGER d_c 6871 INTEGER k_c_offset 6872 INTEGER NXTASK 6873 INTEGER next 6874 INTEGER nprocs 6875 INTEGER count 6876 INTEGER h8b 6877 INTEGER h10b 6878 INTEGER h1b 6879 INTEGER h2b 6880 INTEGER dimc 6881 INTEGER l_c_sort 6882 INTEGER k_c_sort 6883 INTEGER p5b 6884 INTEGER p6b 6885 INTEGER p5b_1 6886 INTEGER p6b_1 6887 INTEGER h1b_1 6888 INTEGER h2b_1 6889 INTEGER h8b_2 6890 INTEGER h10b_2 6891 INTEGER p5b_2 6892 INTEGER p6b_2 6893 INTEGER dim_common 6894 INTEGER dima_sort 6895 INTEGER dima 6896 INTEGER dimb_sort 6897 INTEGER dimb 6898 INTEGER l_a_sort 6899 INTEGER k_a_sort 6900 INTEGER l_a 6901 INTEGER k_a 6902 INTEGER l_b_sort 6903 INTEGER k_b_sort 6904 INTEGER l_b 6905 INTEGER k_b 6906 INTEGER nsuperp(2) 6907 INTEGER isuperp 6908 INTEGER l_c 6909 INTEGER k_c 6910 DOUBLE PRECISION FACTORIAL 6911 EXTERNAL NXTASK 6912 EXTERNAL FACTORIAL 6913 nprocs = GA_NNODES() 6914 count = 0 6915 next = NXTASK(nprocs, 1) 6916 DO h8b = 1,noab 6917 DO h10b = h8b,noab 6918 DO h1b = 1,noab 6919 DO h2b = h1b,noab 6920 IF (next.eq.count) THEN 6921 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 6922 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 6923 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 6924 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 6925 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 6926 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T 6927 &HEN 6928 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 6929 &ange+h1b-1) * int_mb(k_range+h2b-1) 6930 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6931 & ERRQUIT('ipccsd_x2_6_1_3',0,MA_ERR) 6932 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6933 DO p5b = noab+1,noab+nvab 6934 DO p6b = p5b,noab+nvab 6935 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 6936 &1b-1)+int_mb(k_spin+h2b-1)) THEN 6937 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 6938 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 6939 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1) 6940 CALL TCE_RESTRICTED_4(h8b,h10b,p5b,p6b,h8b_2,h10b_2,p5b_2,p6b_2) 6941 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) 6942 dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 6943 dima = dim_common * dima_sort 6944 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) 6945 dimb = dim_common * dimb_sort 6946 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6947 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6948 & ERRQUIT('ipccsd_x2_6_1_3',1,MA_ERR) 6949 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6950 &ipccsd_x2_6_1_3',2,MA_ERR) 6951 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 6952 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 6953 &1 - noab - 1))))) 6954 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 6955 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 6956 &,4,3,2,1,1.0d0) 6957 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1_3',3,MA_ER 6958 &R) 6959 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6960 & ERRQUIT('ipccsd_x2_6_1_3',4,MA_ERR) 6961 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6962 &ipccsd_x2_6_1_3',5,MA_ERR) 6963 if(.not.intorb) then 6964 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 6965 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 6966 &b+nvab) * (h8b_2 - 1))))) 6967 else 6968 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 6969 &(p6b_2 6970 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 6971 &b+nvab) * (h8b_2 - 1)))),p6b_2,p5b_2,h10b_2,h8b_2) 6972 end if 6973 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 6974 &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 6975 &),2,1,4,3,1.0d0) 6976 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_1_3',6,MA_ER 6977 &R) 6978 nsuperp(1) = 1 6979 nsuperp(2) = 1 6980 isuperp = 1 6981 IF (p5b .eq. p6b) THEN 6982 nsuperp(isuperp) = nsuperp(isuperp) + 1 6983 ELSE 6984 isuperp = isuperp + 1 6985 END IF 6986 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 6987 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 6988 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 6989 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_1_3',7, 6990 &MA_ERR) 6991 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1_3',8, 6992 &MA_ERR) 6993 END IF 6994 END IF 6995 END IF 6996 END DO 6997 END DO 6998 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6999 &ipccsd_x2_6_1_3',9,MA_ERR) 7000 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1 7001 &),int_mb(k_range+h8b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1 7002 &),2,1,4,3,1.0d0/2.0d0) 7003 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 7004 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1))))) 7005 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1_3',10,MA_E 7006 &RR) 7007 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_1_3',11 7008 &,MA_ERR) 7009 END IF 7010 END IF 7011 END IF 7012 next = NXTASK(nprocs, 1) 7013 END IF 7014 count = count + 1 7015 END DO 7016 END DO 7017 END DO 7018 END DO 7019 next = NXTASK(-nprocs, 1) 7020 call GA_SYNC() 7021 RETURN 7022 END 7023 SUBROUTINE ipccsd_x2_6_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 7024 &set) 7025C $Id$ 7026C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7027C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7028C i1 ( h10 p3 h1 h2 )_fx + = 1 * Sum ( p5 ) * x ( p3 p5 h1 h2 )_x * i2 ( h10 p5 )_f 7029 IMPLICIT NONE 7030#include "global.fh" 7031#include "mafdecls.fh" 7032#include "sym.fh" 7033#include "errquit.fh" 7034#include "tce.fh" 7035#include "stdio.fh" 7036 INTEGER d_a 7037 INTEGER k_a_offset 7038 INTEGER d_b 7039 INTEGER k_b_offset 7040 INTEGER d_c 7041 INTEGER k_c_offset 7042 INTEGER NXTASK 7043 INTEGER next 7044 INTEGER nprocs 7045 INTEGER count 7046 INTEGER p3b 7047 INTEGER h10b 7048 INTEGER h1b 7049 INTEGER h2b 7050 INTEGER dimc 7051 INTEGER l_c_sort 7052 INTEGER k_c_sort 7053 INTEGER p5b 7054 INTEGER p3b_1 7055 INTEGER p5b_1 7056 INTEGER h1b_1 7057 INTEGER h2b_1 7058 INTEGER h10b_2 7059 INTEGER p5b_2 7060 INTEGER dim_common 7061 INTEGER dima_sort 7062 INTEGER dima 7063 INTEGER dimb_sort 7064 INTEGER dimb 7065 INTEGER l_a_sort 7066 INTEGER k_a_sort 7067 INTEGER l_a 7068 INTEGER k_a 7069 INTEGER l_b_sort 7070 INTEGER k_b_sort 7071 INTEGER l_b 7072 INTEGER k_b 7073 INTEGER l_c 7074 INTEGER k_c 7075 EXTERNAL NXTASK 7076 nprocs = GA_NNODES() 7077 count = 0 7078 next = NXTASK(nprocs, 1) 7079ckbn DO p3b = noab+1,noab+nvab 7080 DO p3b = 1,1 7081 DO h10b = 1,noab 7082 DO h1b = 1,noab 7083 DO h2b = h1b,noab 7084 IF (next.eq.count) THEN 7085ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 7086ckbn &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 7087 IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+h10b- 7088 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 7089ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 7090ckbn &h1b-1)+int_mb(k_spin+h2b-1)) THEN 7091 IF (ip_unused_spin +int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 7092 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 7093ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 7094ckbn &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_f,irrep_x)) T 7095ckbn &HEN 7096 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+h10b-1),ieor(int_mb 7097 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_f,irrep_x)) T 7098 &HEN 7099ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 7100ckbn &ange+h1b-1) * int_mb(k_range+h2b-1) 7101 dimc = 1 * int_mb(k_range+h10b-1) * int_mb(k_r 7102 &ange+h1b-1) * int_mb(k_range+h2b-1) 7103 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7104 & ERRQUIT('ipccsd_x2_6_2',0,MA_ERR) 7105 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7106 DO p5b = noab+1,noab+nvab 7107ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 7108ckbn &1b-1)+int_mb(k_spin+h2b-1)) THEN 7109 IF (ip_unused_spin +int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 7110 &1b-1)+int_mb(k_spin+h2b-1)) THEN 7111ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 7112ckbn &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN 7113 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 7114 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN 7115 CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h2b,p3b_1,p5b_1,h1b_1,h2b_1) 7116 CALL TCE_RESTRICTED_2(h10b,p5b,h10b_2,p5b_2) 7117 dim_common = int_mb(k_range+p5b-1) 7118ckbn dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb 7119ckbn &(k_range+h2b-1) 7120 dima_sort = 1 * int_mb(k_range+h1b-1) * int_mb 7121 &(k_range+h2b-1) 7122 dima = dim_common * dima_sort 7123 dimb_sort = int_mb(k_range+h10b-1) 7124 dimb = dim_common * dimb_sort 7125 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7126 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7127 & ERRQUIT('ipccsd_x2_6_2',1,MA_ERR) 7128 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7129 &ipccsd_x2_6_2',2,MA_ERR) 7130c write(LuOut,*) "I am here 1." 7131c call util_flush(LuOut) 7132ckbn IF ((p5b .lt. p3b)) THEN 7133 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 7134 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 7135 &1 - noab - 1))))) 7136ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 7137ckbn &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 7138ckbn &,4,3,2,1,-1.0d0) 7139 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 7140 &,1,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 7141 &,4,3,2,1,-1.0d0) 7142c write(LuOut,*) "I am here 2." 7143c call util_flush(LuOut) 7144ckbn END IF 7145ckbn IF ((p3b .le. p5b)) THEN 7146ckbn CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 7147ckbn & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 7148ckbn &1 - noab - 1))))) 7149ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7150ckbn &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 7151ckbn &,4,3,1,2,1.0d0) 7152ckbn END IF 7153 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_2',3,MA_ERR) 7154 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7155 & ERRQUIT('ipccsd_x2_6_2',4,MA_ERR) 7156 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7157 &ipccsd_x2_6_2',5,MA_ERR) 7158 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 7159 & - noab - 1 + nvab * (h10b_2 - 1))) 7160 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 7161 &),int_mb(k_range+p5b-1),1,2,1.0d0) 7162 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_2',6,MA_ERR) 7163 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 7164 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 7165 &t),dima_sort) 7166 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_2',7,MA 7167 &_ERR) 7168 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_2',8,MA 7169 &_ERR) 7170 END IF 7171 END IF 7172 END IF 7173 END DO 7174 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7175 &ipccsd_x2_6_2',9,MA_ERR) 7176c write(LuOut,*) "I am here 3." 7177c call util_flush(LuOut) 7178ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1 7179ckbn &),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1 7180ckbn &),4,1,3,2,1.0d0) 7181 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1 7182 &),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),1 7183 &,4,1,3,2,1.0d0) 7184c write(LuOut,*) "I am here 3.1" 7185c call util_flush(LuOut) 7186 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 7187 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 7188 &))) 7189c write(LuOut,*) "I am here 4." 7190c call util_flush(LuOut) 7191 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_2',10,MA_ERR 7192 &) 7193 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_2',11,M 7194 &A_ERR) 7195 END IF 7196 END IF 7197 END IF 7198 next = NXTASK(nprocs, 1) 7199 END IF 7200 count = count + 1 7201 END DO 7202 END DO 7203 END DO 7204 END DO 7205 next = NXTASK(-nprocs, 1) 7206 call GA_SYNC() 7207 RETURN 7208 END 7209 SUBROUTINE ipccsd_x2_6_2_1(d_a,k_a_offset,d_c,k_c_offset) 7210C $Id$ 7211C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7212C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7213C i2 ( h10 p5 )_f + = 1 * f ( h10 p5 )_f 7214 IMPLICIT NONE 7215#include "global.fh" 7216#include "mafdecls.fh" 7217#include "sym.fh" 7218#include "errquit.fh" 7219#include "tce.fh" 7220 INTEGER d_a 7221 INTEGER k_a_offset 7222 INTEGER d_c 7223 INTEGER k_c_offset 7224 INTEGER NXTASK 7225 INTEGER next 7226 INTEGER nprocs 7227 INTEGER count 7228 INTEGER h10b 7229 INTEGER p5b 7230 INTEGER dimc 7231 INTEGER h10b_1 7232 INTEGER p5b_1 7233 INTEGER dim_common 7234 INTEGER dima_sort 7235 INTEGER dima 7236 INTEGER l_a_sort 7237 INTEGER k_a_sort 7238 INTEGER l_a 7239 INTEGER k_a 7240 INTEGER l_c 7241 INTEGER k_c 7242 EXTERNAL NXTASK 7243 nprocs = GA_NNODES() 7244 count = 0 7245 next = NXTASK(nprocs, 1) 7246 DO h10b = 1,noab 7247 DO p5b = noab+1,noab+nvab 7248 IF (next.eq.count) THEN 7249 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b- 7250 &1).ne.4)) THEN 7251 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN 7252 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T 7253 &HEN 7254 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1) 7255 CALL TCE_RESTRICTED_2(h10b,p5b,h10b_1,p5b_1) 7256 dim_common = 1 7257 dima_sort = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1) 7258 dima = dim_common * dima_sort 7259 IF (dima .gt. 0) THEN 7260 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7261 & ERRQUIT('ipccsd_x2_6_2_1',0,MA_ERR) 7262 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7263 &ipccsd_x2_6_2_1',1,MA_ERR) 7264 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1 7265 & - 1 + (noab+nvab) * (h10b_1 - 1))) 7266 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1 7267 &),int_mb(k_range+p5b-1),2,1,1.0d0) 7268 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_2_1',2,MA_ER 7269 &R) 7270 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7271 &ipccsd_x2_6_2_1',3,MA_ERR) 7272 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 7273 &,int_mb(k_range+h10b-1),2,1,1.0d0) 7274 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 7275 & noab - 1 + nvab * (h10b - 1))) 7276 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_2_1',4,MA_ER 7277 &R) 7278 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_2_1',5, 7279 &MA_ERR) 7280 END IF 7281 END IF 7282 END IF 7283 END IF 7284 next = NXTASK(nprocs, 1) 7285 END IF 7286 count = count + 1 7287 END DO 7288 END DO 7289 next = NXTASK(-nprocs, 1) 7290 call GA_SYNC() 7291 RETURN 7292 END 7293 SUBROUTINE OFFSET_ipccsd_x2_6_2_1(l_a_offset,k_a_offset,size) 7294C $Id$ 7295C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7296C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7297C i2 ( h10 p5 )_f 7298 IMPLICIT NONE 7299#include "global.fh" 7300#include "mafdecls.fh" 7301#include "sym.fh" 7302#include "errquit.fh" 7303#include "tce.fh" 7304 INTEGER l_a_offset 7305 INTEGER k_a_offset 7306 INTEGER size 7307 INTEGER length 7308 INTEGER addr 7309 INTEGER h10b 7310 INTEGER p5b 7311 length = 0 7312 DO h10b = 1,noab 7313 DO p5b = noab+1,noab+nvab 7314 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN 7315 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T 7316 &HEN 7317 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b- 7318 &1).ne.4)) THEN 7319 length = length + 1 7320 END IF 7321 END IF 7322 END IF 7323 END DO 7324 END DO 7325 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 7326 &set)) CALL ERRQUIT('ipccsd_x2_6_2_1',0,MA_ERR) 7327 int_mb(k_a_offset) = length 7328 addr = 0 7329 size = 0 7330 DO h10b = 1,noab 7331 DO p5b = noab+1,noab+nvab 7332 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN 7333 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T 7334 &HEN 7335 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b- 7336 &1).ne.4)) THEN 7337 addr = addr + 1 7338 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h10b - 1) 7339 int_mb(k_a_offset+length+addr) = size 7340 size = size + int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1) 7341 END IF 7342 END IF 7343 END IF 7344 END DO 7345 END DO 7346 RETURN 7347 END 7348 SUBROUTINE ipccsd_x2_6_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o 7349 &ffset) 7350C $Id$ 7351C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7352C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7353C i2 ( h10 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h10 p5 p6 )_v 7354 IMPLICIT NONE 7355#include "global.fh" 7356#include "mafdecls.fh" 7357#include "sym.fh" 7358#include "errquit.fh" 7359#include "tce.fh" 7360 INTEGER d_a 7361 INTEGER k_a_offset 7362 INTEGER d_b 7363 INTEGER k_b_offset 7364 INTEGER d_c 7365 INTEGER k_c_offset 7366 INTEGER NXTASK 7367 INTEGER next 7368 INTEGER nprocs 7369 INTEGER count 7370 INTEGER h10b 7371 INTEGER p5b 7372 INTEGER dimc 7373 INTEGER l_c_sort 7374 INTEGER k_c_sort 7375 INTEGER p6b 7376 INTEGER h7b 7377 INTEGER p6b_1 7378 INTEGER h7b_1 7379 INTEGER h10b_2 7380 INTEGER h7b_2 7381 INTEGER p5b_2 7382 INTEGER p6b_2 7383 INTEGER dim_common 7384 INTEGER dima_sort 7385 INTEGER dima 7386 INTEGER dimb_sort 7387 INTEGER dimb 7388 INTEGER l_a_sort 7389 INTEGER k_a_sort 7390 INTEGER l_a 7391 INTEGER k_a 7392 INTEGER l_b_sort 7393 INTEGER k_b_sort 7394 INTEGER l_b 7395 INTEGER k_b 7396 INTEGER l_c 7397 INTEGER k_c 7398 EXTERNAL NXTASK 7399 nprocs = GA_NNODES() 7400 count = 0 7401 next = NXTASK(nprocs, 1) 7402 DO h10b = 1,noab 7403 DO p5b = noab+1,noab+nvab 7404 IF (next.eq.count) THEN 7405 IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b- 7406 &1).ne.4)) THEN 7407 IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN 7408 IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep 7409 &_v,irrep_t)) THEN 7410 dimc = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1) 7411 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7412 & ERRQUIT('ipccsd_x2_6_2_2',0,MA_ERR) 7413 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7414 DO p6b = noab+1,noab+nvab 7415 DO h7b = 1,noab 7416 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN 7417 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 7418 &EN 7419 CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1) 7420 CALL TCE_RESTRICTED_4(h10b,h7b,p5b,p6b,h10b_2,h7b_2,p5b_2,p6b_2) 7421 dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1) 7422 dima_sort = 1 7423 dima = dim_common * dima_sort 7424 dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1) 7425 dimb = dim_common * dimb_sort 7426 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7427 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7428 & ERRQUIT('ipccsd_x2_6_2_2',1,MA_ERR) 7429 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7430 &ipccsd_x2_6_2_2',2,MA_ERR) 7431 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 7432 & - 1 + noab * (p6b_1 - noab - 1))) 7433 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 7434 &,int_mb(k_range+h7b-1),2,1,1.0d0) 7435 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_2_2',3,MA_ER 7436 &R) 7437 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7438 & ERRQUIT('ipccsd_x2_6_2_2',4,MA_ERR) 7439 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7440 &ipccsd_x2_6_2_2',5,MA_ERR) 7441 IF ((h7b .le. h10b) .and. (p6b .lt. p5b)) THEN 7442 if(.not.intorb) then 7443 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 7444 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 7445 &b+nvab) * (h7b_2 - 1))))) 7446 else 7447 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 7448 &(p5b_2 7449 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 7450 &b+nvab) * (h7b_2 - 1)))),p5b_2,p6b_2,h10b_2,h7b_2) 7451 end if 7452 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 7453 &,int_mb(k_range+h10b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1 7454 &),4,2,1,3,-1.0d0) 7455 END IF 7456 IF ((h7b .le. h10b) .and. (p5b .le. p6b)) THEN 7457 if(.not.intorb) then 7458 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 7459 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 7460 &b+nvab) * (h7b_2 - 1))))) 7461 else 7462 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 7463 &(p6b_2 7464 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 7465 &b+nvab) * (h7b_2 - 1)))),p6b_2,p5b_2,h10b_2,h7b_2) 7466 end if 7467 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 7468 &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 7469 &),3,2,1,4,1.0d0) 7470 END IF 7471 IF ((h10b .lt. h7b) .and. (p6b .lt. p5b)) THEN 7472 if(.not.intorb) then 7473 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 7474 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 7475 &+nvab) * (h10b_2 - 1))))) 7476 else 7477 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 7478 &(p5b_2 7479 & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 7480 &+nvab) * (h10b_2 - 1)))),p5b_2,p6b_2,h7b_2,h10b_2) 7481 end if 7482 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 7483 &),int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1 7484 &),4,1,2,3,1.0d0) 7485 END IF 7486 IF ((h10b .lt. h7b) .and. (p5b .le. p6b)) THEN 7487 if(.not.intorb) then 7488 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 7489 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 7490 &+nvab) * (h10b_2 - 1))))) 7491 else 7492 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 7493 &(p6b_2 7494 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 7495 &+nvab) * (h10b_2 - 1)))),p6b_2,p5b_2,h7b_2,h10b_2) 7496 end if 7497 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 7498 &),int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1 7499 &),3,1,2,4,-1.0d0) 7500 END IF 7501 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_2_2',6,MA_ER 7502 &R) 7503 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 7504 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 7505 &t),dima_sort) 7506 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_2_2',7, 7507 &MA_ERR) 7508 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_2_2',8, 7509 &MA_ERR) 7510 END IF 7511 END IF 7512 END IF 7513 END DO 7514 END DO 7515 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7516 &ipccsd_x2_6_2_2',9,MA_ERR) 7517 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 7518 &,int_mb(k_range+h10b-1),2,1,-1.0d0) 7519 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 7520 & noab - 1 + nvab * (h10b - 1))) 7521 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_2_2',10,MA_E 7522 &RR) 7523 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_2_2',11 7524 &,MA_ERR) 7525 END IF 7526 END IF 7527 END IF 7528 next = NXTASK(nprocs, 1) 7529 END IF 7530 count = count + 1 7531 END DO 7532 END DO 7533 next = NXTASK(-nprocs, 1) 7534 call GA_SYNC() 7535 RETURN 7536 END 7537 SUBROUTINE ipccsd_x2_6_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 7538 &set) 7539C $Id$ 7540C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7541C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7542C i1 ( h10 p3 h1 h2 )_vx + = -1 * P( 2 ) * Sum ( h8 p9 ) * x ( p3 p9 h1 h8 )_x * i2 ( h8 h10 h2 p9 )_v 7543 IMPLICIT NONE 7544#include "global.fh" 7545#include "mafdecls.fh" 7546#include "sym.fh" 7547#include "errquit.fh" 7548#include "tce.fh" 7549#include "stdio.fh" 7550 INTEGER d_a 7551 INTEGER k_a_offset 7552 INTEGER d_b 7553 INTEGER k_b_offset 7554 INTEGER d_c 7555 INTEGER k_c_offset 7556 INTEGER NXTASK 7557 INTEGER next 7558 INTEGER nprocs 7559 INTEGER count 7560 INTEGER p3b 7561 INTEGER h10b 7562 INTEGER h1b 7563 INTEGER h2b 7564 INTEGER dimc 7565 INTEGER l_c_sort 7566 INTEGER k_c_sort 7567 INTEGER p9b 7568 INTEGER h8b 7569 INTEGER p3b_1 7570 INTEGER p9b_1 7571 INTEGER h1b_1 7572 INTEGER h8b_1 7573 INTEGER h10b_2 7574 INTEGER h8b_2 7575 INTEGER h2b_2 7576 INTEGER p9b_2 7577 INTEGER dim_common 7578 INTEGER dima_sort 7579 INTEGER dima 7580 INTEGER dimb_sort 7581 INTEGER dimb 7582 INTEGER l_a_sort 7583 INTEGER k_a_sort 7584 INTEGER l_a 7585 INTEGER k_a 7586 INTEGER l_b_sort 7587 INTEGER k_b_sort 7588 INTEGER l_b 7589 INTEGER k_b 7590 INTEGER l_c 7591 INTEGER k_c 7592 EXTERNAL NXTASK 7593 nprocs = GA_NNODES() 7594 count = 0 7595 next = NXTASK(nprocs, 1) 7596ckbn DO p3b = noab+1,noab+nvab 7597 DO p3b = 1,1 7598 DO h10b = 1,noab 7599 DO h1b = 1,noab 7600 DO h2b = 1,noab 7601 IF (next.eq.count) THEN 7602ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b- 7603ckbn &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 7604 IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+h10b- 7605 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 7606ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 7607ckbn &h1b-1)+int_mb(k_spin+h2b-1)) THEN 7608 IF (ip_unused_spin +int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 7609 &h1b-1)+int_mb(k_spin+h2b-1)) THEN 7610ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 7611ckbn &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T 7612ckbn &HEN 7613 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+h10b-1),ieor(int_mb 7614 &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T 7615 &HEN 7616ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 7617ckbn &ange+h1b-1) * int_mb(k_range+h2b-1) 7618 dimc = 1 * int_mb(k_range+h10b-1) * int_mb(k_r 7619 &ange+h1b-1) * int_mb(k_range+h2b-1) 7620 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7621 & ERRQUIT('ipccsd_x2_6_3',0,MA_ERR) 7622 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7623 DO p9b = noab+1,noab+nvab 7624 DO h8b = 1,noab 7625ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h 7626ckbn &1b-1)+int_mb(k_spin+h8b-1)) THEN 7627 IF (ip_unused_spin +int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h 7628 &1b-1)+int_mb(k_spin+h8b-1)) THEN 7629ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p9b-1),ieor(int_mb( 7630ckbn &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_x) THEN 7631 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p9b-1),ieor(int_mb( 7632 &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_x) THEN 7633 CALL TCE_RESTRICTED_4(p3b,p9b,h1b,h8b,p3b_1,p9b_1,h1b_1,h8b_1) 7634 CALL TCE_RESTRICTED_4(h10b,h8b,h2b,p9b,h10b_2,h8b_2,h2b_2,p9b_2) 7635 dim_common = int_mb(k_range+p9b-1) * int_mb(k_range+h8b-1) 7636ckbn dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) 7637 dima_sort = 1 * int_mb(k_range+h1b-1) 7638 dima = dim_common * dima_sort 7639 dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h2b-1) 7640 dimb = dim_common * dimb_sort 7641 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7642 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7643 & ERRQUIT('ipccsd_x2_6_3',1,MA_ERR) 7644 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7645 &ipccsd_x2_6_3',2,MA_ERR) 7646c write(LuOut,*) "I am here 1." 7647c call util_flush(LuOut) 7648ckbn IF ((p9b .lt. p3b) .and. (h8b .lt. h1b)) THEN 7649 IF ( (h8b .lt. h1b)) THEN 7650 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 7651 & - 1 + noab * (h8b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p9b_ 7652 &1 - noab - 1))))) 7653ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 7654ckbn &,int_mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) 7655ckbn &,4,2,3,1,1.0d0) 7656 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 7657 &,1,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) 7658 &,4,2,3,1,1.0d0) 7659 END IF 7660c write(LuOut,*) "I am here 1.1" 7661c call util_flush(LuOut) 7662ckbn IF ((p9b .lt. p3b) .and. (h1b .le. h8b)) THEN 7663 IF ( (h1b .le. h8b)) THEN 7664 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 7665 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p9b_ 7666 &1 - noab - 1))))) 7667ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 7668ckbn &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) 7669ckbn &,3,2,4,1,-1.0d0) 7670 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 7671 &,1,int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) 7672 &,3,2,4,1,-1.0d0) 7673 END IF 7674ckbn IF ((p3b .le. p9b) .and. (h8b .lt. h1b)) THEN 7675ckbn CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 7676ckbn & - 1 + noab * (h8b_1 - 1 + noab * (p9b_1 - noab - 1 + nvab * (p3b_ 7677ckbn &1 - noab - 1))))) 7678ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7679ckbn &,int_mb(k_range+p9b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) 7680ckbn &,4,1,3,2,-1.0d0) 7681ckbn END IF 7682ckbn IF ((p3b .le. p9b) .and. (h1b .le. h8b)) THEN 7683ckbn CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 7684ckbn & - 1 + noab * (h1b_1 - 1 + noab * (p9b_1 - noab - 1 + nvab * (p3b_ 7685ckbn &1 - noab - 1))))) 7686ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7687ckbn &,int_mb(k_range+p9b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) 7688ckbn &,3,1,4,2,1.0d0) 7689ckbn END IF 7690c write(LuOut,*) "I am here 2." 7691c call util_flush(LuOut) 7692 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_3',3,MA_ERR) 7693 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7694 & ERRQUIT('ipccsd_x2_6_3',4,MA_ERR) 7695 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7696 &ipccsd_x2_6_3',5,MA_ERR) 7697 IF ((h8b .le. h10b)) THEN 7698 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 7699 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h10b_2 - 1 + noab * (h8b 7700 &_2 - 1))))) 7701 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 7702 &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+p9b-1 7703 &),3,2,1,4,1.0d0) 7704 END IF 7705 IF ((h10b .lt. h8b)) THEN 7706 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 7707 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h8b_2 - 1 + noab * (h10b 7708 &_2 - 1))))) 7709 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 7710 &),int_mb(k_range+h8b-1),int_mb(k_range+h2b-1),int_mb(k_range+p9b-1 7711 &),3,1,2,4,-1.0d0) 7712 END IF 7713 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_3',6,MA_ERR) 7714 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 7715 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 7716 &t),dima_sort) 7717 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_3',7,MA 7718 &_ERR) 7719 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_3',8,MA 7720 &_ERR) 7721 END IF 7722 END IF 7723 END IF 7724 END DO 7725 END DO 7726 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7727 &ipccsd_x2_6_3',9,MA_ERR) 7728c write(LuOut,*) "I am here 3." 7729c call util_flush(LuOut) 7730 IF ((h1b .le. h2b)) THEN 7731ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 7732ckbn &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1 7733ckbn &),4,2,3,1,-1.0d0) 7734 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 7735 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),1 7736 &,4,2,3,1,-1.0d0) 7737 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 7738 & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 7739 &))) 7740 END IF 7741 IF ((h2b .le. h1b)) THEN 7742ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 7743ckbn &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1 7744ckbn &),4,2,1,3,1.0d0) 7745 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 7746 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),1 7747 & ,4,2,1,3,1.0d0) 7748 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 7749 & 1 + noab * (h2b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1)) 7750 &))) 7751 END IF 7752c write(LuOut,*) "I am here 4." 7753c call util_flush(LuOut) 7754 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_3',10,MA_ERR 7755 &) 7756 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_3',11,M 7757 &A_ERR) 7758 END IF 7759 END IF 7760 END IF 7761 next = NXTASK(nprocs, 1) 7762 END IF 7763 count = count + 1 7764 END DO 7765 END DO 7766 END DO 7767 END DO 7768 next = NXTASK(-nprocs, 1) 7769 call GA_SYNC() 7770 RETURN 7771 END 7772 SUBROUTINE ipccsd_x2_6_3_1(d_a,k_a_offset,d_c,k_c_offset) 7773C $Id$ 7774C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7775C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7776C i2 ( h8 h10 h1 p9 )_v + = 1 * v ( h8 h10 h1 p9 )_v 7777 IMPLICIT NONE 7778#include "global.fh" 7779#include "mafdecls.fh" 7780#include "sym.fh" 7781#include "errquit.fh" 7782#include "tce.fh" 7783 INTEGER d_a 7784 INTEGER k_a_offset 7785 INTEGER d_c 7786 INTEGER k_c_offset 7787 INTEGER NXTASK 7788 INTEGER next 7789 INTEGER nprocs 7790 INTEGER count 7791 INTEGER h8b 7792 INTEGER h10b 7793 INTEGER h1b 7794 INTEGER p9b 7795 INTEGER dimc 7796 INTEGER h8b_1 7797 INTEGER h10b_1 7798 INTEGER h1b_1 7799 INTEGER p9b_1 7800 INTEGER dim_common 7801 INTEGER dima_sort 7802 INTEGER dima 7803 INTEGER l_a_sort 7804 INTEGER k_a_sort 7805 INTEGER l_a 7806 INTEGER k_a 7807 INTEGER l_c 7808 INTEGER k_c 7809 EXTERNAL NXTASK 7810 nprocs = GA_NNODES() 7811 count = 0 7812 next = NXTASK(nprocs, 1) 7813 DO h8b = 1,noab 7814 DO h10b = h8b,noab 7815 DO h1b = 1,noab 7816 DO p9b = noab+1,noab+nvab 7817 IF (next.eq.count) THEN 7818 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 7819 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN 7820 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 7821 &h1b-1)+int_mb(k_spin+p9b-1)) THEN 7822 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 7823 &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN 7824 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 7825 &ange+h1b-1) * int_mb(k_range+p9b-1) 7826 CALL TCE_RESTRICTED_4(h8b,h10b,h1b,p9b,h8b_1,h10b_1,h1b_1,p9b_1) 7827 dim_common = 1 7828 dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m 7829 &b(k_range+h1b-1) * int_mb(k_range+p9b-1) 7830 dima = dim_common * dima_sort 7831 IF (dima .gt. 0) THEN 7832 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7833 & ERRQUIT('ipccsd_x2_6_3_1',0,MA_ERR) 7834 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7835 &ipccsd_x2_6_3_1',1,MA_ERR) 7836 IF ((h1b .le. p9b)) THEN 7837 if(.not.intorb) then 7838 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p9b_1 7839 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 7840 &b+nvab) * (h8b_1 - 1))))) 7841 else 7842 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset), 7843 &(p9b_1 7844 & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa 7845 &b+nvab) * (h8b_1 - 1)))),p9b_1,h1b_1,h10b_1,h8b_1) 7846 end if 7847 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1) 7848 &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p9b-1 7849 &),4,3,2,1,1.0d0) 7850 END IF 7851 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_3_1',2,MA_ER 7852 &R) 7853 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7854 &ipccsd_x2_6_3_1',3,MA_ERR) 7855 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p9b-1) 7856 &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h8b-1 7857 &),4,3,2,1,1.0d0) 7858 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b - 7859 & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1)) 7860 &))) 7861 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_3_1',4,MA_ER 7862 &R) 7863 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_3_1',5, 7864 &MA_ERR) 7865 END IF 7866 END IF 7867 END IF 7868 END IF 7869 next = NXTASK(nprocs, 1) 7870 END IF 7871 count = count + 1 7872 END DO 7873 END DO 7874 END DO 7875 END DO 7876 next = NXTASK(-nprocs, 1) 7877 call GA_SYNC() 7878 RETURN 7879 END 7880 SUBROUTINE OFFSET_ipccsd_x2_6_3_1(l_a_offset,k_a_offset,size) 7881C $Id$ 7882C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7883C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7884C i2 ( h8 h10 h1 p9 )_v 7885 IMPLICIT NONE 7886#include "global.fh" 7887#include "mafdecls.fh" 7888#include "sym.fh" 7889#include "errquit.fh" 7890#include "tce.fh" 7891 INTEGER l_a_offset 7892 INTEGER k_a_offset 7893 INTEGER size 7894 INTEGER length 7895 INTEGER addr 7896 INTEGER h8b 7897 INTEGER h10b 7898 INTEGER h1b 7899 INTEGER p9b 7900 length = 0 7901 DO h8b = 1,noab 7902 DO h10b = h8b,noab 7903 DO h1b = 1,noab 7904 DO p9b = noab+1,noab+nvab 7905 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 7906 &h1b-1)+int_mb(k_spin+p9b-1)) THEN 7907 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 7908 &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN 7909 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 7910 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN 7911 length = length + 1 7912 END IF 7913 END IF 7914 END IF 7915 END DO 7916 END DO 7917 END DO 7918 END DO 7919 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 7920 &set)) CALL ERRQUIT('ipccsd_x2_6_3_1',0,MA_ERR) 7921 int_mb(k_a_offset) = length 7922 addr = 0 7923 size = 0 7924 DO h8b = 1,noab 7925 DO h10b = h8b,noab 7926 DO h1b = 1,noab 7927 DO p9b = noab+1,noab+nvab 7928 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 7929 &h1b-1)+int_mb(k_spin+p9b-1)) THEN 7930 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 7931 &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN 7932 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 7933 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN 7934 addr = addr + 1 7935 int_mb(k_a_offset+addr) = p9b - noab - 1 + nvab * (h1b - 1 + noab 7936 &* (h10b - 1 + noab * (h8b - 1))) 7937 int_mb(k_a_offset+length+addr) = size 7938 size = size + int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int 7939 &_mb(k_range+h1b-1) * int_mb(k_range+p9b-1) 7940 END IF 7941 END IF 7942 END IF 7943 END DO 7944 END DO 7945 END DO 7946 END DO 7947 RETURN 7948 END 7949 SUBROUTINE ipccsd_x2_6_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o 7950 &ffset) 7951C $Id$ 7952C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7953C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7954C i2 ( h8 h10 h1 p9 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h8 h10 p5 p9 )_v 7955 IMPLICIT NONE 7956#include "global.fh" 7957#include "mafdecls.fh" 7958#include "sym.fh" 7959#include "errquit.fh" 7960#include "tce.fh" 7961 INTEGER d_a 7962 INTEGER k_a_offset 7963 INTEGER d_b 7964 INTEGER k_b_offset 7965 INTEGER d_c 7966 INTEGER k_c_offset 7967 INTEGER NXTASK 7968 INTEGER next 7969 INTEGER nprocs 7970 INTEGER count 7971 INTEGER h8b 7972 INTEGER h10b 7973 INTEGER h1b 7974 INTEGER p9b 7975 INTEGER dimc 7976 INTEGER l_c_sort 7977 INTEGER k_c_sort 7978 INTEGER p5b 7979 INTEGER p5b_1 7980 INTEGER h1b_1 7981 INTEGER h8b_2 7982 INTEGER h10b_2 7983 INTEGER p9b_2 7984 INTEGER p5b_2 7985 INTEGER dim_common 7986 INTEGER dima_sort 7987 INTEGER dima 7988 INTEGER dimb_sort 7989 INTEGER dimb 7990 INTEGER l_a_sort 7991 INTEGER k_a_sort 7992 INTEGER l_a 7993 INTEGER k_a 7994 INTEGER l_b_sort 7995 INTEGER k_b_sort 7996 INTEGER l_b 7997 INTEGER k_b 7998 INTEGER l_c 7999 INTEGER k_c 8000 EXTERNAL NXTASK 8001 nprocs = GA_NNODES() 8002 count = 0 8003 next = NXTASK(nprocs, 1) 8004 DO h8b = 1,noab 8005 DO h10b = h8b,noab 8006 DO h1b = 1,noab 8007 DO p9b = noab+1,noab+nvab 8008 IF (next.eq.count) THEN 8009 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b- 8010 &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN 8011 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 8012 &h1b-1)+int_mb(k_spin+p9b-1)) THEN 8013 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 8014 &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. ieor(irrep_v,irrep_t)) T 8015 &HEN 8016 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 8017 &ange+h1b-1) * int_mb(k_range+p9b-1) 8018 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8019 & ERRQUIT('ipccsd_x2_6_3_2',0,MA_ERR) 8020 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8021 DO p5b = noab+1,noab+nvab 8022 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 8023 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 8024 &EN 8025 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 8026 CALL TCE_RESTRICTED_4(h8b,h10b,p9b,p5b,h8b_2,h10b_2,p9b_2,p5b_2) 8027 dim_common = int_mb(k_range+p5b-1) 8028 dima_sort = int_mb(k_range+h1b-1) 8029 dima = dim_common * dima_sort 8030 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m 8031 &b(k_range+p9b-1) 8032 dimb = dim_common * dimb_sort 8033 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8034 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8035 & ERRQUIT('ipccsd_x2_6_3_2',1,MA_ERR) 8036 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8037 &ipccsd_x2_6_3_2',2,MA_ERR) 8038 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 8039 & - 1 + noab * (p5b_1 - noab - 1))) 8040 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8041 &,int_mb(k_range+h1b-1),2,1,1.0d0) 8042 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_3_2',3,MA_ER 8043 &R) 8044 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8045 & ERRQUIT('ipccsd_x2_6_3_2',4,MA_ERR) 8046 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8047 &ipccsd_x2_6_3_2',5,MA_ERR) 8048 IF ((p5b .le. p9b)) THEN 8049 if(.not.intorb) then 8050 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 8051 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 8052 &b+nvab) * (h8b_2 - 1))))) 8053 else 8054 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 8055 &(p9b_2 8056 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 8057 &b+nvab) * (h8b_2 - 1)))),p9b_2,p5b_2,h10b_2,h8b_2) 8058 end if 8059 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 8060 &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1 8061 &),4,2,1,3,1.0d0) 8062 END IF 8063 IF ((p9b .lt. p5b)) THEN 8064 if(.not.intorb) then 8065 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 8066 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 8067 &b+nvab) * (h8b_2 - 1))))) 8068 else 8069 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 8070 &(p5b_2 8071 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 8072 &b+nvab) * (h8b_2 - 1)))),p5b_2,p9b_2,h10b_2,h8b_2) 8073 end if 8074 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 8075 &,int_mb(k_range+h10b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1 8076 &),3,2,1,4,-1.0d0) 8077 END IF 8078 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_3_2',6,MA_ER 8079 &R) 8080 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 8081 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 8082 &t),dima_sort) 8083 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_3_2',7, 8084 &MA_ERR) 8085 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_3_2',8, 8086 &MA_ERR) 8087 END IF 8088 END IF 8089 END IF 8090 END DO 8091 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8092 &ipccsd_x2_6_3_2',9,MA_ERR) 8093 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p9b-1) 8094 &,int_mb(k_range+h10b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1 8095 &),3,2,4,1,1.0d0) 8096 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b - 8097 & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1)) 8098 &))) 8099 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_3_2',10,MA_E 8100 &RR) 8101 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_3_2',11 8102 &,MA_ERR) 8103 END IF 8104 END IF 8105 END IF 8106 next = NXTASK(nprocs, 1) 8107 END IF 8108 count = count + 1 8109 END DO 8110 END DO 8111 END DO 8112 END DO 8113 next = NXTASK(-nprocs, 1) 8114 call GA_SYNC() 8115 RETURN 8116 END 8117 SUBROUTINE ipccsd_x2_7(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 8118 &t) 8119C $Id$ 8120C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8121C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8122C i0 ( p3 p4 h1 h2 )_vxt + = 1/2 * P( 2 ) * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i1 ( p4 p5 )_vx 8123 IMPLICIT NONE 8124#include "global.fh" 8125#include "mafdecls.fh" 8126#include "sym.fh" 8127#include "errquit.fh" 8128#include "tce.fh" 8129 INTEGER d_a 8130 INTEGER k_a_offset 8131 INTEGER d_b 8132 INTEGER k_b_offset 8133 INTEGER d_c 8134 INTEGER k_c_offset 8135 INTEGER NXTASK 8136 INTEGER next 8137 INTEGER nprocs 8138 INTEGER count 8139 INTEGER p3b 8140 INTEGER p4b 8141 INTEGER h1b 8142 INTEGER h2b 8143 INTEGER dimc 8144 INTEGER l_c_sort 8145 INTEGER k_c_sort 8146 INTEGER p5b 8147 INTEGER p3b_1 8148 INTEGER p5b_1 8149 INTEGER h1b_1 8150 INTEGER h2b_1 8151 INTEGER p4b_2 8152 INTEGER p5b_2 8153 INTEGER dim_common 8154 INTEGER dima_sort 8155 INTEGER dima 8156 INTEGER dimb_sort 8157 INTEGER dimb 8158 INTEGER l_a_sort 8159 INTEGER k_a_sort 8160 INTEGER l_a 8161 INTEGER k_a 8162 INTEGER l_b_sort 8163 INTEGER k_b_sort 8164 INTEGER l_b 8165 INTEGER k_b 8166 INTEGER l_c 8167 INTEGER k_c 8168 EXTERNAL NXTASK 8169 nprocs = GA_NNODES() 8170 count = 0 8171 next = NXTASK(nprocs, 1) 8172 DO p3b = noab+1,noab+nvab 8173ckbn DO p4b = noab+1,noab+nvab 8174 DO p4b = 1,1 8175 DO h1b = 1,noab 8176 DO h2b = h1b,noab 8177 IF (next.eq.count) THEN 8178ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 8179ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 8180 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ ip_unused_spin 8181 & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 8182ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 8183ckbn &1b-1)+int_mb(k_spin+h2b-1)) THEN 8184 IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h 8185 &1b-1)+int_mb(k_spin+h2b-1)) THEN 8186ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 8187ckbn &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x 8188ckbn &,irrep_t))) THEN 8189 IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb( 8190 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x 8191 &,irrep_t))) THEN 8192ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 8193ckbn &nge+h1b-1) * int_mb(k_range+h2b-1) 8194 dimc = int_mb(k_range+p3b-1) * 1 * int_mb(k_ra 8195 &nge+h1b-1) * int_mb(k_range+h2b-1) 8196 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8197 & ERRQUIT('ipccsd_x2_7',0,MA_ERR) 8198 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8199 DO p5b = noab+1,noab+nvab 8200 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 8201 &1b-1)+int_mb(k_spin+h2b-1)) THEN 8202 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 8203 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 8204 CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h2b,p3b_1,p5b_1,h1b_1,h2b_1) 8205 CALL TCE_RESTRICTED_2(p4b,p5b,p4b_2,p5b_2) 8206 dim_common = int_mb(k_range+p5b-1) 8207 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb 8208 &(k_range+h2b-1) 8209 dima = dim_common * dima_sort 8210ckbn dimb_sort = int_mb(k_range+p4b-1) 8211 dimb_sort = 1 8212 dimb = dim_common * dimb_sort 8213 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8214 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8215 & ERRQUIT('ipccsd_x2_7',1,MA_ERR) 8216 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8217 &ipccsd_x2_7',2,MA_ERR) 8218 IF ((p5b .lt. p3b)) THEN 8219 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 8220 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 8221 &1 - noab - 1))))) 8222 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8223 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 8224 &,4,3,2,1,-1.0d0) 8225 END IF 8226 IF ((p3b .le. p5b)) THEN 8227 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 8228 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 8229 &1 - noab - 1))))) 8230 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8231 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 8232 &,4,3,1,2,1.0d0) 8233 END IF 8234 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_7',3,MA_ERR) 8235 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8236 & ERRQUIT('ipccsd_x2_7',4,MA_ERR) 8237 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8238 &ipccsd_x2_7',5,MA_ERR) 8239 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 8240 & - noab - 1 + nvab * (p4b_2 - noab - 1))) 8241ckbn CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 8242ckbn &,int_mb(k_range+p5b-1),1,2,1.0d0) 8243 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),1 8244 &,int_mb(k_range+p5b-1),1,2,1.0d0) 8245 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_7',6,MA_ERR) 8246 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 8247 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 8248 &t),dima_sort) 8249 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_7',7,MA_E 8250 &RR) 8251 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_7',8,MA_E 8252 &RR) 8253 END IF 8254 END IF 8255 END IF 8256 END DO 8257 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8258 &ipccsd_x2_7',9,MA_ERR) 8259ckbn IF ((p3b .le. p4b)) THEN 8260ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 8261ckbn &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8262ckbn &,4,1,3,2,1.0d0/2.0d0) 8263 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),1 8264 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8265 &,4,1,3,2,1.0d0/2.0d0) 8266 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 8267 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 8268 & - 1))))) 8269ckbn END IF 8270ckbn IF ((p4b .le. p3b)) THEN 8271ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 8272ckbn &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8273ckbn &,1,4,3,2,-1.0d0/2.0d0) 8274ckbn CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 8275ckbn & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 8276ckbn & - 1))))) 8277ckbn END IF 8278 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_7',10,MA_ERR) 8279 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_7',11,MA_ 8280 &ERR) 8281 END IF 8282 END IF 8283 END IF 8284 next = NXTASK(nprocs, 1) 8285 END IF 8286 count = count + 1 8287 END DO 8288 END DO 8289 END DO 8290 END DO 8291 next = NXTASK(-nprocs, 1) 8292 call GA_SYNC() 8293 RETURN 8294 END 8295 SUBROUTINE ipccsd_x2_7_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 8296 &set) 8297C $Id$ 8298C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8299C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8300C i1 ( p3 p5 )_vx + = -1 * Sum ( h6 h7 p8 ) * x ( p3 p8 h6 h7 )_x * v ( h6 h7 p5 p8 )_v 8301 IMPLICIT NONE 8302#include "global.fh" 8303#include "mafdecls.fh" 8304#include "sym.fh" 8305#include "errquit.fh" 8306#include "tce.fh" 8307#include "stdio.fh" 8308 INTEGER d_a 8309 INTEGER k_a_offset 8310 INTEGER d_b 8311 INTEGER k_b_offset 8312 INTEGER d_c 8313 INTEGER k_c_offset 8314 INTEGER NXTASK 8315 INTEGER next 8316 INTEGER nprocs 8317 INTEGER count 8318 INTEGER p3b 8319 INTEGER p5b 8320 INTEGER dimc 8321 INTEGER l_c_sort 8322 INTEGER k_c_sort 8323 INTEGER p8b 8324 INTEGER h6b 8325 INTEGER h7b 8326 INTEGER p3b_1 8327 INTEGER p8b_1 8328 INTEGER h6b_1 8329 INTEGER h7b_1 8330 INTEGER h6b_2 8331 INTEGER h7b_2 8332 INTEGER p5b_2 8333 INTEGER p8b_2 8334 INTEGER dim_common 8335 INTEGER dima_sort 8336 INTEGER dima 8337 INTEGER dimb_sort 8338 INTEGER dimb 8339 INTEGER l_a_sort 8340 INTEGER k_a_sort 8341 INTEGER l_a 8342 INTEGER k_a 8343 INTEGER l_b_sort 8344 INTEGER k_b_sort 8345 INTEGER l_b 8346 INTEGER k_b 8347 INTEGER nsubh(2) 8348 INTEGER isubh 8349 INTEGER l_c 8350 INTEGER k_c 8351 DOUBLE PRECISION FACTORIAL 8352 EXTERNAL NXTASK 8353 EXTERNAL FACTORIAL 8354 nprocs = GA_NNODES() 8355 count = 0 8356 next = NXTASK(nprocs, 1) 8357ckbn DO p3b = noab+1,noab+nvab 8358 DO p3b = 1,1 8359 DO p5b = noab+1,noab+nvab 8360 IF (next.eq.count) THEN 8361ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 8362ckbn &).ne.4)) THEN 8363 IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p5b-1 8364 &).ne.4)) THEN 8365ckbn IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 8366 IF (ip_unused_spin .eq. int_mb(k_spin+p5b-1)) THEN 8367ckbn IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 8368ckbn &v,irrep_x)) THEN 8369 IF (ieor(ip_unused_sym ,int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 8370 &v,irrep_x)) THEN 8371ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1) 8372 dimc = 1 * int_mb(k_range+p5b-1) 8373 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8374 & ERRQUIT('ipccsd_x2_7_1',0,MA_ERR) 8375 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8376 DO p8b = noab+1,noab+nvab 8377 DO h6b = 1,noab 8378 DO h7b = h6b,noab 8379ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h 8380ckbn &6b-1)+int_mb(k_spin+h7b-1)) THEN 8381 IF (ip_unused_spin +int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h 8382 &6b-1)+int_mb(k_spin+h7b-1)) THEN 8383ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb( 8384ckbn &k_sym+h6b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN 8385 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p8b-1),ieor(int_mb( 8386 &k_sym+h6b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN 8387 CALL TCE_RESTRICTED_4(p3b,p8b,h6b,h7b,p3b_1,p8b_1,h6b_1,h7b_1) 8388 CALL TCE_RESTRICTED_4(h6b,h7b,p5b,p8b,h6b_2,h7b_2,p5b_2,p8b_2) 8389 dim_common = int_mb(k_range+p8b-1) * int_mb(k_range+h6b-1) * int_m 8390 &b(k_range+h7b-1) 8391ckbn dima_sort = int_mb(k_range+p3b-1) 8392 dima_sort = 1 8393 dima = dim_common * dima_sort 8394 dimb_sort = int_mb(k_range+p5b-1) 8395 dimb = dim_common * dimb_sort 8396 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8397 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8398 & ERRQUIT('ipccsd_x2_7_1',1,MA_ERR) 8399 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8400 &ipccsd_x2_7_1',2,MA_ERR) 8401c write(LuOut,*) "I am here 1." 8402c call util_flush(LuOut) 8403ckbn IF ((p8b .lt. p3b)) THEN 8404 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8405 & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 8406 &1 - noab - 1))))) 8407ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 8408ckbn &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h7b-1) 8409ckbn &,2,4,3,1,-1.0d0) 8410 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 8411 &,1,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1) 8412 &,2,4,3,1,-1.0d0) 8413ckbn END IF 8414ckbn IF ((p3b .le. p8b)) THEN 8415ckbn CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 8416ckbn & - 1 + noab * (h6b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 8417ckbn &1 - noab - 1))))) 8418ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8419ckbn &,int_mb(k_range+p8b-1),int_mb(k_range+h6b-1),int_mb(k_range+h7b-1) 8420ckbn &,1,4,3,2,1.0d0) 8421ckbn END IF 8422c write(LuOut,*) "I am here 2." 8423c call util_flush(LuOut) 8424 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_7_1',3,MA_ERR) 8425 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8426 & ERRQUIT('ipccsd_x2_7_1',4,MA_ERR) 8427 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8428 &ipccsd_x2_7_1',5,MA_ERR) 8429 IF ((p8b .lt. p5b)) THEN 8430 if(.not.intorb) then 8431 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 8432 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 8433 &+nvab) * (h6b_2 - 1))))) 8434 else 8435 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 8436 &(p5b_2 8437 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 8438 &+nvab) * (h6b_2 - 1)))),p5b_2,p8b_2,h7b_2,h6b_2) 8439 end if 8440 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 8441 &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1) 8442 &,4,2,1,3,-1.0d0) 8443 END IF 8444 IF ((p5b .le. p8b)) THEN 8445 if(.not.intorb) then 8446 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 8447 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 8448 &+nvab) * (h6b_2 - 1))))) 8449 else 8450 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 8451 &(p8b_2 8452 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 8453 &+nvab) * (h6b_2 - 1)))),p8b_2,p5b_2,h7b_2,h6b_2) 8454 end if 8455 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 8456 &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1) 8457 &,3,2,1,4,1.0d0) 8458 END IF 8459 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_7_1',6,MA_ERR) 8460 nsubh(1) = 1 8461 nsubh(2) = 1 8462 isubh = 1 8463 IF (h6b .eq. h7b) THEN 8464 nsubh(isubh) = nsubh(isubh) + 1 8465 ELSE 8466 isubh = isubh + 1 8467 END IF 8468 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 8469 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 8470 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 8471 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_7_1',7,MA 8472 &_ERR) 8473 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_7_1',8,MA 8474 &_ERR) 8475 END IF 8476 END IF 8477 END IF 8478 END DO 8479 END DO 8480 END DO 8481 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8482 &ipccsd_x2_7_1',9,MA_ERR) 8483c write(LuOut,*) "I am here 3." 8484c call util_flush(LuOut) 8485ckbn CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 8486ckbn &,int_mb(k_range+p3b-1),2,1,-1.0d0) 8487 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 8488 &,1,2,1,-1.0d0) 8489 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 8490 & noab - 1 + nvab * (p3b - noab - 1))) 8491c write(LuOut,*) "I am here 4." 8492c call util_flush(LuOut) 8493 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_7_1',10,MA_ERR 8494 &) 8495 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_7_1',11,M 8496 &A_ERR) 8497 END IF 8498 END IF 8499 END IF 8500 next = NXTASK(nprocs, 1) 8501 END IF 8502 count = count + 1 8503 END DO 8504 END DO 8505 next = NXTASK(-nprocs, 1) 8506 call GA_SYNC() 8507 RETURN 8508 END 8509 8510ckbn SUBROUTINE OFFSET_ipccsd_x2_7_1(l_a_offset,k_a_offset,size) 8511ckbnC $Id$ 8512ckbnC This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8513ckbnC Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8514ckbnC i1 ( p3 p5 )_vx 8515ckbn IMPLICIT NONE 8516ckbn#include "global.fh" 8517ckbn#include "mafdecls.fh" 8518ckbn#include "sym.fh" 8519ckbn#include "errquit.fh" 8520ckbn#include "tce.fh" 8521ckbn INTEGER l_a_offset 8522ckbn INTEGER k_a_offset 8523ckbn INTEGER size 8524ckbn INTEGER length 8525ckbn INTEGER addr 8526ckbn INTEGER p3b 8527ckbn INTEGER p5b 8528ckbn length = 0 8529ckbn DO p3b = noab+1,noab+nvab 8530ckbn DO p5b = noab+1,noab+nvab 8531ckbn IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 8532ckbn IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 8533ckbn &v,irrep_x)) THEN 8534ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 8535ckbn &).ne.4)) THEN 8536ckbn length = length + 1 8537ckbn END IF 8538ckbn END IF 8539ckbn END IF 8540ckbn END DO 8541ckbn END DO 8542ckbn IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 8543ckbn &set)) CALL ERRQUIT('ipccsd_x2_7_1',0,MA_ERR) 8544ckbn int_mb(k_a_offset) = length 8545ckbn addr = 0 8546ckbn size = 0 8547ckbn DO p3b = noab+1,noab+nvab 8548ckbn DO p5b = noab+1,noab+nvab 8549ckbn IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 8550ckbn IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 8551ckbn &v,irrep_x)) THEN 8552ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 8553ckbn &).ne.4)) THEN 8554ckbn addr = addr + 1 8555ckbn int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (p3b - noab - 1) 8556ckbn int_mb(k_a_offset+length+addr) = size 8557ckbn size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1) 8558ckbn END IF 8559ckbn END IF 8560ckbn END IF 8561ckbn END DO 8562ckbn END DO 8563ckbn RETURN 8564ckbn END 8565 8566 SUBROUTINE OFFSET_ipccsd_x2_7_1(l_a_offset,k_a_offset,size) 8567C $Id$ 8568C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8569C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8570C i1 ( p3 p5 )_vx 8571 IMPLICIT NONE 8572#include "global.fh" 8573#include "mafdecls.fh" 8574#include "sym.fh" 8575#include "errquit.fh" 8576#include "tce.fh" 8577 INTEGER l_a_offset 8578 INTEGER k_a_offset 8579 INTEGER size 8580 INTEGER length 8581 INTEGER addr 8582 INTEGER p3b 8583 INTEGER p5b 8584 length = 0 8585ckbn DO p3b = noab+1,noab+nvab 8586 DO p3b =1,1 8587 DO p5b = noab+1,noab+nvab 8588ckbn IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 8589 IF (ip_unused_spin .eq. int_mb(k_spin+p5b-1)) THEN 8590ckbn IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 8591ckbn &v,irrep_x)) THEN 8592 IF (ieor(ip_unused_sym,int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 8593 &v,irrep_x)) THEN 8594ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 8595ckbn &).ne.4)) THEN 8596 IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p5b-1 8597 &).ne.4)) THEN 8598 length = length + 1 8599 END IF 8600 END IF 8601 END IF 8602 END DO 8603 END DO 8604 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 8605 &set)) CALL ERRQUIT('ipccsd_x2_7_1',0,MA_ERR) 8606 int_mb(k_a_offset) = length 8607 addr = 0 8608 size = 0 8609ckbn DO p3b = noab+1,noab+nvab 8610 DO p3b = 1,1 8611 DO p5b = noab+1,noab+nvab 8612ckbn IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 8613 IF (ip_unused_spin .eq. int_mb(k_spin+p5b-1)) THEN 8614ckbn IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 8615ckbn &v,irrep_x)) THEN 8616 IF (ieor(ip_unused_sym,int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 8617 &v,irrep_x)) THEN 8618ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 8619ckbn &).ne.4)) THEN 8620 IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p5b-1 8621 &).ne.4)) THEN 8622 addr = addr + 1 8623 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (p3b - noab - 1) 8624 int_mb(k_a_offset+length+addr) = size 8625ckbn size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1) 8626 size = size + 1 * int_mb(k_range+p5b-1) 8627 END IF 8628 END IF 8629 END IF 8630 END DO 8631 END DO 8632 RETURN 8633 END 8634 8635 8636ckbn SUBROUTINE OFFSET_ipccsd_x2_7_1(l_a_offset,k_a_offset,size) 8637ckbnC $Id$ 8638ckbnC This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8639ckbnC Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8640ckbnC i1 ( p3 p5 )_vx 8641ckbn IMPLICIT NONE 8642ckbn#include "global.fh" 8643ckbn#include "mafdecls.fh" 8644ckbn#include "sym.fh" 8645ckbn#include "errquit.fh" 8646ckbn#include "tce.fh" 8647ckbn INTEGER l_a_offset 8648ckbn INTEGER k_a_offset 8649ckbn INTEGER size 8650ckbn INTEGER length 8651ckbn INTEGER addr 8652ckbn INTEGER p3b 8653ckbn INTEGER p5b 8654ckbn length = 0 8655ckbn DO p3b = noab+1,noab+nvab 8656ckbnckbn DO p5b = noab+1,noab+nvab 8657ckbn DO p5b = 1,1 8658ckbnckbn IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 8659ckbn IF (int_mb(k_spin+p3b-1) .eq. ip_unused_spin) THEN 8660ckbnckbn IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 8661ckbnckbn &v,irrep_x)) THEN 8662ckbn IF (ieor(int_mb(k_sym+p3b-1),ip_unused_sym ) .eq. ieor(irrep_ 8663ckbn &v,irrep_x)) THEN 8664ckbnckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 8665ckbnckbn &).ne.4)) THEN 8666ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ip_unused_spin 8667ckbn & .ne.4)) THEN 8668ckbn length = length + 1 8669ckbn END IF 8670ckbn END IF 8671ckbn END IF 8672ckbn END DO 8673ckbn END DO 8674ckbn IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 8675ckbn &set)) CALL ERRQUIT('ipccsd_x2_7_1',0,MA_ERR) 8676ckbn int_mb(k_a_offset) = length 8677ckbn addr = 0 8678ckbn size = 0 8679ckbn DO p3b = noab+1,noab+nvab 8680ckbnckbn DO p5b = noab+1,noab+nvab 8681ckbn DO p5b = 1,1 8682ckbnckbn IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN 8683ckbn IF (int_mb(k_spin+p3b-1) .eq. ip_unused_spin ) THEN 8684ckbnckbn IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 8685ckbnckbn &v,irrep_x)) THEN 8686ckbn IF (ieor(int_mb(k_sym+p3b-1),ip_unused_sym) .eq. ieor(irrep_ 8687ckbn &v,irrep_x)) THEN 8688ckbnckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1 8689ckbnckbn &).ne.4)) THEN 8690ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ ip_unused_spin 8691ckbn & .ne.4)) THEN 8692ckbn addr = addr + 1 8693ckbn int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (p3b - noab - 1) 8694ckbn int_mb(k_a_offset+length+addr) = size 8695ckbnckbn size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1) 8696ckbn size = size + int_mb(k_range+p3b-1) * 1 8697ckbn END IF 8698ckbn END IF 8699ckbn END IF 8700ckbn END DO 8701ckbn END DO 8702ckbn RETURN 8703ckbn END 8704 SUBROUTINE ipccsd_x2_8(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse 8705 &t) 8706C $Id$ 8707C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8708C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8709C i0 ( p3 p4 h1 h2 )_vxt + = 1 * P( 4 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i1 ( h6 p4 h2 p5 )_vx 8710 IMPLICIT NONE 8711#include "global.fh" 8712#include "mafdecls.fh" 8713#include "sym.fh" 8714#include "errquit.fh" 8715#include "tce.fh" 8716 INTEGER d_a 8717 INTEGER k_a_offset 8718 INTEGER d_b 8719 INTEGER k_b_offset 8720 INTEGER d_c 8721 INTEGER k_c_offset 8722 INTEGER NXTASK 8723 INTEGER next 8724 INTEGER nprocs 8725 INTEGER count 8726 INTEGER p3b 8727 INTEGER p4b 8728 INTEGER h1b 8729 INTEGER h2b 8730 INTEGER dimc 8731 INTEGER l_c_sort 8732 INTEGER k_c_sort 8733 INTEGER p5b 8734 INTEGER h6b 8735 INTEGER p3b_1 8736 INTEGER p5b_1 8737 INTEGER h1b_1 8738 INTEGER h6b_1 8739 INTEGER p4b_2 8740 INTEGER h6b_2 8741 INTEGER h2b_2 8742 INTEGER p5b_2 8743 INTEGER dim_common 8744 INTEGER dima_sort 8745 INTEGER dima 8746 INTEGER dimb_sort 8747 INTEGER dimb 8748 INTEGER l_a_sort 8749 INTEGER k_a_sort 8750 INTEGER l_a 8751 INTEGER k_a 8752 INTEGER l_b_sort 8753 INTEGER k_b_sort 8754 INTEGER l_b 8755 INTEGER k_b 8756 INTEGER l_c 8757 INTEGER k_c 8758 EXTERNAL NXTASK 8759 nprocs = GA_NNODES() 8760 count = 0 8761 next = NXTASK(nprocs, 1) 8762 DO p3b = noab+1,noab+nvab 8763ckbn DO p4b = noab+1,noab+nvab 8764 DO p4b = 1,1 8765 DO h1b = 1,noab 8766 DO h2b = 1,noab 8767 IF (next.eq.count) THEN 8768ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 8769ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 8770 IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ip_unused_spin 8771 & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 8772ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 8773ckbn &1b-1)+int_mb(k_spin+h2b-1)) THEN 8774 IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h 8775 &1b-1)+int_mb(k_spin+h2b-1)) THEN 8776ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 8777ckbn &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x 8778ckbn &,irrep_t))) THEN 8779 IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb( 8780 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x 8781 &,irrep_t))) THEN 8782ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra 8783ckbn &nge+h1b-1) * int_mb(k_range+h2b-1) 8784 dimc = int_mb(k_range+p3b-1) * 1 * int_mb(k_ra 8785 &nge+h1b-1) * int_mb(k_range+h2b-1) 8786 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8787 & ERRQUIT('ipccsd_x2_8',0,MA_ERR) 8788 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8789 DO p5b = noab+1,noab+nvab 8790 DO h6b = 1,noab 8791 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 8792 &1b-1)+int_mb(k_spin+h6b-1)) THEN 8793 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 8794 &k_sym+h1b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_t) THEN 8795 CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h6b,p3b_1,p5b_1,h1b_1,h6b_1) 8796 CALL TCE_RESTRICTED_4(p4b,h6b,h2b,p5b,p4b_2,h6b_2,h2b_2,p5b_2) 8797 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) 8798 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) 8799 dima = dim_common * dima_sort 8800ckbn dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h2b-1) 8801 dimb_sort = 1 * int_mb(k_range+h2b-1) 8802 dimb = dim_common * dimb_sort 8803 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8804 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8805 & ERRQUIT('ipccsd_x2_8',1,MA_ERR) 8806 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8807 &ipccsd_x2_8',2,MA_ERR) 8808 IF ((p5b .lt. p3b) .and. (h6b .lt. h1b)) THEN 8809 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 8810 & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 8811 &1 - noab - 1))))) 8812 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8813 &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 8814 &,4,2,3,1,1.0d0) 8815 END IF 8816 IF ((p5b .lt. p3b) .and. (h1b .le. h6b)) THEN 8817 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 8818 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 8819 &1 - noab - 1))))) 8820 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 8821 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1) 8822 &,3,2,4,1,-1.0d0) 8823 END IF 8824 IF ((p3b .le. p5b) .and. (h6b .lt. h1b)) THEN 8825 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 8826 & - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 8827 &1 - noab - 1))))) 8828 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8829 &,int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 8830 &,4,1,3,2,-1.0d0) 8831 END IF 8832 IF ((p3b .le. p5b) .and. (h1b .le. h6b)) THEN 8833 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 8834 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 8835 &1 - noab - 1))))) 8836 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8837 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1) 8838 &,3,1,4,2,1.0d0) 8839 END IF 8840 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_8',3,MA_ERR) 8841 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8842 & ERRQUIT('ipccsd_x2_8',4,MA_ERR) 8843 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8844 &ipccsd_x2_8',5,MA_ERR) 8845 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 8846 & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h6b_2 - 1 + noab * (p4b_ 8847 &2 - noab - 1))))) 8848ckbn CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1) 8849ckbn &,int_mb(k_range+h6b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1) 8850ckbn &,3,1,2,4,1.0d0) 8851 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),1 8852 &,int_mb(k_range+h6b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1) 8853 &,3,1,2,4,1.0d0) 8854 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_8',6,MA_ERR) 8855 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 8856 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 8857 &t),dima_sort) 8858 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_8',7,MA_E 8859 &RR) 8860 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_8',8,MA_E 8861 &RR) 8862 END IF 8863 END IF 8864 END IF 8865 END DO 8866 END DO 8867 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8868 &ipccsd_x2_8',9,MA_ERR) 8869ckbn IF ((p3b .le. p4b) .and. (h1b .le. h2b)) THEN 8870 IF ( (h1b .le. h2b)) THEN 8871ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 8872ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8873ckbn &,4,2,3,1,1.0d0) 8874 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 8875 &,1,int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8876 &,4,2,3,1,1.0d0) 8877 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 8878 & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 8879 & - 1))))) 8880 END IF 8881ckbn IF ((p3b .le. p4b) .and. (h2b .le. h1b)) THEN 8882 IF ( (h2b .le. h1b)) THEN 8883ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 8884ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8885ckbn &,4,2,1,3,-1.0d0) 8886 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 8887 &,1,int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8888 &,4,2,1,3,-1.0d0) 8889 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 8890 & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab 8891 & - 1))))) 8892 END IF 8893ckbn IF ((p4b .le. p3b) .and. (h1b .le. h2b)) THEN 8894ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 8895ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8896ckbn &,2,4,3,1,-1.0d0) 8897ckbn CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 8898ckbn & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 8899ckbn & - 1))))) 8900ckbn END IF 8901ckbn IF ((p4b .le. p3b) .and. (h2b .le. h1b)) THEN 8902ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 8903ckbn &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 8904ckbn &,2,4,1,3,1.0d0) 8905ckbn CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 8906ckbn & 1 + noab * (h2b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab 8907ckbn & - 1))))) 8908ckbn END IF 8909 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_8',10,MA_ERR) 8910 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_8',11,MA_ 8911 &ERR) 8912 END IF 8913 END IF 8914 END IF 8915 next = NXTASK(nprocs, 1) 8916 END IF 8917 count = count + 1 8918 END DO 8919 END DO 8920 END DO 8921 END DO 8922 next = NXTASK(-nprocs, 1) 8923 call GA_SYNC() 8924 RETURN 8925 END 8926 SUBROUTINE ipccsd_x2_8_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off 8927 &set) 8928C $Id$ 8929C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8930C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8931C i1 ( h6 p3 h1 p5 )_vx + = 1 * Sum ( h7 p8 ) * x ( p3 p8 h1 h7 )_x * v ( h6 h7 p5 p8 )_v 8932 IMPLICIT NONE 8933#include "global.fh" 8934#include "mafdecls.fh" 8935#include "sym.fh" 8936#include "errquit.fh" 8937#include "tce.fh" 8938#include "stdio.fh" 8939 INTEGER d_a 8940 INTEGER k_a_offset 8941 INTEGER d_b 8942 INTEGER k_b_offset 8943 INTEGER d_c 8944 INTEGER k_c_offset 8945 INTEGER NXTASK 8946 INTEGER next 8947 INTEGER nprocs 8948 INTEGER count 8949 INTEGER p3b 8950 INTEGER h6b 8951 INTEGER h1b 8952 INTEGER p5b 8953 INTEGER dimc 8954 INTEGER l_c_sort 8955 INTEGER k_c_sort 8956 INTEGER p8b 8957 INTEGER h7b 8958 INTEGER p3b_1 8959 INTEGER p8b_1 8960 INTEGER h1b_1 8961 INTEGER h7b_1 8962 INTEGER h6b_2 8963 INTEGER h7b_2 8964 INTEGER p5b_2 8965 INTEGER p8b_2 8966 INTEGER dim_common 8967 INTEGER dima_sort 8968 INTEGER dima 8969 INTEGER dimb_sort 8970 INTEGER dimb 8971 INTEGER l_a_sort 8972 INTEGER k_a_sort 8973 INTEGER l_a 8974 INTEGER k_a 8975 INTEGER l_b_sort 8976 INTEGER k_b_sort 8977 INTEGER l_b 8978 INTEGER k_b 8979 INTEGER l_c 8980 INTEGER k_c 8981 EXTERNAL NXTASK 8982 nprocs = GA_NNODES() 8983 count = 0 8984 next = NXTASK(nprocs, 1) 8985ckbn DO p3b = noab+1,noab+nvab 8986 DO p3b = 1,1 8987 DO h6b = 1,noab 8988 DO h1b = 1,noab 8989 DO p5b = noab+1,noab+nvab 8990 IF (next.eq.count) THEN 8991ckbn IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1 8992ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 8993 IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+h6b-1 8994 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 8995ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 8996ckbn &1b-1)+int_mb(k_spin+p5b-1)) THEN 8997 IF (ip_unused_spin +int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 8998 &1b-1)+int_mb(k_spin+p5b-1)) THEN 8999ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 9000ckbn &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 9001ckbn &EN 9002 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 9003 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 9004 &EN 9005ckbn dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 9006ckbn &nge+h1b-1) * int_mb(k_range+p5b-1) 9007 dimc = 1 * int_mb(k_range+h6b-1) * int_mb(k_ra 9008 &nge+h1b-1) * int_mb(k_range+p5b-1) 9009 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 9010 & ERRQUIT('ipccsd_x2_8_1',0,MA_ERR) 9011 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 9012 DO p8b = noab+1,noab+nvab 9013 DO h7b = 1,noab 9014ckbn IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h 9015ckbn &1b-1)+int_mb(k_spin+h7b-1)) THEN 9016 IF (ip_unused_spin +int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h 9017 &1b-1)+int_mb(k_spin+h7b-1)) THEN 9018ckbn IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb( 9019ckbn &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN 9020 IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p8b-1),ieor(int_mb( 9021 &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN 9022 CALL TCE_RESTRICTED_4(p3b,p8b,h1b,h7b,p3b_1,p8b_1,h1b_1,h7b_1) 9023 CALL TCE_RESTRICTED_4(h6b,h7b,p5b,p8b,h6b_2,h7b_2,p5b_2,p8b_2) 9024 dim_common = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 9025ckbn dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) 9026 dima_sort = 1 * int_mb(k_range+h1b-1) 9027 dima = dim_common * dima_sort 9028 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1) 9029 dimb = dim_common * dimb_sort 9030 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 9031 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 9032 & ERRQUIT('ipccsd_x2_8_1',1,MA_ERR) 9033 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 9034 &ipccsd_x2_8_1',2,MA_ERR) 9035c write(LuOut,*) "I am here 1." 9036c call util_flush(LuOut) 9037ckbn IF ((p8b .lt. p3b) .and. (h7b .lt. h1b)) THEN 9038 IF ((h7b .lt. h1b)) THEN 9039 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 9040 & - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 9041 &1 - noab - 1))))) 9042ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 9043ckbn &,int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 9044ckbn &,4,2,3,1,1.0d0) 9045 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 9046 &,1,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 9047 &,4,2,3,1,1.0d0) 9048 END IF 9049 IF ((h1b .le. h7b)) THEN 9050 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 9051 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 9052 &1 - noab - 1))))) 9053ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 9054ckbn &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1) 9055ckbn &,3,2,4,1,-1.0d0) 9056 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 9057 &,1,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1) 9058 &,3,2,4,1,-1.0d0) 9059 END IF 9060c write(LuOut,*) "I am here 2." 9061c call util_flush(LuOut) 9062ckbn IF ((p3b .le. p8b) .and. (h7b .lt. h1b)) THEN 9063ckbn CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 9064ckbn & - 1 + noab * (h7b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 9065ckbn &1 - noab - 1))))) 9066ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 9067ckbn &,int_mb(k_range+p8b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 9068ckbn &,4,1,3,2,-1.0d0) 9069ckbn END IF 9070ckbn IF ((p3b .le. p8b) .and. (h1b .le. h7b)) THEN 9071ckbn CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 9072ckbn & - 1 + noab * (h1b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 9073ckbn &1 - noab - 1))))) 9074ckbn CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 9075ckbn &,int_mb(k_range+p8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1) 9076ckbn &,3,1,4,2,1.0d0) 9077ckbn END IF 9078 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_8_1',3,MA_ERR) 9079 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 9080 & ERRQUIT('ipccsd_x2_8_1',4,MA_ERR) 9081 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 9082 &ipccsd_x2_8_1',5,MA_ERR) 9083 IF ((h7b .lt. h6b) .and. (p8b .lt. p5b)) THEN 9084c write(LuOut,*) "I am here 3." 9085c call util_flush(LuOut) 9086 if(.not.intorb) then 9087 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 9088 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 9089 &+nvab) * (h7b_2 - 1))))) 9090 else 9091 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 9092 &(p5b_2 9093 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 9094 &+nvab) * (h7b_2 - 1)))),p5b_2,p8b_2,h6b_2,h7b_2) 9095 end if 9096 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 9097 &,int_mb(k_range+h6b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1) 9098 &,4,2,1,3,1.0d0) 9099 END IF 9100 IF ((h7b .lt. h6b) .and. (p5b .le. p8b)) THEN 9101c write(LuOut,*) "I am here 3.1" 9102c call util_flush(LuOut) 9103 if(.not.intorb) then 9104 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 9105 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 9106 &+nvab) * (h7b_2 - 1))))) 9107 else 9108 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 9109 &(p8b_2 9110 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 9111 &+nvab) * (h7b_2 - 1)))),p8b_2,p5b_2,h6b_2,h7b_2) 9112 end if 9113 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 9114 &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1) 9115 &,3,2,1,4,-1.0d0) 9116 END IF 9117 IF ((h6b .le. h7b) .and. (p8b .lt. p5b)) THEN 9118c write(LuOut,*) "I am here 3.2" 9119c call util_flush(LuOut) 9120 if(.not.intorb) then 9121 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 9122 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 9123 &+nvab) * (h6b_2 - 1))))) 9124 else 9125 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 9126 &(p5b_2 9127 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 9128 &+nvab) * (h6b_2 - 1)))),p5b_2,p8b_2,h7b_2,h6b_2) 9129 end if 9130 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 9131 &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1) 9132 &,4,1,2,3,-1.0d0) 9133 END IF 9134 IF ((h6b .le. h7b) .and. (p5b .le. p8b)) THEN 9135 if(.not.intorb) then 9136 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 9137 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 9138 &+nvab) * (h6b_2 - 1))))) 9139 else 9140 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 9141 &(p8b_2 9142 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab 9143 &+nvab) * (h6b_2 - 1)))),p8b_2,p5b_2,h7b_2,h6b_2) 9144 end if 9145 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 9146 &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1) 9147 &,3,1,2,4,1.0d0) 9148 END IF 9149 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_8_1',6,MA_ERR) 9150 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 9151 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 9152 &t),dima_sort) 9153 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_8_1',7,MA 9154 &_ERR) 9155 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_8_1',8,MA 9156 &_ERR) 9157 END IF 9158 END IF 9159 END IF 9160 END DO 9161 END DO 9162 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 9163 &ipccsd_x2_8_1',9,MA_ERR) 9164ckbn CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 9165ckbn &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 9166ckbn &,4,2,3,1,1.0d0) 9167c write(LuOut,*) "I am here 3.3" 9168c call util_flush(LuOut) 9169 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 9170 &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),1 9171 &,4,2,3,1,1.0d0) 9172c write(LuOut,*) "I am here 3.4" 9173c call util_flush(LuOut) 9174 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 9175 & noab - 1 + nvab * (h1b - 1 + noab * (h6b - 1 + noab * (p3b - noab 9176 & - 1))))) 9177c write(LuOut,*) "I am here 4." 9178c call util_flush(LuOut) 9179 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_8_1',10,MA_ERR 9180 &) 9181 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_8_1',11,M 9182 &A_ERR) 9183 END IF 9184 END IF 9185 END IF 9186 next = NXTASK(nprocs, 1) 9187 END IF 9188 count = count + 1 9189 END DO 9190 END DO 9191 END DO 9192 END DO 9193 next = NXTASK(-nprocs, 1) 9194 call GA_SYNC() 9195 RETURN 9196 END 9197ckbn SUBROUTINE OFFSET_ipccsd_x2_8_1(l_a_offset,k_a_offset,size) 9198ckbnC $Id$ 9199ckbnC This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 9200ckbnC Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 9201ckbnC i1 ( h6 p3 h1 p5 )_vx 9202ckbn IMPLICIT NONE 9203ckbn#include "global.fh" 9204ckbn#include "mafdecls.fh" 9205ckbn#include "sym.fh" 9206ckbn#include "errquit.fh" 9207ckbn#include "tce.fh" 9208ckbn INTEGER l_a_offset 9209ckbn INTEGER k_a_offset 9210ckbn INTEGER size 9211ckbn INTEGER length 9212ckbn INTEGER addr 9213ckbn INTEGER p3b 9214ckbn INTEGER h6b 9215ckbn INTEGER h1b 9216ckbn INTEGER p5b 9217ckbn length = 0 9218ckbn DO p3b = noab+1,noab+nvab 9219ckbn DO h6b = 1,noab 9220ckbn DO h1b = 1,noab 9221ckbnckbn DO p5b = noab+1,noab+nvab 9222ckbn DO p5b = 1,1 9223ckbnckbn IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 9224ckbnckbn &1b-1)+int_mb(k_spin+p5b-1)) THEN 9225ckbn IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 9226ckbn &1b-1)+ip_unused_spin ) THEN 9227ckbnckbn IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 9228ckbnckbn &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 9229ckbnckbn &EN 9230ckbn IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 9231ckbn &k_sym+h1b-1),ip_unused_sym))) .eq. ieor(irrep_v,irrep_x)) TH 9232ckbn &EN 9233ckbnckbn IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1 9234ckbnckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 9235ckbn IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1 9236ckbn &)+int_mb(k_spin+h1b-1)+ip_unused_spin .ne.8)) THEN 9237ckbn length = length + 1 9238ckbn END IF 9239ckbn END IF 9240ckbn END IF 9241ckbn END DO 9242ckbn END DO 9243ckbn END DO 9244ckbn END DO 9245ckbn IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 9246ckbn &set)) CALL ERRQUIT('ipccsd_x2_8_1',0,MA_ERR) 9247ckbn int_mb(k_a_offset) = length 9248ckbn addr = 0 9249ckbn size = 0 9250ckbn DO p3b = noab+1,noab+nvab 9251ckbn DO h6b = 1,noab 9252ckbn DO h1b = 1,noab 9253ckbnckbn DO p5b = noab+1,noab+nvab 9254ckbn DO p5b = 1,1 9255ckbnckbn IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 9256ckbnckbn &1b-1)+int_mb(k_spin+p5b-1)) THEN 9257ckbn IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 9258ckbn &1b-1)+ip_unused_spin) THEN 9259ckbnckbn IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 9260ckbnckbn &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 9261ckbnckbn &EN 9262ckbn IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 9263ckbn &k_sym+h1b-1),ip_unused_sym))) .eq. ieor(irrep_v,irrep_x)) TH 9264ckbn &EN 9265ckbnckbn IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1 9266ckbnckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 9267ckbn IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1 9268ckbn &)+int_mb(k_spin+h1b-1)+ip_unused_spin .ne.8)) THEN 9269ckbn addr = addr + 1 9270ckbn int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 9271ckbn &* (h6b - 1 + noab * (p3b - noab - 1))) 9272ckbn int_mb(k_a_offset+length+addr) = size 9273ckbnckbn size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_ 9274ckbnckbn &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 9275ckbn size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_ 9276ckbn &mb(k_range+h1b-1) * 1 9277ckbn END IF 9278ckbn END IF 9279ckbn END IF 9280ckbn END DO 9281ckbn END DO 9282ckbn END DO 9283ckbn END DO 9284ckbn RETURN 9285ckbn END 9286 SUBROUTINE OFFSET_ipccsd_x2_8_1(l_a_offset,k_a_offset,size) 9287C $Id$ 9288C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 9289C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 9290C i1 ( h6 p3 h1 p5 )_vx 9291 IMPLICIT NONE 9292#include "global.fh" 9293#include "mafdecls.fh" 9294#include "sym.fh" 9295#include "errquit.fh" 9296#include "tce.fh" 9297 INTEGER l_a_offset 9298 INTEGER k_a_offset 9299 INTEGER size 9300 INTEGER length 9301 INTEGER addr 9302 INTEGER p3b 9303 INTEGER h6b 9304 INTEGER h1b 9305 INTEGER p5b 9306 length = 0 9307ckbn DO p3b = noab+1,noab+nvab 9308 DO p3b = 1,1 9309 DO h6b = 1,noab 9310 DO h1b = 1,noab 9311 DO p5b = noab+1,noab+nvab 9312ckbn IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 9313ckbn &1b-1)+int_mb(k_spin+p5b-1)) THEN 9314 IF (int_mb(k_spin+h6b-1)+ip_unused_spin .eq. int_mb(k_spin+h 9315 &1b-1)+int_mb(k_spin+p5b-1)) THEN 9316ckbn IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 9317ckbn &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 9318ckbn &EN 9319 IF (ieor(int_mb(k_sym+h6b-1),ieor(ip_unused_sym ,ieor(int_mb( 9320 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 9321 &EN 9322ckbn IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1 9323ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 9324 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+ ip_unused_spin 9325 & +int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 9326 length = length + 1 9327 END IF 9328 END IF 9329 END IF 9330 END DO 9331 END DO 9332 END DO 9333 END DO 9334 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 9335 &set)) CALL ERRQUIT('ipccsd_x2_8_1',0,MA_ERR) 9336 int_mb(k_a_offset) = length 9337 addr = 0 9338 size = 0 9339ckbn DO p3b = noab+1,noab+nvab 9340 DO p3b = 1,1 9341 DO h6b = 1,noab 9342 DO h1b = 1,noab 9343 DO p5b = noab+1,noab+nvab 9344ckbn IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 9345ckbn &1b-1)+int_mb(k_spin+p5b-1)) THEN 9346 IF (int_mb(k_spin+h6b-1)+ip_unused_spin .eq. int_mb(k_spin+h 9347 &1b-1)+int_mb(k_spin+p5b-1)) THEN 9348ckbn IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 9349ckbn &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 9350ckbn &EN 9351 IF (ieor(int_mb(k_sym+h6b-1),ieor(ip_unused_sym ,ieor(int_mb( 9352 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 9353 &EN 9354ckbn IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1 9355ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 9356 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+ ip_unused_spin 9357 & +int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 9358 addr = addr + 1 9359 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 9360 &* (h6b - 1 + noab * (p3b - noab - 1))) 9361 int_mb(k_a_offset+length+addr) = size 9362ckbn size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_ 9363ckbn &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 9364 size = size + 1 * int_mb(k_range+h6b-1) * int_ 9365 &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 9366 END IF 9367 END IF 9368 END IF 9369 END DO 9370 END DO 9371 END DO 9372 END DO 9373 RETURN 9374 END 9375ckbn SUBROUTINE OFFSET_ipccsd_x2_8_1(l_a_offset,k_a_offset,size) 9376ckbnC $Id$ 9377ckbnC This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 9378ckbnC Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 9379ckbnC i1 ( h6 p3 h1 p5 )_vx 9380ckbn IMPLICIT NONE 9381ckbn#include "global.fh" 9382ckbn#include "mafdecls.fh" 9383ckbn#include "sym.fh" 9384ckbn#include "errquit.fh" 9385ckbn#include "tce.fh" 9386ckbn INTEGER l_a_offset 9387ckbn INTEGER k_a_offset 9388ckbn INTEGER size 9389ckbn INTEGER length 9390ckbn INTEGER addr 9391ckbn INTEGER p3b 9392ckbn INTEGER h6b 9393ckbn INTEGER h1b 9394ckbn INTEGER p5b 9395ckbn length = 0 9396ckbn DO p3b = noab+1,noab+nvab 9397ckbn DO h6b = 1,noab 9398ckbn DO h1b = 1,noab 9399ckbn DO p5b = noab+1,noab+nvab 9400ckbn IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 9401ckbn &1b-1)+int_mb(k_spin+p5b-1)) THEN 9402ckbn IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 9403ckbn &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 9404ckbn &EN 9405ckbn IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1 9406ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 9407ckbn length = length + 1 9408ckbn END IF 9409ckbn END IF 9410ckbn END IF 9411ckbn END DO 9412ckbn END DO 9413ckbn END DO 9414ckbn END DO 9415ckbn IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 9416ckbn &set)) CALL ERRQUIT('ipccsd_x2_8_1',0,MA_ERR) 9417ckbn int_mb(k_a_offset) = length 9418ckbn addr = 0 9419ckbn size = 0 9420ckbn DO p3b = noab+1,noab+nvab 9421ckbn DO h6b = 1,noab 9422ckbn DO h1b = 1,noab 9423ckbn DO p5b = noab+1,noab+nvab 9424ckbn IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 9425ckbn &1b-1)+int_mb(k_spin+p5b-1)) THEN 9426ckbn IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 9427ckbn &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH 9428ckbn &EN 9429ckbn IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1 9430ckbn &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 9431ckbn addr = addr + 1 9432ckbn int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 9433ckbn &* (h6b - 1 + noab * (p3b - noab - 1))) 9434ckbn int_mb(k_a_offset+length+addr) = size 9435ckbn size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_ 9436ckbn &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 9437ckbn END IF 9438ckbn END IF 9439ckbn END IF 9440ckbn END DO 9441ckbn END DO 9442ckbn END DO 9443ckbn END DO 9444ckbn RETURN 9445ckbn END 9446