1 SUBROUTINE eomccsd_density1(d_d1,d_i0,d_t1,d_t2,d_x0,d_x1,d_x2,d_y 2 &0,d_y1,d_y2,k_d1_offset,k_i0_offset,k_t1_offset,k_t2_offset,k_x0_o 3 &ffset,k_x1_offset,k_x2_offset,k_y0_offset,k_y1_offset,k_y2_offset) 4C $Id$ 5C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7C i0 ( )_yxd + = 1 * Sum ( h2 p1 ) * d ( p1 h2 )_d * i1 ( h2 p1 )_yx 8C i1 ( h2 p1 )_yx + = 1 * x ( )_x * y ( h2 p1 )_y 9C i1 ( h2 p1 )_yx + = 1 * Sum ( h4 p3 ) * x ( p3 h4 )_x * y ( h2 h4 p1 p3 )_y 10C i0 ( )_dxy + = 1 * y ( )_y * i1 ( )_dx 11C i1 ( )_dx + = 1 * Sum ( h1 p2 ) * d ( h1 p2 )_d * x ( p2 h1 )_x 12C i1 ( )_dtx + = 1 * x ( )_x * i2 ( )_dt 13C i2 ( )_dt + = 1 * Sum ( h1 p2 ) * d ( h1 p2 )_d * t ( p2 h1 )_t 14C i0 ( )_yxd + = -1 * Sum ( h2 h1 ) * d ( h1 h2 )_d * i1 ( h2 h1 )_yx 15C i1 ( h2 h1 )_yx + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * y ( h2 p3 )_y 16C i1 ( h2 h1 )_yx + = 1/2 * Sum ( h5 p4 p3 ) * x ( p3 p4 h1 h5 )_x * y ( h2 h5 p3 p4 )_y 17C i1 ( h2 h1 )_ytx + = 1 * x ( )_x * i2 ( h2 h1 )_yt 18C i2 ( h2 h1 )_yt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * y ( h2 p3 )_y 19C i2 ( h2 h1 )_yt + = 1/2 * Sum ( h5 p4 p3 ) * t ( p3 p4 h1 h5 )_t * y ( h2 h5 p3 p4 )_y 20C i1 ( h2 h1 )_yxt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * i2 ( h2 p3 )_yx 21C i2 ( h2 p3 )_yx + = 1 * Sum ( h5 p4 ) * x ( p4 h5 )_x * y ( h2 h5 p3 p4 )_y 22C i0 ( )_dxy + = 1 * Sum ( p1 h3 ) * y ( h3 p1 )_y * i1 ( p1 h3 )_dx 23C i1 ( p1 h3 )_dx + = 1 * Sum ( p2 ) * d ( p1 p2 )_d * x ( p2 h3 )_x 24C i1 ( p1 h3 )_dtx + = 1 * x ( )_x * i2 ( p1 h3 )_dt 25C i2 ( p1 h3 )_dt + = 1 * Sum ( p2 ) * d ( p1 p2 )_d * t ( p2 h3 )_t 26C i0 ( )_yxd + = 1 * Sum ( p8 h7 ) * d ( h7 p8 )_d * i1 ( p8 h7 )_yx 27C i1 ( p8 h7 )_yx + = 1 * Sum ( h4 p3 ) * x ( p3 p8 h4 h7 )_x * y ( h4 p3 )_y 28C i1 ( p8 h7 )_yxt + = -1 * Sum ( h1 ) * t ( p8 h1 )_t * i2 ( h1 h7 )_yx 29C i2 ( h1 h7 )_yx + = 1 * Sum ( p4 ) * x ( p4 h7 )_x * y ( h1 p4 )_y 30C i2 ( h1 h7 )_yx + = -1/2 * Sum ( h6 p5 p4 ) * x ( p4 p5 h6 h7 )_x * y ( h1 h6 p4 p5 )_y 31C i2 ( h1 h7 )_ytx + = 1 * x ( )_x * i3 ( h1 h7 )_yt 32C i3 ( h1 h7 )_yt + = 1 * Sum ( p3 ) * t ( p3 h7 )_t * y ( h1 p3 )_y 33C i3 ( h1 h7 )_yt + = -1/2 * Sum ( h5 p4 p3 ) * t ( p3 p4 h5 h7 )_t * y ( h1 h5 p3 p4 )_y 34C i2 ( h1 h7 )_yxt + = 1 * Sum ( p3 ) * t ( p3 h7 )_t * i3 ( h1 p3 )_yx 35C i3 ( h1 p3 )_yx + = 1 * Sum ( h6 p5 ) * x ( p5 h6 )_x * y ( h1 h6 p3 p5 )_y 36C i1 ( p8 h7 )_ytx + = -1 * Sum ( h1 ) * x ( p8 h1 )_x * i2 ( h1 h7 )_yt 37C i2 ( h1 h7 )_yt + = 1 * Sum ( p3 ) * t ( p3 h7 )_t * y ( h1 p3 )_y 38C i2 ( h1 h7 )_yt + = -1/2 * Sum ( h5 p4 p3 ) * t ( p3 p4 h5 h7 )_t * y ( h1 h5 p3 p4 )_y 39C i1 ( p8 h7 )_yxt + = 1 * t ( p8 h7 )_t * i2 ( )_yx 40C i2 ( )_yx + = 1 * Sum ( h4 p3 ) * x ( p3 h4 )_x * y ( h4 p3 )_y 41C i2 ( )_yx + = 1/4 * Sum ( h6 h5 p4 p3 ) * x ( p3 p4 h5 h6 )_x * y ( h5 h6 p3 p4 )_y 42C i1 ( p8 h7 )_ytx + = 1/2 * Sum ( h5 h6 p4 ) * x ( p4 p8 h5 h6 )_x * i2 ( h5 h6 h7 p4 )_yt 43C i2 ( h5 h6 h7 p4 )_yt + = 1 * Sum ( p3 ) * t ( p3 h7 )_t * y ( h5 h6 p3 p4 )_y 44C i1 ( p8 h7 )_yxt + = 1 * Sum ( h4 p3 ) * t ( p3 p8 h4 h7 )_t * i2 ( h4 p3 )_yx 45C i2 ( h4 p3 )_yx + = 1 * x ( )_x * y ( h4 p3 )_y 46C i2 ( h4 p3 )_yx + = 1 * Sum ( h6 p5 ) * x ( p5 h6 )_x * y ( h4 h6 p3 p5 )_y 47C i1 ( p8 h7 )_yxt + = -1/2 * Sum ( h4 h5 p3 ) * t ( p3 p8 h4 h5 )_t * i2 ( h4 h5 h7 p3 )_yx 48C i2 ( h4 h5 h7 p3 )_yx + = 1 * Sum ( p6 ) * x ( p6 h7 )_x * y ( h4 h5 p3 p6 )_y 49C i1 ( p8 h7 )_yttx + = -1/2 * x ( )_x * i2 ( p8 h7 )_ytt 50C i2 ( p8 h7 )_ytt + = 1 * Sum ( h4 h5 p3 ) * t ( p3 p8 h4 h5 )_t * i3 ( h4 h5 h7 p3 )_yt 51C i3 ( h4 h5 h7 p3 )_yt + = 1 * Sum ( p6 ) * t ( p6 h7 )_t * y ( h4 h5 p3 p6 )_y 52C i0 ( )_yxd + = -1/2 * Sum ( p2 p1 ) * d ( p1 p2 )_d * i1 ( p2 p1 )_yx 53C i1 ( p2 p1 )_yx + = -1 * Sum ( h5 h4 p3 ) * x ( p2 p3 h4 h5 )_x * y ( h4 h5 p1 p3 )_y 54C i1 ( p2 p1 )_yxt + = -2 * Sum ( h3 ) * t ( p2 h3 )_t * i2 ( h3 p1 )_yx 55C i2 ( h3 p1 )_yx + = 1 * Sum ( h5 p4 ) * x ( p4 h5 )_x * y ( h3 h5 p1 p4 )_y 56C i1 ( p2 p1 )_ytx + = 1 * x ( )_x * i2 ( p2 p1 )_yt 57C i2 ( p2 p1 )_yt + = -1 * Sum ( h5 h4 p3 ) * t ( p2 p3 h4 h5 )_t * y ( h4 h5 p1 p3 )_y 58 IMPLICIT NONE 59#include "global.fh" 60#include "mafdecls.fh" 61#include "util.fh" 62#include "errquit.fh" 63#include "tce.fh" 64 INTEGER d_i0 65 INTEGER k_i0_offset 66 INTEGER d_d1 67 INTEGER k_d1_offset 68 INTEGER d_i1 69 INTEGER k_i1_offset 70 INTEGER d_y0 71 INTEGER k_y0_offset 72 INTEGER d_y1 73 INTEGER k_y1_offset 74 INTEGER l_i1_offset 75 INTEGER d_x0 76 INTEGER k_x0_offset 77 INTEGER size_i1 78 INTEGER d_x1 79 INTEGER k_x1_offset 80 INTEGER d_y2 81 INTEGER k_y2_offset 82 INTEGER d_i2 83 INTEGER k_i2_offset 84 INTEGER l_i2_offset 85 INTEGER d_t1 86 INTEGER k_t1_offset 87 INTEGER size_i2 88 INTEGER d_x2 89 INTEGER k_x2_offset 90 INTEGER d_t2 91 INTEGER k_t2_offset 92 INTEGER d_i3 93 INTEGER k_i3_offset 94 INTEGER l_i3_offset 95 INTEGER size_i3 96 CHARACTER*255 filename 97 CALL OFFSET_eomccsd_density1_1_1(l_i1_offset,k_i1_offset,size_i1) 98 CALL TCE_FILENAME('eomccsd_density1_1_1_i1',filename) 99 CALL CREATEFILE(filename,d_i1,size_i1) 100 CALL eomccsd_density1_1_1(d_x0,k_x0_offset,d_y1,k_y1_offset,d_i1,k 101 &_i1_offset) 102 CALL eomccsd_density1_1_2(d_x1,k_x1_offset,d_y2,k_y2_offset,d_i1,k 103 &_i1_offset) 104 CALL RECONCILEFILE(d_i1,size_i1) 105 CALL eomccsd_density1_1(d_d1,k_d1_offset,d_i1,k_i1_offset,d_i0,k_i 106 &0_offset) 107 CALL DELETEFILE(d_i1) 108 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('eomccsd_density1 109 &',-1,MA_ERR) 110 CALL OFFSET_eomccsd_density1_2_1(l_i1_offset,k_i1_offset,size_i1) 111 CALL TCE_FILENAME('eomccsd_density1_2_1_i1',filename) 112 CALL CREATEFILE(filename,d_i1,size_i1) 113 CALL eomccsd_density1_2_1(d_d1,k_d1_offset,d_x1,k_x1_offset,d_i1,k 114 &_i1_offset) 115 CALL OFFSET_eomccsd_density1_2_2_1(l_i2_offset,k_i2_offset,size_i2 116 &) 117 CALL TCE_FILENAME('eomccsd_density1_2_2_1_i2',filename) 118 CALL CREATEFILE(filename,d_i2,size_i2) 119 CALL eomccsd_density1_2_2_1(d_d1,k_d1_offset,d_t1,k_t1_offset,d_i2 120 &,k_i2_offset) 121 CALL RECONCILEFILE(d_i2,size_i2) 122 CALL eomccsd_density1_2_2(d_x0,k_x0_offset,d_i2,k_i2_offset,d_i1,k 123 &_i1_offset) 124 CALL DELETEFILE(d_i2) 125 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 126 &',-1,MA_ERR) 127 CALL RECONCILEFILE(d_i1,size_i1) 128 CALL eomccsd_density1_2(d_y0,k_y0_offset,d_i1,k_i1_offset,d_i0,k_i 129 &0_offset) 130 CALL DELETEFILE(d_i1) 131 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('eomccsd_density1 132 &',-1,MA_ERR) 133 CALL OFFSET_eomccsd_density1_3_1(l_i1_offset,k_i1_offset,size_i1) 134 CALL TCE_FILENAME('eomccsd_density1_3_1_i1',filename) 135 CALL CREATEFILE(filename,d_i1,size_i1) 136 CALL eomccsd_density1_3_1(d_x1,k_x1_offset,d_y1,k_y1_offset,d_i1,k 137 &_i1_offset) 138 CALL eomccsd_density1_3_2(d_x2,k_x2_offset,d_y2,k_y2_offset,d_i1,k 139 &_i1_offset) 140 CALL OFFSET_eomccsd_density1_3_3_1(l_i2_offset,k_i2_offset,size_i2 141 &) 142 CALL TCE_FILENAME('eomccsd_density1_3_3_1_i2',filename) 143 CALL CREATEFILE(filename,d_i2,size_i2) 144 CALL eomccsd_density1_3_3_1(d_t1,k_t1_offset,d_y1,k_y1_offset,d_i2 145 &,k_i2_offset) 146 CALL eomccsd_density1_3_3_2(d_t2,k_t2_offset,d_y2,k_y2_offset,d_i2 147 &,k_i2_offset) 148 CALL RECONCILEFILE(d_i2,size_i2) 149 CALL eomccsd_density1_3_3(d_x0,k_x0_offset,d_i2,k_i2_offset,d_i1,k 150 &_i1_offset) 151 CALL DELETEFILE(d_i2) 152 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 153 &',-1,MA_ERR) 154 CALL OFFSET_eomccsd_density1_3_4_1(l_i2_offset,k_i2_offset,size_i2 155 &) 156 CALL TCE_FILENAME('eomccsd_density1_3_4_1_i2',filename) 157 CALL CREATEFILE(filename,d_i2,size_i2) 158 CALL eomccsd_density1_3_4_1(d_x1,k_x1_offset,d_y2,k_y2_offset,d_i2 159 &,k_i2_offset) 160 CALL RECONCILEFILE(d_i2,size_i2) 161 CALL eomccsd_density1_3_4(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k 162 &_i1_offset) 163 CALL DELETEFILE(d_i2) 164 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 165 &',-1,MA_ERR) 166 CALL RECONCILEFILE(d_i1,size_i1) 167 CALL eomccsd_density1_3(d_d1,k_d1_offset,d_i1,k_i1_offset,d_i0,k_i 168 &0_offset) 169 CALL DELETEFILE(d_i1) 170 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('eomccsd_density1 171 &',-1,MA_ERR) 172 CALL OFFSET_eomccsd_density1_4_1(l_i1_offset,k_i1_offset,size_i1) 173 CALL TCE_FILENAME('eomccsd_density1_4_1_i1',filename) 174 CALL CREATEFILE(filename,d_i1,size_i1) 175 CALL eomccsd_density1_4_1(d_d1,k_d1_offset,d_x1,k_x1_offset,d_i1,k 176 &_i1_offset) 177 CALL OFFSET_eomccsd_density1_4_2_1(l_i2_offset,k_i2_offset,size_i2 178 &) 179 CALL TCE_FILENAME('eomccsd_density1_4_2_1_i2',filename) 180 CALL CREATEFILE(filename,d_i2,size_i2) 181 CALL eomccsd_density1_4_2_1(d_d1,k_d1_offset,d_t1,k_t1_offset,d_i2 182 &,k_i2_offset) 183 CALL RECONCILEFILE(d_i2,size_i2) 184 CALL eomccsd_density1_4_2(d_x0,k_x0_offset,d_i2,k_i2_offset,d_i1,k 185 &_i1_offset) 186 CALL DELETEFILE(d_i2) 187 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 188 &',-1,MA_ERR) 189 CALL RECONCILEFILE(d_i1,size_i1) 190 CALL eomccsd_density1_4(d_y1,k_y1_offset,d_i1,k_i1_offset,d_i0,k_i 191 &0_offset) 192 CALL DELETEFILE(d_i1) 193 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('eomccsd_density1 194 &',-1,MA_ERR) 195 CALL OFFSET_eomccsd_density1_5_1(l_i1_offset,k_i1_offset,size_i1) 196 CALL TCE_FILENAME('eomccsd_density1_5_1_i1',filename) 197 CALL CREATEFILE(filename,d_i1,size_i1) 198 CALL eomccsd_density1_5_1(d_x2,k_x2_offset,d_y1,k_y1_offset,d_i1,k 199 &_i1_offset) 200 CALL OFFSET_eomccsd_density1_5_2_1(l_i2_offset,k_i2_offset,size_i2 201 &) 202 CALL TCE_FILENAME('eomccsd_density1_5_2_1_i2',filename) 203 CALL CREATEFILE(filename,d_i2,size_i2) 204 CALL eomccsd_density1_5_2_1(d_x1,k_x1_offset,d_y1,k_y1_offset,d_i2 205 &,k_i2_offset) 206 CALL eomccsd_density1_5_2_2(d_x2,k_x2_offset,d_y2,k_y2_offset,d_i2 207 &,k_i2_offset) 208 CALL OFFSET_eomccsd_density1_5_2_3_1(l_i3_offset,k_i3_offset,size_ 209 &i3) 210 CALL TCE_FILENAME('eomccsd_density1_5_2_3_1_i3',filename) 211 CALL CREATEFILE(filename,d_i3,size_i3) 212 CALL eomccsd_density1_5_2_3_1(d_t1,k_t1_offset,d_y1,k_y1_offset,d_ 213 &i3,k_i3_offset) 214 CALL eomccsd_density1_5_2_3_2(d_t2,k_t2_offset,d_y2,k_y2_offset,d_ 215 &i3,k_i3_offset) 216 CALL RECONCILEFILE(d_i3,size_i3) 217 CALL eomccsd_density1_5_2_3(d_x0,k_x0_offset,d_i3,k_i3_offset,d_i2 218 &,k_i2_offset) 219 CALL DELETEFILE(d_i3) 220 IF (.not.MA_POP_STACK(l_i3_offset)) CALL ERRQUIT('eomccsd_density1 221 &',-1,MA_ERR) 222 CALL OFFSET_eomccsd_density1_5_2_4_1(l_i3_offset,k_i3_offset,size_ 223 &i3) 224 CALL TCE_FILENAME('eomccsd_density1_5_2_4_1_i3',filename) 225 CALL CREATEFILE(filename,d_i3,size_i3) 226 CALL eomccsd_density1_5_2_4_1(d_x1,k_x1_offset,d_y2,k_y2_offset,d_ 227 &i3,k_i3_offset) 228 CALL RECONCILEFILE(d_i3,size_i3) 229 CALL eomccsd_density1_5_2_4(d_t1,k_t1_offset,d_i3,k_i3_offset,d_i2 230 &,k_i2_offset) 231 CALL DELETEFILE(d_i3) 232 IF (.not.MA_POP_STACK(l_i3_offset)) CALL ERRQUIT('eomccsd_density1 233 &',-1,MA_ERR) 234 CALL RECONCILEFILE(d_i2,size_i2) 235 CALL eomccsd_density1_5_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k 236 &_i1_offset) 237 CALL DELETEFILE(d_i2) 238 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 239 &',-1,MA_ERR) 240 CALL OFFSET_eomccsd_density1_5_3_1(l_i2_offset,k_i2_offset,size_i2 241 &) 242 CALL TCE_FILENAME('eomccsd_density1_5_3_1_i2',filename) 243 CALL CREATEFILE(filename,d_i2,size_i2) 244 CALL eomccsd_density1_5_3_1(d_t1,k_t1_offset,d_y1,k_y1_offset,d_i2 245 &,k_i2_offset) 246 CALL eomccsd_density1_5_3_2(d_t2,k_t2_offset,d_y2,k_y2_offset,d_i2 247 &,k_i2_offset) 248 CALL RECONCILEFILE(d_i2,size_i2) 249 CALL eomccsd_density1_5_3(d_x1,k_x1_offset,d_i2,k_i2_offset,d_i1,k 250 &_i1_offset) 251 CALL DELETEFILE(d_i2) 252 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 253 &',-1,MA_ERR) 254 CALL OFFSET_eomccsd_density1_5_4_1(l_i2_offset,k_i2_offset,size_i2 255 &) 256 CALL TCE_FILENAME('eomccsd_density1_5_4_1_i2',filename) 257 CALL CREATEFILE(filename,d_i2,size_i2) 258 CALL eomccsd_density1_5_4_1(d_x1,k_x1_offset,d_y1,k_y1_offset,d_i2 259 &,k_i2_offset) 260 CALL eomccsd_density1_5_4_2(d_x2,k_x2_offset,d_y2,k_y2_offset,d_i2 261 &,k_i2_offset) 262 CALL RECONCILEFILE(d_i2,size_i2) 263 CALL eomccsd_density1_5_4(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k 264 &_i1_offset) 265 CALL DELETEFILE(d_i2) 266 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 267 &',-1,MA_ERR) 268 CALL OFFSET_eomccsd_density1_5_5_1(l_i2_offset,k_i2_offset,size_i2 269 &) 270 CALL TCE_FILENAME('eomccsd_density1_5_5_1_i2',filename) 271 CALL CREATEFILE(filename,d_i2,size_i2) 272 CALL eomccsd_density1_5_5_1(d_t1,k_t1_offset,d_y2,k_y2_offset,d_i2 273 &,k_i2_offset) 274 CALL RECONCILEFILE(d_i2,size_i2) 275 CALL eomccsd_density1_5_5(d_x2,k_x2_offset,d_i2,k_i2_offset,d_i1,k 276 &_i1_offset) 277 CALL DELETEFILE(d_i2) 278 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 279 &',-1,MA_ERR) 280 CALL OFFSET_eomccsd_density1_5_6_1(l_i2_offset,k_i2_offset,size_i2 281 &) 282 CALL TCE_FILENAME('eomccsd_density1_5_6_1_i2',filename) 283 CALL CREATEFILE(filename,d_i2,size_i2) 284 CALL eomccsd_density1_5_6_1(d_x0,k_x0_offset,d_y1,k_y1_offset,d_i2 285 &,k_i2_offset) 286 CALL eomccsd_density1_5_6_2(d_x1,k_x1_offset,d_y2,k_y2_offset,d_i2 287 &,k_i2_offset) 288 CALL RECONCILEFILE(d_i2,size_i2) 289 CALL eomccsd_density1_5_6(d_t2,k_t2_offset,d_i2,k_i2_offset,d_i1,k 290 &_i1_offset) 291 CALL DELETEFILE(d_i2) 292 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 293 &',-1,MA_ERR) 294 CALL OFFSET_eomccsd_density1_5_7_1(l_i2_offset,k_i2_offset,size_i2 295 &) 296 CALL TCE_FILENAME('eomccsd_density1_5_7_1_i2',filename) 297 CALL CREATEFILE(filename,d_i2,size_i2) 298 CALL eomccsd_density1_5_7_1(d_x1,k_x1_offset,d_y2,k_y2_offset,d_i2 299 &,k_i2_offset) 300 CALL RECONCILEFILE(d_i2,size_i2) 301 CALL eomccsd_density1_5_7(d_t2,k_t2_offset,d_i2,k_i2_offset,d_i1,k 302 &_i1_offset) 303 CALL DELETEFILE(d_i2) 304 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 305 &',-1,MA_ERR) 306 CALL OFFSET_eomccsd_density1_5_8_1(l_i2_offset,k_i2_offset,size_i2 307 &) 308 CALL TCE_FILENAME('eomccsd_density1_5_8_1_i2',filename) 309 CALL CREATEFILE(filename,d_i2,size_i2) 310 CALL OFFSET_eomccsd_density1_5_8_1_1(l_i3_offset,k_i3_offset,size_ 311 &i3) 312 CALL TCE_FILENAME('eomccsd_density1_5_8_1_1_i3',filename) 313 CALL CREATEFILE(filename,d_i3,size_i3) 314 CALL eomccsd_density1_5_8_1_1(d_t1,k_t1_offset,d_y2,k_y2_offset,d_ 315 &i3,k_i3_offset) 316 CALL RECONCILEFILE(d_i3,size_i3) 317 CALL eomccsd_density1_5_8_1(d_t2,k_t2_offset,d_i3,k_i3_offset,d_i2 318 &,k_i2_offset) 319 CALL DELETEFILE(d_i3) 320 IF (.not.MA_POP_STACK(l_i3_offset)) CALL ERRQUIT('eomccsd_density1 321 &',-1,MA_ERR) 322 CALL RECONCILEFILE(d_i2,size_i2) 323 CALL eomccsd_density1_5_8(d_x0,k_x0_offset,d_i2,k_i2_offset,d_i1,k 324 &_i1_offset) 325 CALL DELETEFILE(d_i2) 326 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 327 &',-1,MA_ERR) 328 CALL RECONCILEFILE(d_i1,size_i1) 329 CALL eomccsd_density1_5(d_d1,k_d1_offset,d_i1,k_i1_offset,d_i0,k_i 330 &0_offset) 331 CALL DELETEFILE(d_i1) 332 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('eomccsd_density1 333 &',-1,MA_ERR) 334 CALL OFFSET_eomccsd_density1_6_1(l_i1_offset,k_i1_offset,size_i1) 335 CALL TCE_FILENAME('eomccsd_density1_6_1_i1',filename) 336 CALL CREATEFILE(filename,d_i1,size_i1) 337 CALL eomccsd_density1_6_1(d_x2,k_x2_offset,d_y2,k_y2_offset,d_i1,k 338 &_i1_offset) 339 CALL OFFSET_eomccsd_density1_6_2_1(l_i2_offset,k_i2_offset,size_i2 340 &) 341 CALL TCE_FILENAME('eomccsd_density1_6_2_1_i2',filename) 342 CALL CREATEFILE(filename,d_i2,size_i2) 343 CALL eomccsd_density1_6_2_1(d_x1,k_x1_offset,d_y2,k_y2_offset,d_i2 344 &,k_i2_offset) 345 CALL RECONCILEFILE(d_i2,size_i2) 346 CALL eomccsd_density1_6_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k 347 &_i1_offset) 348 CALL DELETEFILE(d_i2) 349 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 350 &',-1,MA_ERR) 351 CALL OFFSET_eomccsd_density1_6_3_1(l_i2_offset,k_i2_offset,size_i2 352 &) 353 CALL TCE_FILENAME('eomccsd_density1_6_3_1_i2',filename) 354 CALL CREATEFILE(filename,d_i2,size_i2) 355 CALL eomccsd_density1_6_3_1(d_t2,k_t2_offset,d_y2,k_y2_offset,d_i2 356 &,k_i2_offset) 357 CALL RECONCILEFILE(d_i2,size_i2) 358 CALL eomccsd_density1_6_3(d_x0,k_x0_offset,d_i2,k_i2_offset,d_i1,k 359 &_i1_offset) 360 CALL DELETEFILE(d_i2) 361 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('eomccsd_density1 362 &',-1,MA_ERR) 363 CALL RECONCILEFILE(d_i1,size_i1) 364 CALL eomccsd_density1_6(d_d1,k_d1_offset,d_i1,k_i1_offset,d_i0,k_i 365 &0_offset) 366 CALL DELETEFILE(d_i1) 367 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('eomccsd_density1 368 &',-1,MA_ERR) 369 RETURN 370 END 371 SUBROUTINE eomccsd_density1_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_ 372 &c_offset) 373C $Id$ 374C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 375C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 376C i0 ( )_yxd + = 1 * Sum ( h2 p1 ) * d ( p1 h2 )_d * i1 ( h2 p1 )_yx 377 IMPLICIT NONE 378#include "global.fh" 379#include "mafdecls.fh" 380#include "sym.fh" 381#include "errquit.fh" 382#include "tce.fh" 383 INTEGER d_a 384 INTEGER k_a_offset 385 INTEGER d_b 386 INTEGER k_b_offset 387 INTEGER d_c 388 INTEGER k_c_offset 389 INTEGER NXTASK 390 INTEGER next 391 INTEGER nprocs 392 INTEGER count 393 INTEGER dimc 394 INTEGER l_c_sort 395 INTEGER k_c_sort 396 INTEGER p1b 397 INTEGER h2b 398 INTEGER p1b_1 399 INTEGER h2b_1 400 INTEGER h2b_2 401 INTEGER p1b_2 402 INTEGER dim_common 403 INTEGER dima_sort 404 INTEGER dima 405 INTEGER dimb_sort 406 INTEGER dimb 407 INTEGER l_a_sort 408 INTEGER k_a_sort 409 INTEGER l_a 410 INTEGER k_a 411 INTEGER l_b_sort 412 INTEGER k_b_sort 413 INTEGER l_b 414 INTEGER k_b 415 INTEGER l_c 416 INTEGER k_c 417 EXTERNAL NXTASK 418 nprocs = GA_NNODES() 419 count = 0 420 next = NXTASK(nprocs,1) 421 IF (next.eq.count) THEN 422 IF (0 .eq. ieor(irrep_y,ieor(irrep_x,irrep_d))) THEN 423 dimc = 1 424 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 425 & ERRQUIT('eomccsd_density1_1',0,MA_ERR) 426 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 427 DO p1b = noab+1,noab+nvab 428 DO h2b = 1,noab 429 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) THEN 430 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)) .eq. irrep_d) TH 431 &EN 432 CALL TCE_RESTRICTED_2(p1b,h2b,p1b_1,h2b_1) 433 CALL TCE_RESTRICTED_2(h2b,p1b,h2b_2,p1b_2) 434 dim_common = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1) 435 dima_sort = 1 436 dima = dim_common * dima_sort 437 dimb_sort = 1 438 dimb = dim_common * dimb_sort 439 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 440 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 441 & ERRQUIT('eomccsd_density1_1',1,MA_ERR) 442 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 443 &eomccsd_density1_1',2,MA_ERR) 444 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 445 & - 1 + (noab+nvab) * (p1b_1 - 1))) 446 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 447 &,int_mb(k_range+h2b-1),2,1,1.0d0) 448 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_1',3,MA 449 &_ERR) 450 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 451 & ERRQUIT('eomccsd_density1_1',4,MA_ERR) 452 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 453 &eomccsd_density1_1',5,MA_ERR) 454 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 455 & - noab - 1 + nvab * (h2b_2 - 1))) 456 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 457 &,int_mb(k_range+p1b-1),1,2,1.0d0) 458 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_1',6,MA 459 &_ERR) 460 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 461 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 462 &t),dima_sort) 463 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_1' 464 &,7,MA_ERR) 465 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_1' 466 &,8,MA_ERR) 467 END IF 468 END IF 469 END IF 470 END DO 471 END DO 472 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 473 &eomccsd_density1_1',9,MA_ERR) 474 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 475 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 476 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_1',10,M 477 &A_ERR) 478 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_1' 479 &,11,MA_ERR) 480 END IF 481 next = NXTASK(nprocs,1) 482 END IF 483 count = count + 1 484 next = NXTASK(-nprocs,1) 485 call GA_SYNC() 486 RETURN 487 END 488 SUBROUTINE eomccsd_density1_1_1(d_a,k_a_offset,d_b,k_b_offset,d_c, 489 &k_c_offset) 490C $Id$ 491C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 492C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 493C i1 ( h2 p1 )_yx + = 1 * x ( )_x * y ( h2 p1 )_y 494 IMPLICIT NONE 495#include "global.fh" 496#include "mafdecls.fh" 497#include "sym.fh" 498#include "errquit.fh" 499#include "tce.fh" 500 INTEGER d_a 501 INTEGER k_a_offset 502 INTEGER d_b 503 INTEGER k_b_offset 504 INTEGER d_c 505 INTEGER k_c_offset 506 INTEGER NXTASK 507 INTEGER next 508 INTEGER nprocs 509 INTEGER count 510 INTEGER h2b 511 INTEGER p1b 512 INTEGER dimc 513 INTEGER l_c_sort 514 INTEGER k_c_sort 515 INTEGER h2b_2 516 INTEGER p1b_2 517 INTEGER dim_common 518 INTEGER dima_sort 519 INTEGER dima 520 INTEGER dimb_sort 521 INTEGER dimb 522 INTEGER l_a_sort 523 INTEGER k_a_sort 524 INTEGER l_a 525 INTEGER k_a 526 INTEGER l_b_sort 527 INTEGER k_b_sort 528 INTEGER l_b 529 INTEGER k_b 530 INTEGER l_c 531 INTEGER k_c 532 EXTERNAL NXTASK 533 nprocs = GA_NNODES() 534 count = 0 535 next = NXTASK(nprocs,1) 536 DO h2b = 1,noab 537 DO p1b = noab+1,noab+nvab 538 IF (next.eq.count) THEN 539 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1 540 &).ne.4)) THEN 541 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 542 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 543 &y,irrep_x)) THEN 544 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 545 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 546 & ERRQUIT('eomccsd_density1_1_1',0,MA_ERR) 547 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 548 IF (0 .eq. irrep_x) THEN 549 CALL TCE_RESTRICTED_2(h2b,p1b,h2b_2,p1b_2) 550 dim_common = 1 551 dima_sort = 1 552 dima = dim_common * dima_sort 553 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 554 dimb = dim_common * dimb_sort 555 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 556 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 557 & ERRQUIT('eomccsd_density1_1_1',1,MA_ERR) 558 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 559 &eomccsd_density1_1_1',2,MA_ERR) 560 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),0) 561 CALL TCE_SORT_0(dbl_mb(k_a),dbl_mb(k_a_sort),1.0d0) 562 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_1_1',3, 563 &MA_ERR) 564 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 565 & ERRQUIT('eomccsd_density1_1_1',4,MA_ERR) 566 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 567 &eomccsd_density1_1_1',5,MA_ERR) 568 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 569 & - noab - 1 + nvab * (h2b_2 - 1))) 570 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 571 &,int_mb(k_range+p1b-1),2,1,1.0d0) 572 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_1_1',6, 573 &MA_ERR) 574 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 575 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 576 &t),dima_sort) 577 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_1_ 578 &1',7,MA_ERR) 579 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_1_ 580 &1',8,MA_ERR) 581 END IF 582 END IF 583 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 584 &eomccsd_density1_1_1',9,MA_ERR) 585 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 586 &,int_mb(k_range+h2b-1),2,1,1.0d0) 587 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b - 588 & noab - 1 + nvab * (h2b - 1))) 589 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_1_1',10 590 &,MA_ERR) 591 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_1_ 592 &1',11,MA_ERR) 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 next = NXTASK(-nprocs,1) 602 call GA_SYNC() 603 RETURN 604 END 605 SUBROUTINE OFFSET_eomccsd_density1_1_1(l_a_offset,k_a_offset,size) 606C $Id$ 607C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 608C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 609C i1 ( h2 p1 )_yx 610 IMPLICIT NONE 611#include "global.fh" 612#include "mafdecls.fh" 613#include "sym.fh" 614#include "errquit.fh" 615#include "tce.fh" 616 INTEGER l_a_offset 617 INTEGER k_a_offset 618 INTEGER size 619 INTEGER length 620 INTEGER addr 621 INTEGER h2b 622 INTEGER p1b 623 length = 0 624 DO h2b = 1,noab 625 DO p1b = noab+1,noab+nvab 626 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 627 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 628 &y,irrep_x)) THEN 629 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1 630 &).ne.4)) THEN 631 length = length + 1 632 END IF 633 END IF 634 END IF 635 END DO 636 END DO 637 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 638 &set)) CALL ERRQUIT('eomccsd_density1_1_1',0,MA_ERR) 639 int_mb(k_a_offset) = length 640 addr = 0 641 size = 0 642 DO h2b = 1,noab 643 DO p1b = noab+1,noab+nvab 644 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 645 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 646 &y,irrep_x)) THEN 647 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1 648 &).ne.4)) THEN 649 addr = addr + 1 650 int_mb(k_a_offset+addr) = p1b - noab - 1 + nvab * (h2b - 1) 651 int_mb(k_a_offset+length+addr) = size 652 size = size + int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 653 END IF 654 END IF 655 END IF 656 END DO 657 END DO 658 RETURN 659 END 660 SUBROUTINE eomccsd_density1_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 661 &k_c_offset) 662C $Id$ 663C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 664C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 665C i1 ( h2 p1 )_yx + = 1 * Sum ( h4 p3 ) * x ( p3 h4 )_x * y ( h2 h4 p1 p3 )_y 666 IMPLICIT NONE 667#include "global.fh" 668#include "mafdecls.fh" 669#include "sym.fh" 670#include "errquit.fh" 671#include "tce.fh" 672 INTEGER d_a 673 INTEGER k_a_offset 674 INTEGER d_b 675 INTEGER k_b_offset 676 INTEGER d_c 677 INTEGER k_c_offset 678 INTEGER NXTASK 679 INTEGER next 680 INTEGER nprocs 681 INTEGER count 682 INTEGER h2b 683 INTEGER p1b 684 INTEGER dimc 685 INTEGER l_c_sort 686 INTEGER k_c_sort 687 INTEGER p3b 688 INTEGER h4b 689 INTEGER p3b_1 690 INTEGER h4b_1 691 INTEGER h2b_2 692 INTEGER h4b_2 693 INTEGER p1b_2 694 INTEGER p3b_2 695 INTEGER dim_common 696 INTEGER dima_sort 697 INTEGER dima 698 INTEGER dimb_sort 699 INTEGER dimb 700 INTEGER l_a_sort 701 INTEGER k_a_sort 702 INTEGER l_a 703 INTEGER k_a 704 INTEGER l_b_sort 705 INTEGER k_b_sort 706 INTEGER l_b 707 INTEGER k_b 708 INTEGER l_c 709 INTEGER k_c 710 EXTERNAL NXTASK 711 nprocs = GA_NNODES() 712 count = 0 713 next = NXTASK(nprocs,1) 714 DO h2b = 1,noab 715 DO p1b = noab+1,noab+nvab 716 IF (next.eq.count) THEN 717 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1 718 &).ne.4)) THEN 719 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 720 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 721 &y,irrep_x)) THEN 722 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 723 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 724 & ERRQUIT('eomccsd_density1_1_2',0,MA_ERR) 725 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 726 DO p3b = noab+1,noab+nvab 727 DO h4b = 1,noab 728 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN 729 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_x) TH 730 &EN 731 CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1) 732 CALL TCE_RESTRICTED_4(h2b,h4b,p1b,p3b,h2b_2,h4b_2,p1b_2,p3b_2) 733 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) 734 dima_sort = 1 735 dima = dim_common * dima_sort 736 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 737 dimb = dim_common * dimb_sort 738 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 739 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 740 & ERRQUIT('eomccsd_density1_1_2',1,MA_ERR) 741 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 742 &eomccsd_density1_1_2',2,MA_ERR) 743 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 744 & - 1 + noab * (p3b_1 - noab - 1))) 745 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 746 &,int_mb(k_range+h4b-1),2,1,1.0d0) 747 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_1_2',3, 748 &MA_ERR) 749 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 750 & ERRQUIT('eomccsd_density1_1_2',4,MA_ERR) 751 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 752 &eomccsd_density1_1_2',5,MA_ERR) 753 IF ((h4b .lt. h2b) .and. (p3b .lt. p1b)) THEN 754 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 755 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 756 &* (h4b_2 - 1))))) 757 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 758 &,int_mb(k_range+h2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p1b-1) 759 &,4,2,1,3,1.0d0) 760 END IF 761 IF ((h4b .lt. h2b) .and. (p1b .le. p3b)) THEN 762 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 763 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 764 &* (h4b_2 - 1))))) 765 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 766 &,int_mb(k_range+h2b-1),int_mb(k_range+p1b-1),int_mb(k_range+p3b-1) 767 &,3,2,1,4,-1.0d0) 768 END IF 769 IF ((h2b .le. h4b) .and. (p3b .lt. p1b)) THEN 770 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 771 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h4b_2 - 1 + noab 772 &* (h2b_2 - 1))))) 773 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 774 &,int_mb(k_range+h4b-1),int_mb(k_range+p3b-1),int_mb(k_range+p1b-1) 775 &,4,1,2,3,-1.0d0) 776 END IF 777 IF ((h2b .le. h4b) .and. (p1b .le. p3b)) THEN 778 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 779 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (h4b_2 - 1 + noab 780 &* (h2b_2 - 1))))) 781 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 782 &,int_mb(k_range+h4b-1),int_mb(k_range+p1b-1),int_mb(k_range+p3b-1) 783 &,3,1,2,4,1.0d0) 784 END IF 785 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_1_2',6, 786 &MA_ERR) 787 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 788 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 789 &t),dima_sort) 790 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_1_ 791 &2',7,MA_ERR) 792 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_1_ 793 &2',8,MA_ERR) 794 END IF 795 END IF 796 END IF 797 END DO 798 END DO 799 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 800 &eomccsd_density1_1_2',9,MA_ERR) 801 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 802 &,int_mb(k_range+h2b-1),2,1,1.0d0) 803 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b - 804 & noab - 1 + nvab * (h2b - 1))) 805 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_1_2',10 806 &,MA_ERR) 807 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_1_ 808 &2',11,MA_ERR) 809 END IF 810 END IF 811 END IF 812 next = NXTASK(nprocs,1) 813 END IF 814 count = count + 1 815 END DO 816 END DO 817 next = NXTASK(-nprocs,1) 818 call GA_SYNC() 819 RETURN 820 END 821 SUBROUTINE eomccsd_density1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_ 822 &c_offset) 823C $Id$ 824C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 825C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 826C i0 ( )_dxy + = 1 * y ( )_y * i1 ( )_dx 827 IMPLICIT NONE 828#include "global.fh" 829#include "mafdecls.fh" 830#include "sym.fh" 831#include "errquit.fh" 832#include "tce.fh" 833 INTEGER d_a 834 INTEGER k_a_offset 835 INTEGER d_b 836 INTEGER k_b_offset 837 INTEGER d_c 838 INTEGER k_c_offset 839 INTEGER NXTASK 840 INTEGER next 841 INTEGER nprocs 842 INTEGER count 843 INTEGER dimc 844 INTEGER l_c_sort 845 INTEGER k_c_sort 846 INTEGER dim_common 847 INTEGER dima_sort 848 INTEGER dima 849 INTEGER dimb_sort 850 INTEGER dimb 851 INTEGER l_a_sort 852 INTEGER k_a_sort 853 INTEGER l_a 854 INTEGER k_a 855 INTEGER l_b_sort 856 INTEGER k_b_sort 857 INTEGER l_b 858 INTEGER k_b 859 INTEGER l_c 860 INTEGER k_c 861 EXTERNAL NXTASK 862 nprocs = GA_NNODES() 863 count = 0 864 next = NXTASK(nprocs,1) 865 IF (next.eq.count) THEN 866 IF (0 .eq. ieor(irrep_d,ieor(irrep_x,irrep_y))) THEN 867 dimc = 1 868 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 869 & ERRQUIT('eomccsd_density1_2',0,MA_ERR) 870 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 871 IF (0 .eq. irrep_y) THEN 872 dim_common = 1 873 dima_sort = 1 874 dima = dim_common * dima_sort 875 dimb_sort = 1 876 dimb = dim_common * dimb_sort 877 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 878 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 879 & ERRQUIT('eomccsd_density1_2',1,MA_ERR) 880 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 881 &eomccsd_density1_2',2,MA_ERR) 882 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),0) 883 CALL TCE_SORT_0(dbl_mb(k_a),dbl_mb(k_a_sort),1.0d0) 884 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_2',3,MA 885 &_ERR) 886 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 887 & ERRQUIT('eomccsd_density1_2',4,MA_ERR) 888 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 889 &eomccsd_density1_2',5,MA_ERR) 890 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),0) 891 CALL TCE_SORT_0(dbl_mb(k_b),dbl_mb(k_b_sort),1.0d0) 892 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_2',6,MA 893 &_ERR) 894 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 895 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 896 &t),dima_sort) 897 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_2' 898 &,7,MA_ERR) 899 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_2' 900 &,8,MA_ERR) 901 END IF 902 END IF 903 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 904 &eomccsd_density1_2',9,MA_ERR) 905 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 906 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 907 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_2',10,M 908 &A_ERR) 909 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_2' 910 &,11,MA_ERR) 911 END IF 912 next = NXTASK(nprocs,1) 913 END IF 914 count = count + 1 915 next = NXTASK(-nprocs,1) 916 call GA_SYNC() 917 RETURN 918 END 919 SUBROUTINE eomccsd_density1_2_1(d_a,k_a_offset,d_b,k_b_offset,d_c, 920 &k_c_offset) 921C $Id$ 922C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 923C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 924C i1 ( )_dx + = 1 * Sum ( h1 p2 ) * d ( h1 p2 )_d * x ( p2 h1 )_x 925 IMPLICIT NONE 926#include "global.fh" 927#include "mafdecls.fh" 928#include "sym.fh" 929#include "errquit.fh" 930#include "tce.fh" 931 INTEGER d_a 932 INTEGER k_a_offset 933 INTEGER d_b 934 INTEGER k_b_offset 935 INTEGER d_c 936 INTEGER k_c_offset 937 INTEGER NXTASK 938 INTEGER next 939 INTEGER nprocs 940 INTEGER count 941 INTEGER dimc 942 INTEGER l_c_sort 943 INTEGER k_c_sort 944 INTEGER h1b 945 INTEGER p2b 946 INTEGER h1b_1 947 INTEGER p2b_1 948 INTEGER p2b_2 949 INTEGER h1b_2 950 INTEGER dim_common 951 INTEGER dima_sort 952 INTEGER dima 953 INTEGER dimb_sort 954 INTEGER dimb 955 INTEGER l_a_sort 956 INTEGER k_a_sort 957 INTEGER l_a 958 INTEGER k_a 959 INTEGER l_b_sort 960 INTEGER k_b_sort 961 INTEGER l_b 962 INTEGER k_b 963 INTEGER l_c 964 INTEGER k_c 965 EXTERNAL NXTASK 966 nprocs = GA_NNODES() 967 count = 0 968 next = NXTASK(nprocs,1) 969 IF (next.eq.count) THEN 970 IF (0 .eq. ieor(irrep_d,irrep_x)) THEN 971 dimc = 1 972 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 973 & ERRQUIT('eomccsd_density1_2_1',0,MA_ERR) 974 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 975 DO h1b = 1,noab 976 DO p2b = noab+1,noab+nvab 977 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+p2b-1)) THEN 978 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+p2b-1)) .eq. irrep_d) TH 979 &EN 980 CALL TCE_RESTRICTED_2(h1b,p2b,h1b_1,p2b_1) 981 CALL TCE_RESTRICTED_2(p2b,h1b,p2b_2,h1b_2) 982 dim_common = int_mb(k_range+h1b-1) * int_mb(k_range+p2b-1) 983 dima_sort = 1 984 dima = dim_common * dima_sort 985 dimb_sort = 1 986 dimb = dim_common * dimb_sort 987 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 988 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 989 & ERRQUIT('eomccsd_density1_2_1',1,MA_ERR) 990 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 991 &eomccsd_density1_2_1',2,MA_ERR) 992 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 993 & - 1 + (noab+nvab) * (h1b_1 - 1))) 994 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h1b-1) 995 &,int_mb(k_range+p2b-1),2,1,1.0d0) 996 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_2_1',3, 997 &MA_ERR) 998 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 999 & ERRQUIT('eomccsd_density1_2_1',4,MA_ERR) 1000 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1001 &eomccsd_density1_2_1',5,MA_ERR) 1002 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 1003 & - 1 + noab * (p2b_2 - noab - 1))) 1004 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1) 1005 &,int_mb(k_range+h1b-1),1,2,1.0d0) 1006 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_2_1',6, 1007 &MA_ERR) 1008 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1009 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1010 &t),dima_sort) 1011 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_2_ 1012 &1',7,MA_ERR) 1013 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_2_ 1014 &1',8,MA_ERR) 1015 END IF 1016 END IF 1017 END IF 1018 END DO 1019 END DO 1020 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1021 &eomccsd_density1_2_1',9,MA_ERR) 1022 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 1023 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 1024 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_2_1',10 1025 &,MA_ERR) 1026 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_2_ 1027 &1',11,MA_ERR) 1028 END IF 1029 next = NXTASK(nprocs,1) 1030 END IF 1031 count = count + 1 1032 next = NXTASK(-nprocs,1) 1033 call GA_SYNC() 1034 RETURN 1035 END 1036 SUBROUTINE OFFSET_eomccsd_density1_2_1(l_a_offset,k_a_offset,size) 1037C $Id$ 1038C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1039C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1040C i1 ( )_dx 1041 IMPLICIT NONE 1042#include "global.fh" 1043#include "mafdecls.fh" 1044#include "sym.fh" 1045#include "errquit.fh" 1046#include "tce.fh" 1047 INTEGER l_a_offset 1048 INTEGER k_a_offset 1049 INTEGER size 1050 INTEGER length 1051 INTEGER addr 1052 length = 0 1053 IF (0 .eq. ieor(irrep_d,irrep_x)) THEN 1054 length = length + 1 1055 END IF 1056 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1057 &set)) CALL ERRQUIT('eomccsd_density1_2_1',0,MA_ERR) 1058 int_mb(k_a_offset) = length 1059 addr = 0 1060 size = 0 1061 IF (0 .eq. ieor(irrep_d,irrep_x)) THEN 1062 addr = addr + 1 1063 int_mb(k_a_offset+addr) = 0 1064 int_mb(k_a_offset+length+addr) = size 1065 size = 1 1066 END IF 1067 RETURN 1068 END 1069 SUBROUTINE eomccsd_density1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 1070 &k_c_offset) 1071C $Id$ 1072C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1073C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1074C i1 ( )_dtx + = 1 * x ( )_x * i2 ( )_dt 1075 IMPLICIT NONE 1076#include "global.fh" 1077#include "mafdecls.fh" 1078#include "sym.fh" 1079#include "errquit.fh" 1080#include "tce.fh" 1081 INTEGER d_a 1082 INTEGER k_a_offset 1083 INTEGER d_b 1084 INTEGER k_b_offset 1085 INTEGER d_c 1086 INTEGER k_c_offset 1087 INTEGER NXTASK 1088 INTEGER next 1089 INTEGER nprocs 1090 INTEGER count 1091 INTEGER dimc 1092 INTEGER l_c_sort 1093 INTEGER k_c_sort 1094 INTEGER dim_common 1095 INTEGER dima_sort 1096 INTEGER dima 1097 INTEGER dimb_sort 1098 INTEGER dimb 1099 INTEGER l_a_sort 1100 INTEGER k_a_sort 1101 INTEGER l_a 1102 INTEGER k_a 1103 INTEGER l_b_sort 1104 INTEGER k_b_sort 1105 INTEGER l_b 1106 INTEGER k_b 1107 INTEGER l_c 1108 INTEGER k_c 1109 EXTERNAL NXTASK 1110 nprocs = GA_NNODES() 1111 count = 0 1112 next = NXTASK(nprocs,1) 1113 IF (next.eq.count) THEN 1114 IF (0 .eq. ieor(irrep_d,ieor(irrep_t,irrep_x))) THEN 1115 dimc = 1 1116 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1117 & ERRQUIT('eomccsd_density1_2_2',0,MA_ERR) 1118 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1119 IF (0 .eq. irrep_x) THEN 1120 dim_common = 1 1121 dima_sort = 1 1122 dima = dim_common * dima_sort 1123 dimb_sort = 1 1124 dimb = dim_common * dimb_sort 1125 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1126 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1127 & ERRQUIT('eomccsd_density1_2_2',1,MA_ERR) 1128 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1129 &eomccsd_density1_2_2',2,MA_ERR) 1130 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),0) 1131 CALL TCE_SORT_0(dbl_mb(k_a),dbl_mb(k_a_sort),1.0d0) 1132 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_2_2',3, 1133 &MA_ERR) 1134 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1135 & ERRQUIT('eomccsd_density1_2_2',4,MA_ERR) 1136 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1137 &eomccsd_density1_2_2',5,MA_ERR) 1138 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),0) 1139 CALL TCE_SORT_0(dbl_mb(k_b),dbl_mb(k_b_sort),1.0d0) 1140 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_2_2',6, 1141 &MA_ERR) 1142 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1143 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1144 &t),dima_sort) 1145 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_2_ 1146 &2',7,MA_ERR) 1147 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_2_ 1148 &2',8,MA_ERR) 1149 END IF 1150 END IF 1151 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1152 &eomccsd_density1_2_2',9,MA_ERR) 1153 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 1154 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 1155 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_2_2',10 1156 &,MA_ERR) 1157 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_2_ 1158 &2',11,MA_ERR) 1159 END IF 1160 next = NXTASK(nprocs,1) 1161 END IF 1162 count = count + 1 1163 next = NXTASK(-nprocs,1) 1164 call GA_SYNC() 1165 RETURN 1166 END 1167 SUBROUTINE eomccsd_density1_2_2_1(d_a,k_a_offset,d_b,k_b_offset,d_ 1168 &c,k_c_offset) 1169C $Id$ 1170C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1171C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1172C i2 ( )_dt + = 1 * Sum ( h1 p2 ) * d ( h1 p2 )_d * t ( p2 h1 )_t 1173 IMPLICIT NONE 1174#include "global.fh" 1175#include "mafdecls.fh" 1176#include "sym.fh" 1177#include "errquit.fh" 1178#include "tce.fh" 1179 INTEGER d_a 1180 INTEGER k_a_offset 1181 INTEGER d_b 1182 INTEGER k_b_offset 1183 INTEGER d_c 1184 INTEGER k_c_offset 1185 INTEGER NXTASK 1186 INTEGER next 1187 INTEGER nprocs 1188 INTEGER count 1189 INTEGER dimc 1190 INTEGER l_c_sort 1191 INTEGER k_c_sort 1192 INTEGER h1b 1193 INTEGER p2b 1194 INTEGER h1b_1 1195 INTEGER p2b_1 1196 INTEGER p2b_2 1197 INTEGER h1b_2 1198 INTEGER dim_common 1199 INTEGER dima_sort 1200 INTEGER dima 1201 INTEGER dimb_sort 1202 INTEGER dimb 1203 INTEGER l_a_sort 1204 INTEGER k_a_sort 1205 INTEGER l_a 1206 INTEGER k_a 1207 INTEGER l_b_sort 1208 INTEGER k_b_sort 1209 INTEGER l_b 1210 INTEGER k_b 1211 INTEGER l_c 1212 INTEGER k_c 1213 EXTERNAL NXTASK 1214 nprocs = GA_NNODES() 1215 count = 0 1216 next = NXTASK(nprocs,1) 1217 IF (next.eq.count) THEN 1218 IF (0 .eq. ieor(irrep_d,irrep_t)) THEN 1219 dimc = 1 1220 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1221 & ERRQUIT('eomccsd_density1_2_2_1',0,MA_ERR) 1222 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1223 DO h1b = 1,noab 1224 DO p2b = noab+1,noab+nvab 1225 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+p2b-1)) THEN 1226 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+p2b-1)) .eq. irrep_d) TH 1227 &EN 1228 CALL TCE_RESTRICTED_2(h1b,p2b,h1b_1,p2b_1) 1229 CALL TCE_RESTRICTED_2(p2b,h1b,p2b_2,h1b_2) 1230 dim_common = int_mb(k_range+h1b-1) * int_mb(k_range+p2b-1) 1231 dima_sort = 1 1232 dima = dim_common * dima_sort 1233 dimb_sort = 1 1234 dimb = dim_common * dimb_sort 1235 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1236 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1237 & ERRQUIT('eomccsd_density1_2_2_1',1,MA_ERR) 1238 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1239 &eomccsd_density1_2_2_1',2,MA_ERR) 1240 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 1241 & - 1 + (noab+nvab) * (h1b_1 - 1))) 1242 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h1b-1) 1243 &,int_mb(k_range+p2b-1),2,1,1.0d0) 1244 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_2_2_1', 1245 &3,MA_ERR) 1246 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1247 & ERRQUIT('eomccsd_density1_2_2_1',4,MA_ERR) 1248 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1249 &eomccsd_density1_2_2_1',5,MA_ERR) 1250 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 1251 & - 1 + noab * (p2b_2 - noab - 1))) 1252 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1) 1253 &,int_mb(k_range+h1b-1),1,2,1.0d0) 1254 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_2_2_1', 1255 &6,MA_ERR) 1256 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1257 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1258 &t),dima_sort) 1259 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_2_ 1260 &2_1',7,MA_ERR) 1261 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_2_ 1262 &2_1',8,MA_ERR) 1263 END IF 1264 END IF 1265 END IF 1266 END DO 1267 END DO 1268 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1269 &eomccsd_density1_2_2_1',9,MA_ERR) 1270 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 1271 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 1272 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_2_2_1', 1273 &10,MA_ERR) 1274 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_2_ 1275 &2_1',11,MA_ERR) 1276 END IF 1277 next = NXTASK(nprocs,1) 1278 END IF 1279 count = count + 1 1280 next = NXTASK(-nprocs,1) 1281 call GA_SYNC() 1282 RETURN 1283 END 1284 SUBROUTINE OFFSET_eomccsd_density1_2_2_1(l_a_offset,k_a_offset,siz 1285 &e) 1286C $Id$ 1287C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1288C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1289C i2 ( )_dt 1290 IMPLICIT NONE 1291#include "global.fh" 1292#include "mafdecls.fh" 1293#include "sym.fh" 1294#include "errquit.fh" 1295#include "tce.fh" 1296 INTEGER l_a_offset 1297 INTEGER k_a_offset 1298 INTEGER size 1299 INTEGER length 1300 INTEGER addr 1301 length = 0 1302 IF (0 .eq. ieor(irrep_d,irrep_t)) THEN 1303 length = length + 1 1304 END IF 1305 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1306 &set)) CALL ERRQUIT('eomccsd_density1_2_2_1',0,MA_ERR) 1307 int_mb(k_a_offset) = length 1308 addr = 0 1309 size = 0 1310 IF (0 .eq. ieor(irrep_d,irrep_t)) THEN 1311 addr = addr + 1 1312 int_mb(k_a_offset+addr) = 0 1313 int_mb(k_a_offset+length+addr) = size 1314 size = 1 1315 END IF 1316 RETURN 1317 END 1318 SUBROUTINE eomccsd_density1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_ 1319 &c_offset) 1320C $Id$ 1321C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1322C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1323C i0 ( )_yxd + = -1 * Sum ( h2 h1 ) * d ( h1 h2 )_d * i1 ( h2 h1 )_yx 1324 IMPLICIT NONE 1325#include "global.fh" 1326#include "mafdecls.fh" 1327#include "sym.fh" 1328#include "errquit.fh" 1329#include "tce.fh" 1330 INTEGER d_a 1331 INTEGER k_a_offset 1332 INTEGER d_b 1333 INTEGER k_b_offset 1334 INTEGER d_c 1335 INTEGER k_c_offset 1336 INTEGER NXTASK 1337 INTEGER next 1338 INTEGER nprocs 1339 INTEGER count 1340 INTEGER dimc 1341 INTEGER l_c_sort 1342 INTEGER k_c_sort 1343 INTEGER h1b 1344 INTEGER h2b 1345 INTEGER h1b_1 1346 INTEGER h2b_1 1347 INTEGER h2b_2 1348 INTEGER h1b_2 1349 INTEGER dim_common 1350 INTEGER dima_sort 1351 INTEGER dima 1352 INTEGER dimb_sort 1353 INTEGER dimb 1354 INTEGER l_a_sort 1355 INTEGER k_a_sort 1356 INTEGER l_a 1357 INTEGER k_a 1358 INTEGER l_b_sort 1359 INTEGER k_b_sort 1360 INTEGER l_b 1361 INTEGER k_b 1362 INTEGER l_c 1363 INTEGER k_c 1364 EXTERNAL NXTASK 1365 nprocs = GA_NNODES() 1366 count = 0 1367 next = NXTASK(nprocs,1) 1368 IF (next.eq.count) THEN 1369 IF (0 .eq. ieor(irrep_y,ieor(irrep_x,irrep_d))) THEN 1370 dimc = 1 1371 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1372 & ERRQUIT('eomccsd_density1_3',0,MA_ERR) 1373 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1374 DO h1b = 1,noab 1375 DO h2b = 1,noab 1376 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h2b-1)) THEN 1377 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h2b-1)) .eq. irrep_d) TH 1378 &EN 1379 CALL TCE_RESTRICTED_2(h1b,h2b,h1b_1,h2b_1) 1380 CALL TCE_RESTRICTED_2(h2b,h1b,h2b_2,h1b_2) 1381 dim_common = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 1382 dima_sort = 1 1383 dima = dim_common * dima_sort 1384 dimb_sort = 1 1385 dimb = dim_common * dimb_sort 1386 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1387 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1388 & ERRQUIT('eomccsd_density1_3',1,MA_ERR) 1389 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1390 &eomccsd_density1_3',2,MA_ERR) 1391 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 1392 & - 1 + (noab+nvab) * (h1b_1 - 1))) 1393 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h1b-1) 1394 &,int_mb(k_range+h2b-1),2,1,1.0d0) 1395 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_3',3,MA 1396 &_ERR) 1397 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1398 & ERRQUIT('eomccsd_density1_3',4,MA_ERR) 1399 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1400 &eomccsd_density1_3',5,MA_ERR) 1401 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 1402 & - 1 + noab * (h2b_2 - 1))) 1403 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1404 &,int_mb(k_range+h1b-1),1,2,1.0d0) 1405 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_3',6,MA 1406 &_ERR) 1407 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1408 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1409 &t),dima_sort) 1410 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_3' 1411 &,7,MA_ERR) 1412 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_3' 1413 &,8,MA_ERR) 1414 END IF 1415 END IF 1416 END IF 1417 END DO 1418 END DO 1419 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1420 &eomccsd_density1_3',9,MA_ERR) 1421 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),-1.0d0) 1422 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 1423 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_3',10,M 1424 &A_ERR) 1425 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_3' 1426 &,11,MA_ERR) 1427 END IF 1428 next = NXTASK(nprocs,1) 1429 END IF 1430 count = count + 1 1431 next = NXTASK(-nprocs,1) 1432 call GA_SYNC() 1433 RETURN 1434 END 1435 SUBROUTINE eomccsd_density1_3_1(d_a,k_a_offset,d_b,k_b_offset,d_c, 1436 &k_c_offset) 1437C $Id$ 1438C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1439C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1440C i1 ( h2 h1 )_yx + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * y ( h2 p3 )_y 1441 IMPLICIT NONE 1442#include "global.fh" 1443#include "mafdecls.fh" 1444#include "sym.fh" 1445#include "errquit.fh" 1446#include "tce.fh" 1447 INTEGER d_a 1448 INTEGER k_a_offset 1449 INTEGER d_b 1450 INTEGER k_b_offset 1451 INTEGER d_c 1452 INTEGER k_c_offset 1453 INTEGER NXTASK 1454 INTEGER next 1455 INTEGER nprocs 1456 INTEGER count 1457 INTEGER h2b 1458 INTEGER h1b 1459 INTEGER dimc 1460 INTEGER l_c_sort 1461 INTEGER k_c_sort 1462 INTEGER p3b 1463 INTEGER p3b_1 1464 INTEGER h1b_1 1465 INTEGER h2b_2 1466 INTEGER p3b_2 1467 INTEGER dim_common 1468 INTEGER dima_sort 1469 INTEGER dima 1470 INTEGER dimb_sort 1471 INTEGER dimb 1472 INTEGER l_a_sort 1473 INTEGER k_a_sort 1474 INTEGER l_a 1475 INTEGER k_a 1476 INTEGER l_b_sort 1477 INTEGER k_b_sort 1478 INTEGER l_b 1479 INTEGER k_b 1480 INTEGER l_c 1481 INTEGER k_c 1482 EXTERNAL NXTASK 1483 nprocs = GA_NNODES() 1484 count = 0 1485 next = NXTASK(nprocs,1) 1486 DO h2b = 1,noab 1487 DO h1b = 1,noab 1488 IF (next.eq.count) THEN 1489 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 1490 &).ne.4)) THEN 1491 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1492 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1493 &y,irrep_x)) THEN 1494 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 1495 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1496 & ERRQUIT('eomccsd_density1_3_1',0,MA_ERR) 1497 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1498 DO p3b = noab+1,noab+nvab 1499 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1500 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH 1501 &EN 1502 CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1) 1503 CALL TCE_RESTRICTED_2(h2b,p3b,h2b_2,p3b_2) 1504 dim_common = int_mb(k_range+p3b-1) 1505 dima_sort = int_mb(k_range+h1b-1) 1506 dima = dim_common * dima_sort 1507 dimb_sort = int_mb(k_range+h2b-1) 1508 dimb = dim_common * dimb_sort 1509 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1510 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1511 & ERRQUIT('eomccsd_density1_3_1',1,MA_ERR) 1512 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1513 &eomccsd_density1_3_1',2,MA_ERR) 1514 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1515 & - 1 + noab * (p3b_1 - noab - 1))) 1516 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1517 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1518 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_3_1',3, 1519 &MA_ERR) 1520 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1521 & ERRQUIT('eomccsd_density1_3_1',4,MA_ERR) 1522 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1523 &eomccsd_density1_3_1',5,MA_ERR) 1524 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 1525 & - noab - 1 + nvab * (h2b_2 - 1))) 1526 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1527 &,int_mb(k_range+p3b-1),1,2,1.0d0) 1528 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_3_1',6, 1529 &MA_ERR) 1530 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1531 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1532 &t),dima_sort) 1533 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_3_ 1534 &1',7,MA_ERR) 1535 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_3_ 1536 &1',8,MA_ERR) 1537 END IF 1538 END IF 1539 END IF 1540 END DO 1541 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1542 &eomccsd_density1_3_1',9,MA_ERR) 1543 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 1544 &,int_mb(k_range+h1b-1),1,2,1.0d0) 1545 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1546 & 1 + noab * (h2b - 1))) 1547 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_3_1',10 1548 &,MA_ERR) 1549 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_3_ 1550 &1',11,MA_ERR) 1551 END IF 1552 END IF 1553 END IF 1554 next = NXTASK(nprocs,1) 1555 END IF 1556 count = count + 1 1557 END DO 1558 END DO 1559 next = NXTASK(-nprocs,1) 1560 call GA_SYNC() 1561 RETURN 1562 END 1563 SUBROUTINE OFFSET_eomccsd_density1_3_1(l_a_offset,k_a_offset,size) 1564C $Id$ 1565C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1566C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1567C i1 ( h2 h1 )_yx 1568 IMPLICIT NONE 1569#include "global.fh" 1570#include "mafdecls.fh" 1571#include "sym.fh" 1572#include "errquit.fh" 1573#include "tce.fh" 1574 INTEGER l_a_offset 1575 INTEGER k_a_offset 1576 INTEGER size 1577 INTEGER length 1578 INTEGER addr 1579 INTEGER h2b 1580 INTEGER h1b 1581 length = 0 1582 DO h2b = 1,noab 1583 DO h1b = 1,noab 1584 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1585 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1586 &y,irrep_x)) THEN 1587 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 1588 &).ne.4)) THEN 1589 length = length + 1 1590 END IF 1591 END IF 1592 END IF 1593 END DO 1594 END DO 1595 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1596 &set)) CALL ERRQUIT('eomccsd_density1_3_1',0,MA_ERR) 1597 int_mb(k_a_offset) = length 1598 addr = 0 1599 size = 0 1600 DO h2b = 1,noab 1601 DO h1b = 1,noab 1602 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1603 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1604 &y,irrep_x)) THEN 1605 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 1606 &).ne.4)) THEN 1607 addr = addr + 1 1608 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h2b - 1) 1609 int_mb(k_a_offset+length+addr) = size 1610 size = size + int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 1611 END IF 1612 END IF 1613 END IF 1614 END DO 1615 END DO 1616 RETURN 1617 END 1618 SUBROUTINE eomccsd_density1_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 1619 &k_c_offset) 1620C $Id$ 1621C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1622C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1623C i1 ( h2 h1 )_yx + = 1/2 * Sum ( h5 p4 p3 ) * x ( p3 p4 h1 h5 )_x * y ( h2 h5 p3 p4 )_y 1624 IMPLICIT NONE 1625#include "global.fh" 1626#include "mafdecls.fh" 1627#include "sym.fh" 1628#include "errquit.fh" 1629#include "tce.fh" 1630 INTEGER d_a 1631 INTEGER k_a_offset 1632 INTEGER d_b 1633 INTEGER k_b_offset 1634 INTEGER d_c 1635 INTEGER k_c_offset 1636 INTEGER NXTASK 1637 INTEGER next 1638 INTEGER nprocs 1639 INTEGER count 1640 INTEGER h2b 1641 INTEGER h1b 1642 INTEGER dimc 1643 INTEGER l_c_sort 1644 INTEGER k_c_sort 1645 INTEGER p3b 1646 INTEGER p4b 1647 INTEGER h5b 1648 INTEGER p3b_1 1649 INTEGER p4b_1 1650 INTEGER h1b_1 1651 INTEGER h5b_1 1652 INTEGER h2b_2 1653 INTEGER h5b_2 1654 INTEGER p3b_2 1655 INTEGER p4b_2 1656 INTEGER dim_common 1657 INTEGER dima_sort 1658 INTEGER dima 1659 INTEGER dimb_sort 1660 INTEGER dimb 1661 INTEGER l_a_sort 1662 INTEGER k_a_sort 1663 INTEGER l_a 1664 INTEGER k_a 1665 INTEGER l_b_sort 1666 INTEGER k_b_sort 1667 INTEGER l_b 1668 INTEGER k_b 1669 INTEGER nsuperp(2) 1670 INTEGER isuperp 1671 INTEGER l_c 1672 INTEGER k_c 1673 DOUBLE PRECISION FACTORIAL 1674 EXTERNAL NXTASK 1675 EXTERNAL FACTORIAL 1676 nprocs = GA_NNODES() 1677 count = 0 1678 next = NXTASK(nprocs,1) 1679 DO h2b = 1,noab 1680 DO h1b = 1,noab 1681 IF (next.eq.count) THEN 1682 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 1683 &).ne.4)) THEN 1684 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1685 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1686 &y,irrep_x)) THEN 1687 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 1688 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1689 & ERRQUIT('eomccsd_density1_3_2',0,MA_ERR) 1690 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1691 DO p3b = noab+1,noab+nvab 1692 DO p4b = p3b,noab+nvab 1693 DO h5b = 1,noab 1694 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 1695 &1b-1)+int_mb(k_spin+h5b-1)) THEN 1696 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 1697 &k_sym+h1b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_x) THEN 1698 CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h5b,p3b_1,p4b_1,h1b_1,h5b_1) 1699 CALL TCE_RESTRICTED_4(h2b,h5b,p3b,p4b,h2b_2,h5b_2,p3b_2,p4b_2) 1700 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m 1701 &b(k_range+h5b-1) 1702 dima_sort = int_mb(k_range+h1b-1) 1703 dima = dim_common * dima_sort 1704 dimb_sort = int_mb(k_range+h2b-1) 1705 dimb = dim_common * dimb_sort 1706 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1707 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1708 & ERRQUIT('eomccsd_density1_3_2',1,MA_ERR) 1709 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1710 &eomccsd_density1_3_2',2,MA_ERR) 1711 IF ((h5b .lt. h1b)) THEN 1712 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1713 & - 1 + noab * (h5b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 1714 &1 - noab - 1))))) 1715 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1716 &,int_mb(k_range+p4b-1),int_mb(k_range+h5b-1),int_mb(k_range+h1b-1) 1717 &,4,3,2,1,-1.0d0) 1718 END IF 1719 IF ((h1b .le. h5b)) THEN 1720 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 1721 & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 1722 &1 - noab - 1))))) 1723 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1724 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h5b-1) 1725 &,3,4,2,1,1.0d0) 1726 END IF 1727 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_3_2',3, 1728 &MA_ERR) 1729 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1730 & ERRQUIT('eomccsd_density1_3_2',4,MA_ERR) 1731 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1732 &eomccsd_density1_3_2',5,MA_ERR) 1733 IF ((h5b .lt. h2b)) THEN 1734 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 1735 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 1736 &* (h5b_2 - 1))))) 1737 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 1738 &,int_mb(k_range+h2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 1739 &,2,1,4,3,-1.0d0) 1740 END IF 1741 IF ((h2b .le. h5b)) THEN 1742 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 1743 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 1744 &* (h2b_2 - 1))))) 1745 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1746 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 1747 &,1,2,4,3,1.0d0) 1748 END IF 1749 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_3_2',6, 1750 &MA_ERR) 1751 nsuperp(1) = 1 1752 nsuperp(2) = 1 1753 isuperp = 1 1754 IF (p3b .eq. p4b) THEN 1755 nsuperp(isuperp) = nsuperp(isuperp) + 1 1756 ELSE 1757 isuperp = isuperp + 1 1758 END IF 1759 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 1760 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 1761 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 1762 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_3_ 1763 &2',7,MA_ERR) 1764 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_3_ 1765 &2',8,MA_ERR) 1766 END IF 1767 END IF 1768 END IF 1769 END DO 1770 END DO 1771 END DO 1772 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1773 &eomccsd_density1_3_2',9,MA_ERR) 1774 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 1775 &,int_mb(k_range+h1b-1),1,2,1.0d0/2.0d0) 1776 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1777 & 1 + noab * (h2b - 1))) 1778 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_3_2',10 1779 &,MA_ERR) 1780 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_3_ 1781 &2',11,MA_ERR) 1782 END IF 1783 END IF 1784 END IF 1785 next = NXTASK(nprocs,1) 1786 END IF 1787 count = count + 1 1788 END DO 1789 END DO 1790 next = NXTASK(-nprocs,1) 1791 call GA_SYNC() 1792 RETURN 1793 END 1794 SUBROUTINE eomccsd_density1_3_3(d_a,k_a_offset,d_b,k_b_offset,d_c, 1795 &k_c_offset) 1796C $Id$ 1797C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1798C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1799C i1 ( h2 h1 )_ytx + = 1 * x ( )_x * i2 ( h2 h1 )_yt 1800 IMPLICIT NONE 1801#include "global.fh" 1802#include "mafdecls.fh" 1803#include "sym.fh" 1804#include "errquit.fh" 1805#include "tce.fh" 1806 INTEGER d_a 1807 INTEGER k_a_offset 1808 INTEGER d_b 1809 INTEGER k_b_offset 1810 INTEGER d_c 1811 INTEGER k_c_offset 1812 INTEGER NXTASK 1813 INTEGER next 1814 INTEGER nprocs 1815 INTEGER count 1816 INTEGER h2b 1817 INTEGER h1b 1818 INTEGER dimc 1819 INTEGER l_c_sort 1820 INTEGER k_c_sort 1821 INTEGER h2b_2 1822 INTEGER h1b_2 1823 INTEGER dim_common 1824 INTEGER dima_sort 1825 INTEGER dima 1826 INTEGER dimb_sort 1827 INTEGER dimb 1828 INTEGER l_a_sort 1829 INTEGER k_a_sort 1830 INTEGER l_a 1831 INTEGER k_a 1832 INTEGER l_b_sort 1833 INTEGER k_b_sort 1834 INTEGER l_b 1835 INTEGER k_b 1836 INTEGER l_c 1837 INTEGER k_c 1838 EXTERNAL NXTASK 1839 nprocs = GA_NNODES() 1840 count = 0 1841 next = NXTASK(nprocs,1) 1842 DO h2b = 1,noab 1843 DO h1b = 1,noab 1844 IF (next.eq.count) THEN 1845 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 1846 &).ne.4)) THEN 1847 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1848 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1849 &y,ieor(irrep_t,irrep_x))) THEN 1850 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 1851 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1852 & ERRQUIT('eomccsd_density1_3_3',0,MA_ERR) 1853 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1854 IF (0 .eq. irrep_x) THEN 1855 CALL TCE_RESTRICTED_2(h2b,h1b,h2b_2,h1b_2) 1856 dim_common = 1 1857 dima_sort = 1 1858 dima = dim_common * dima_sort 1859 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 1860 dimb = dim_common * dimb_sort 1861 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1862 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1863 & ERRQUIT('eomccsd_density1_3_3',1,MA_ERR) 1864 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1865 &eomccsd_density1_3_3',2,MA_ERR) 1866 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),0) 1867 CALL TCE_SORT_0(dbl_mb(k_a),dbl_mb(k_a_sort),1.0d0) 1868 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_3_3',3, 1869 &MA_ERR) 1870 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1871 & ERRQUIT('eomccsd_density1_3_3',4,MA_ERR) 1872 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1873 &eomccsd_density1_3_3',5,MA_ERR) 1874 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 1875 & - 1 + noab * (h2b_2 - 1))) 1876 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1877 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1878 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_3_3',6, 1879 &MA_ERR) 1880 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1881 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1882 &t),dima_sort) 1883 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_3_ 1884 &3',7,MA_ERR) 1885 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_3_ 1886 &3',8,MA_ERR) 1887 END IF 1888 END IF 1889 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1890 &eomccsd_density1_3_3',9,MA_ERR) 1891 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 1892 &,int_mb(k_range+h2b-1),2,1,1.0d0) 1893 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1894 & 1 + noab * (h2b - 1))) 1895 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_3_3',10 1896 &,MA_ERR) 1897 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_3_ 1898 &3',11,MA_ERR) 1899 END IF 1900 END IF 1901 END IF 1902 next = NXTASK(nprocs,1) 1903 END IF 1904 count = count + 1 1905 END DO 1906 END DO 1907 next = NXTASK(-nprocs,1) 1908 call GA_SYNC() 1909 RETURN 1910 END 1911 SUBROUTINE eomccsd_density1_3_3_1(d_a,k_a_offset,d_b,k_b_offset,d_ 1912 &c,k_c_offset) 1913C $Id$ 1914C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1915C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1916C i2 ( h2 h1 )_yt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * y ( h2 p3 )_y 1917 IMPLICIT NONE 1918#include "global.fh" 1919#include "mafdecls.fh" 1920#include "sym.fh" 1921#include "errquit.fh" 1922#include "tce.fh" 1923 INTEGER d_a 1924 INTEGER k_a_offset 1925 INTEGER d_b 1926 INTEGER k_b_offset 1927 INTEGER d_c 1928 INTEGER k_c_offset 1929 INTEGER NXTASK 1930 INTEGER next 1931 INTEGER nprocs 1932 INTEGER count 1933 INTEGER h2b 1934 INTEGER h1b 1935 INTEGER dimc 1936 INTEGER l_c_sort 1937 INTEGER k_c_sort 1938 INTEGER p3b 1939 INTEGER p3b_1 1940 INTEGER h1b_1 1941 INTEGER h2b_2 1942 INTEGER p3b_2 1943 INTEGER dim_common 1944 INTEGER dima_sort 1945 INTEGER dima 1946 INTEGER dimb_sort 1947 INTEGER dimb 1948 INTEGER l_a_sort 1949 INTEGER k_a_sort 1950 INTEGER l_a 1951 INTEGER k_a 1952 INTEGER l_b_sort 1953 INTEGER k_b_sort 1954 INTEGER l_b 1955 INTEGER k_b 1956 INTEGER l_c 1957 INTEGER k_c 1958 EXTERNAL NXTASK 1959 nprocs = GA_NNODES() 1960 count = 0 1961 next = NXTASK(nprocs,1) 1962 DO h2b = 1,noab 1963 DO h1b = 1,noab 1964 IF (next.eq.count) THEN 1965 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 1966 &).ne.4)) THEN 1967 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1968 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1969 &y,irrep_t)) THEN 1970 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 1971 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1972 & ERRQUIT('eomccsd_density1_3_3_1',0,MA_ERR) 1973 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1974 DO p3b = noab+1,noab+nvab 1975 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1976 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 1977 &EN 1978 CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1) 1979 CALL TCE_RESTRICTED_2(h2b,p3b,h2b_2,p3b_2) 1980 dim_common = int_mb(k_range+p3b-1) 1981 dima_sort = int_mb(k_range+h1b-1) 1982 dima = dim_common * dima_sort 1983 dimb_sort = int_mb(k_range+h2b-1) 1984 dimb = dim_common * dimb_sort 1985 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1986 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1987 & ERRQUIT('eomccsd_density1_3_3_1',1,MA_ERR) 1988 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1989 &eomccsd_density1_3_3_1',2,MA_ERR) 1990 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1991 & - 1 + noab * (p3b_1 - noab - 1))) 1992 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1993 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1994 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_3_3_1', 1995 &3,MA_ERR) 1996 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1997 & ERRQUIT('eomccsd_density1_3_3_1',4,MA_ERR) 1998 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1999 &eomccsd_density1_3_3_1',5,MA_ERR) 2000 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 2001 & - noab - 1 + nvab * (h2b_2 - 1))) 2002 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 2003 &,int_mb(k_range+p3b-1),1,2,1.0d0) 2004 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_3_3_1', 2005 &6,MA_ERR) 2006 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2007 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2008 &t),dima_sort) 2009 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2010 &3_1',7,MA_ERR) 2011 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2012 &3_1',8,MA_ERR) 2013 END IF 2014 END IF 2015 END IF 2016 END DO 2017 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2018 &eomccsd_density1_3_3_1',9,MA_ERR) 2019 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 2020 &,int_mb(k_range+h1b-1),1,2,1.0d0) 2021 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2022 & 1 + noab * (h2b - 1))) 2023 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_3_3_1', 2024 &10,MA_ERR) 2025 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2026 &3_1',11,MA_ERR) 2027 END IF 2028 END IF 2029 END IF 2030 next = NXTASK(nprocs,1) 2031 END IF 2032 count = count + 1 2033 END DO 2034 END DO 2035 next = NXTASK(-nprocs,1) 2036 call GA_SYNC() 2037 RETURN 2038 END 2039 SUBROUTINE OFFSET_eomccsd_density1_3_3_1(l_a_offset,k_a_offset,siz 2040 &e) 2041C $Id$ 2042C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2043C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2044C i2 ( h2 h1 )_yt 2045 IMPLICIT NONE 2046#include "global.fh" 2047#include "mafdecls.fh" 2048#include "sym.fh" 2049#include "errquit.fh" 2050#include "tce.fh" 2051 INTEGER l_a_offset 2052 INTEGER k_a_offset 2053 INTEGER size 2054 INTEGER length 2055 INTEGER addr 2056 INTEGER h2b 2057 INTEGER h1b 2058 length = 0 2059 DO h2b = 1,noab 2060 DO h1b = 1,noab 2061 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2062 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 2063 &y,irrep_t)) THEN 2064 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 2065 &).ne.4)) THEN 2066 length = length + 1 2067 END IF 2068 END IF 2069 END IF 2070 END DO 2071 END DO 2072 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2073 &set)) CALL ERRQUIT('eomccsd_density1_3_3_1',0,MA_ERR) 2074 int_mb(k_a_offset) = length 2075 addr = 0 2076 size = 0 2077 DO h2b = 1,noab 2078 DO h1b = 1,noab 2079 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2080 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 2081 &y,irrep_t)) THEN 2082 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 2083 &).ne.4)) THEN 2084 addr = addr + 1 2085 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h2b - 1) 2086 int_mb(k_a_offset+length+addr) = size 2087 size = size + int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 2088 END IF 2089 END IF 2090 END IF 2091 END DO 2092 END DO 2093 RETURN 2094 END 2095 SUBROUTINE eomccsd_density1_3_3_2(d_a,k_a_offset,d_b,k_b_offset,d_ 2096 &c,k_c_offset) 2097C $Id$ 2098C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2099C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2100C i2 ( h2 h1 )_yt + = 1/2 * Sum ( h5 p4 p3 ) * t ( p3 p4 h1 h5 )_t * y ( h2 h5 p3 p4 )_y 2101 IMPLICIT NONE 2102#include "global.fh" 2103#include "mafdecls.fh" 2104#include "sym.fh" 2105#include "errquit.fh" 2106#include "tce.fh" 2107 INTEGER d_a 2108 INTEGER k_a_offset 2109 INTEGER d_b 2110 INTEGER k_b_offset 2111 INTEGER d_c 2112 INTEGER k_c_offset 2113 INTEGER NXTASK 2114 INTEGER next 2115 INTEGER nprocs 2116 INTEGER count 2117 INTEGER h2b 2118 INTEGER h1b 2119 INTEGER dimc 2120 INTEGER l_c_sort 2121 INTEGER k_c_sort 2122 INTEGER p3b 2123 INTEGER p4b 2124 INTEGER h5b 2125 INTEGER p3b_1 2126 INTEGER p4b_1 2127 INTEGER h1b_1 2128 INTEGER h5b_1 2129 INTEGER h2b_2 2130 INTEGER h5b_2 2131 INTEGER p3b_2 2132 INTEGER p4b_2 2133 INTEGER dim_common 2134 INTEGER dima_sort 2135 INTEGER dima 2136 INTEGER dimb_sort 2137 INTEGER dimb 2138 INTEGER l_a_sort 2139 INTEGER k_a_sort 2140 INTEGER l_a 2141 INTEGER k_a 2142 INTEGER l_b_sort 2143 INTEGER k_b_sort 2144 INTEGER l_b 2145 INTEGER k_b 2146 INTEGER nsuperp(2) 2147 INTEGER isuperp 2148 INTEGER l_c 2149 INTEGER k_c 2150 DOUBLE PRECISION FACTORIAL 2151 EXTERNAL NXTASK 2152 EXTERNAL FACTORIAL 2153 nprocs = GA_NNODES() 2154 count = 0 2155 next = NXTASK(nprocs,1) 2156 DO h2b = 1,noab 2157 DO h1b = 1,noab 2158 IF (next.eq.count) THEN 2159 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 2160 &).ne.4)) THEN 2161 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2162 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 2163 &y,irrep_t)) THEN 2164 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 2165 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2166 & ERRQUIT('eomccsd_density1_3_3_2',0,MA_ERR) 2167 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2168 DO p3b = noab+1,noab+nvab 2169 DO p4b = p3b,noab+nvab 2170 DO h5b = 1,noab 2171 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 2172 &1b-1)+int_mb(k_spin+h5b-1)) THEN 2173 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 2174 &k_sym+h1b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN 2175 CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h5b,p3b_1,p4b_1,h1b_1,h5b_1) 2176 CALL TCE_RESTRICTED_4(h2b,h5b,p3b,p4b,h2b_2,h5b_2,p3b_2,p4b_2) 2177 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m 2178 &b(k_range+h5b-1) 2179 dima_sort = int_mb(k_range+h1b-1) 2180 dima = dim_common * dima_sort 2181 dimb_sort = int_mb(k_range+h2b-1) 2182 dimb = dim_common * dimb_sort 2183 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2184 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2185 & ERRQUIT('eomccsd_density1_3_3_2',1,MA_ERR) 2186 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2187 &eomccsd_density1_3_3_2',2,MA_ERR) 2188 IF ((h5b .lt. h1b)) THEN 2189 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2190 & - 1 + noab * (h5b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 2191 &1 - noab - 1))))) 2192 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2193 &,int_mb(k_range+p4b-1),int_mb(k_range+h5b-1),int_mb(k_range+h1b-1) 2194 &,4,3,2,1,-1.0d0) 2195 END IF 2196 IF ((h1b .le. h5b)) THEN 2197 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 2198 & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 2199 &1 - noab - 1))))) 2200 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2201 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h5b-1) 2202 &,3,4,2,1,1.0d0) 2203 END IF 2204 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_3_3_2', 2205 &3,MA_ERR) 2206 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2207 & ERRQUIT('eomccsd_density1_3_3_2',4,MA_ERR) 2208 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2209 &eomccsd_density1_3_3_2',5,MA_ERR) 2210 IF ((h5b .lt. h2b)) THEN 2211 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 2212 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 2213 &* (h5b_2 - 1))))) 2214 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 2215 &,int_mb(k_range+h2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 2216 &,2,1,4,3,-1.0d0) 2217 END IF 2218 IF ((h2b .le. h5b)) THEN 2219 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 2220 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 2221 &* (h2b_2 - 1))))) 2222 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 2223 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 2224 &,1,2,4,3,1.0d0) 2225 END IF 2226 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_3_3_2', 2227 &6,MA_ERR) 2228 nsuperp(1) = 1 2229 nsuperp(2) = 1 2230 isuperp = 1 2231 IF (p3b .eq. p4b) THEN 2232 nsuperp(isuperp) = nsuperp(isuperp) + 1 2233 ELSE 2234 isuperp = isuperp + 1 2235 END IF 2236 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 2237 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 2238 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 2239 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2240 &3_2',7,MA_ERR) 2241 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2242 &3_2',8,MA_ERR) 2243 END IF 2244 END IF 2245 END IF 2246 END DO 2247 END DO 2248 END DO 2249 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2250 &eomccsd_density1_3_3_2',9,MA_ERR) 2251 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 2252 &,int_mb(k_range+h1b-1),1,2,1.0d0/2.0d0) 2253 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2254 & 1 + noab * (h2b - 1))) 2255 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_3_3_2', 2256 &10,MA_ERR) 2257 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2258 &3_2',11,MA_ERR) 2259 END IF 2260 END IF 2261 END IF 2262 next = NXTASK(nprocs,1) 2263 END IF 2264 count = count + 1 2265 END DO 2266 END DO 2267 next = NXTASK(-nprocs,1) 2268 call GA_SYNC() 2269 RETURN 2270 END 2271 SUBROUTINE eomccsd_density1_3_4(d_a,k_a_offset,d_b,k_b_offset,d_c, 2272 &k_c_offset) 2273C $Id$ 2274C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2275C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2276C i1 ( h2 h1 )_yxt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * i2 ( h2 p3 )_yx 2277 IMPLICIT NONE 2278#include "global.fh" 2279#include "mafdecls.fh" 2280#include "sym.fh" 2281#include "errquit.fh" 2282#include "tce.fh" 2283 INTEGER d_a 2284 INTEGER k_a_offset 2285 INTEGER d_b 2286 INTEGER k_b_offset 2287 INTEGER d_c 2288 INTEGER k_c_offset 2289 INTEGER NXTASK 2290 INTEGER next 2291 INTEGER nprocs 2292 INTEGER count 2293 INTEGER h2b 2294 INTEGER h1b 2295 INTEGER dimc 2296 INTEGER l_c_sort 2297 INTEGER k_c_sort 2298 INTEGER p3b 2299 INTEGER p3b_1 2300 INTEGER h1b_1 2301 INTEGER h2b_2 2302 INTEGER p3b_2 2303 INTEGER dim_common 2304 INTEGER dima_sort 2305 INTEGER dima 2306 INTEGER dimb_sort 2307 INTEGER dimb 2308 INTEGER l_a_sort 2309 INTEGER k_a_sort 2310 INTEGER l_a 2311 INTEGER k_a 2312 INTEGER l_b_sort 2313 INTEGER k_b_sort 2314 INTEGER l_b 2315 INTEGER k_b 2316 INTEGER l_c 2317 INTEGER k_c 2318 EXTERNAL NXTASK 2319 nprocs = GA_NNODES() 2320 count = 0 2321 next = NXTASK(nprocs,1) 2322 DO h2b = 1,noab 2323 DO h1b = 1,noab 2324 IF (next.eq.count) THEN 2325 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 2326 &).ne.4)) THEN 2327 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2328 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 2329 &y,ieor(irrep_x,irrep_t))) THEN 2330 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 2331 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2332 & ERRQUIT('eomccsd_density1_3_4',0,MA_ERR) 2333 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2334 DO p3b = noab+1,noab+nvab 2335 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 2336 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 2337 &EN 2338 CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1) 2339 CALL TCE_RESTRICTED_2(h2b,p3b,h2b_2,p3b_2) 2340 dim_common = int_mb(k_range+p3b-1) 2341 dima_sort = int_mb(k_range+h1b-1) 2342 dima = dim_common * dima_sort 2343 dimb_sort = int_mb(k_range+h2b-1) 2344 dimb = dim_common * dimb_sort 2345 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2346 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2347 & ERRQUIT('eomccsd_density1_3_4',1,MA_ERR) 2348 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2349 &eomccsd_density1_3_4',2,MA_ERR) 2350 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 2351 & - 1 + noab * (p3b_1 - noab - 1))) 2352 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 2353 &,int_mb(k_range+h1b-1),2,1,1.0d0) 2354 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_3_4',3, 2355 &MA_ERR) 2356 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2357 & ERRQUIT('eomccsd_density1_3_4',4,MA_ERR) 2358 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2359 &eomccsd_density1_3_4',5,MA_ERR) 2360 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 2361 & - noab - 1 + nvab * (h2b_2 - 1))) 2362 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 2363 &,int_mb(k_range+p3b-1),1,2,1.0d0) 2364 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_3_4',6, 2365 &MA_ERR) 2366 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2367 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2368 &t),dima_sort) 2369 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2370 &4',7,MA_ERR) 2371 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2372 &4',8,MA_ERR) 2373 END IF 2374 END IF 2375 END IF 2376 END DO 2377 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2378 &eomccsd_density1_3_4',9,MA_ERR) 2379 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 2380 &,int_mb(k_range+h1b-1),1,2,1.0d0) 2381 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 2382 & 1 + noab * (h2b - 1))) 2383 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_3_4',10 2384 &,MA_ERR) 2385 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2386 &4',11,MA_ERR) 2387 END IF 2388 END IF 2389 END IF 2390 next = NXTASK(nprocs,1) 2391 END IF 2392 count = count + 1 2393 END DO 2394 END DO 2395 next = NXTASK(-nprocs,1) 2396 call GA_SYNC() 2397 RETURN 2398 END 2399 SUBROUTINE eomccsd_density1_3_4_1(d_a,k_a_offset,d_b,k_b_offset,d_ 2400 &c,k_c_offset) 2401C $Id$ 2402C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2403C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2404C i2 ( h2 p3 )_yx + = 1 * Sum ( h5 p4 ) * x ( p4 h5 )_x * y ( h2 h5 p3 p4 )_y 2405 IMPLICIT NONE 2406#include "global.fh" 2407#include "mafdecls.fh" 2408#include "sym.fh" 2409#include "errquit.fh" 2410#include "tce.fh" 2411 INTEGER d_a 2412 INTEGER k_a_offset 2413 INTEGER d_b 2414 INTEGER k_b_offset 2415 INTEGER d_c 2416 INTEGER k_c_offset 2417 INTEGER NXTASK 2418 INTEGER next 2419 INTEGER nprocs 2420 INTEGER count 2421 INTEGER h2b 2422 INTEGER p3b 2423 INTEGER dimc 2424 INTEGER l_c_sort 2425 INTEGER k_c_sort 2426 INTEGER p4b 2427 INTEGER h5b 2428 INTEGER p4b_1 2429 INTEGER h5b_1 2430 INTEGER h2b_2 2431 INTEGER h5b_2 2432 INTEGER p3b_2 2433 INTEGER p4b_2 2434 INTEGER dim_common 2435 INTEGER dima_sort 2436 INTEGER dima 2437 INTEGER dimb_sort 2438 INTEGER dimb 2439 INTEGER l_a_sort 2440 INTEGER k_a_sort 2441 INTEGER l_a 2442 INTEGER k_a 2443 INTEGER l_b_sort 2444 INTEGER k_b_sort 2445 INTEGER l_b 2446 INTEGER k_b 2447 INTEGER l_c 2448 INTEGER k_c 2449 EXTERNAL NXTASK 2450 nprocs = GA_NNODES() 2451 count = 0 2452 next = NXTASK(nprocs,1) 2453 DO h2b = 1,noab 2454 DO p3b = noab+1,noab+nvab 2455 IF (next.eq.count) THEN 2456 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p3b-1 2457 &).ne.4)) THEN 2458 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p3b-1)) THEN 2459 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 2460 &y,irrep_x)) THEN 2461 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+p3b-1) 2462 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2463 & ERRQUIT('eomccsd_density1_3_4_1',0,MA_ERR) 2464 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2465 DO p4b = noab+1,noab+nvab 2466 DO h5b = 1,noab 2467 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h5b-1)) THEN 2468 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h5b-1)) .eq. irrep_x) TH 2469 &EN 2470 CALL TCE_RESTRICTED_2(p4b,h5b,p4b_1,h5b_1) 2471 CALL TCE_RESTRICTED_4(h2b,h5b,p3b,p4b,h2b_2,h5b_2,p3b_2,p4b_2) 2472 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h5b-1) 2473 dima_sort = 1 2474 dima = dim_common * dima_sort 2475 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+p3b-1) 2476 dimb = dim_common * dimb_sort 2477 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2478 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2479 & ERRQUIT('eomccsd_density1_3_4_1',1,MA_ERR) 2480 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2481 &eomccsd_density1_3_4_1',2,MA_ERR) 2482 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 2483 & - 1 + noab * (p4b_1 - noab - 1))) 2484 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 2485 &,int_mb(k_range+h5b-1),2,1,1.0d0) 2486 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_3_4_1', 2487 &3,MA_ERR) 2488 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2489 & ERRQUIT('eomccsd_density1_3_4_1',4,MA_ERR) 2490 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2491 &eomccsd_density1_3_4_1',5,MA_ERR) 2492 IF ((h5b .lt. h2b) .and. (p4b .lt. p3b)) THEN 2493 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 2494 & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 2495 &* (h5b_2 - 1))))) 2496 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 2497 &,int_mb(k_range+h2b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 2498 &,4,2,1,3,1.0d0) 2499 END IF 2500 IF ((h5b .lt. h2b) .and. (p3b .le. p4b)) THEN 2501 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 2502 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 2503 &* (h5b_2 - 1))))) 2504 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 2505 &,int_mb(k_range+h2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 2506 &,3,2,1,4,-1.0d0) 2507 END IF 2508 IF ((h2b .le. h5b) .and. (p4b .lt. p3b)) THEN 2509 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 2510 & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 2511 &* (h2b_2 - 1))))) 2512 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 2513 &,int_mb(k_range+h5b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 2514 &,4,1,2,3,-1.0d0) 2515 END IF 2516 IF ((h2b .le. h5b) .and. (p3b .le. p4b)) THEN 2517 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 2518 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 2519 &* (h2b_2 - 1))))) 2520 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 2521 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 2522 &,3,1,2,4,1.0d0) 2523 END IF 2524 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_3_4_1', 2525 &6,MA_ERR) 2526 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2527 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2528 &t),dima_sort) 2529 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2530 &4_1',7,MA_ERR) 2531 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2532 &4_1',8,MA_ERR) 2533 END IF 2534 END IF 2535 END IF 2536 END DO 2537 END DO 2538 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2539 &eomccsd_density1_3_4_1',9,MA_ERR) 2540 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 2541 &,int_mb(k_range+h2b-1),2,1,1.0d0) 2542 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 2543 & noab - 1 + nvab * (h2b - 1))) 2544 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_3_4_1', 2545 &10,MA_ERR) 2546 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_3_ 2547 &4_1',11,MA_ERR) 2548 END IF 2549 END IF 2550 END IF 2551 next = NXTASK(nprocs,1) 2552 END IF 2553 count = count + 1 2554 END DO 2555 END DO 2556 next = NXTASK(-nprocs,1) 2557 call GA_SYNC() 2558 RETURN 2559 END 2560 SUBROUTINE OFFSET_eomccsd_density1_3_4_1(l_a_offset,k_a_offset,siz 2561 &e) 2562C $Id$ 2563C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2564C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2565C i2 ( h2 p3 )_yx 2566 IMPLICIT NONE 2567#include "global.fh" 2568#include "mafdecls.fh" 2569#include "sym.fh" 2570#include "errquit.fh" 2571#include "tce.fh" 2572 INTEGER l_a_offset 2573 INTEGER k_a_offset 2574 INTEGER size 2575 INTEGER length 2576 INTEGER addr 2577 INTEGER h2b 2578 INTEGER p3b 2579 length = 0 2580 DO h2b = 1,noab 2581 DO p3b = noab+1,noab+nvab 2582 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p3b-1)) THEN 2583 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 2584 &y,irrep_x)) THEN 2585 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p3b-1 2586 &).ne.4)) THEN 2587 length = length + 1 2588 END IF 2589 END IF 2590 END IF 2591 END DO 2592 END DO 2593 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2594 &set)) CALL ERRQUIT('eomccsd_density1_3_4_1',0,MA_ERR) 2595 int_mb(k_a_offset) = length 2596 addr = 0 2597 size = 0 2598 DO h2b = 1,noab 2599 DO p3b = noab+1,noab+nvab 2600 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p3b-1)) THEN 2601 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 2602 &y,irrep_x)) THEN 2603 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p3b-1 2604 &).ne.4)) THEN 2605 addr = addr + 1 2606 int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h2b - 1) 2607 int_mb(k_a_offset+length+addr) = size 2608 size = size + int_mb(k_range+h2b-1) * int_mb(k_range+p3b-1) 2609 END IF 2610 END IF 2611 END IF 2612 END DO 2613 END DO 2614 RETURN 2615 END 2616 SUBROUTINE eomccsd_density1_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_ 2617 &c_offset) 2618C $Id$ 2619C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2620C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2621C i0 ( )_dxy + = 1 * Sum ( p1 h3 ) * y ( h3 p1 )_y * i1 ( p1 h3 )_dx 2622 IMPLICIT NONE 2623#include "global.fh" 2624#include "mafdecls.fh" 2625#include "sym.fh" 2626#include "errquit.fh" 2627#include "tce.fh" 2628 INTEGER d_a 2629 INTEGER k_a_offset 2630 INTEGER d_b 2631 INTEGER k_b_offset 2632 INTEGER d_c 2633 INTEGER k_c_offset 2634 INTEGER NXTASK 2635 INTEGER next 2636 INTEGER nprocs 2637 INTEGER count 2638 INTEGER dimc 2639 INTEGER l_c_sort 2640 INTEGER k_c_sort 2641 INTEGER h3b 2642 INTEGER p1b 2643 INTEGER h3b_1 2644 INTEGER p1b_1 2645 INTEGER p1b_2 2646 INTEGER h3b_2 2647 INTEGER dim_common 2648 INTEGER dima_sort 2649 INTEGER dima 2650 INTEGER dimb_sort 2651 INTEGER dimb 2652 INTEGER l_a_sort 2653 INTEGER k_a_sort 2654 INTEGER l_a 2655 INTEGER k_a 2656 INTEGER l_b_sort 2657 INTEGER k_b_sort 2658 INTEGER l_b 2659 INTEGER k_b 2660 INTEGER l_c 2661 INTEGER k_c 2662 EXTERNAL NXTASK 2663 nprocs = GA_NNODES() 2664 count = 0 2665 next = NXTASK(nprocs,1) 2666 IF (next.eq.count) THEN 2667 IF (0 .eq. ieor(irrep_d,ieor(irrep_x,irrep_y))) THEN 2668 dimc = 1 2669 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2670 & ERRQUIT('eomccsd_density1_4',0,MA_ERR) 2671 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2672 DO h3b = 1,noab 2673 DO p1b = noab+1,noab+nvab 2674 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+p1b-1)) THEN 2675 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+p1b-1)) .eq. irrep_y) TH 2676 &EN 2677 CALL TCE_RESTRICTED_2(h3b,p1b,h3b_1,p1b_1) 2678 CALL TCE_RESTRICTED_2(p1b,h3b,p1b_2,h3b_2) 2679 dim_common = int_mb(k_range+h3b-1) * int_mb(k_range+p1b-1) 2680 dima_sort = 1 2681 dima = dim_common * dima_sort 2682 dimb_sort = 1 2683 dimb = dim_common * dimb_sort 2684 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2685 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2686 & ERRQUIT('eomccsd_density1_4',1,MA_ERR) 2687 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2688 &eomccsd_density1_4',2,MA_ERR) 2689 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1 2690 & - noab - 1 + nvab * (h3b_1 - 1))) 2691 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1) 2692 &,int_mb(k_range+p1b-1),2,1,1.0d0) 2693 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_4',3,MA 2694 &_ERR) 2695 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2696 & ERRQUIT('eomccsd_density1_4',4,MA_ERR) 2697 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2698 &eomccsd_density1_4',5,MA_ERR) 2699 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 2700 & - 1 + noab * (p1b_2 - noab - 1))) 2701 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p1b-1) 2702 &,int_mb(k_range+h3b-1),1,2,1.0d0) 2703 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_4',6,MA 2704 &_ERR) 2705 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2706 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2707 &t),dima_sort) 2708 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_4' 2709 &,7,MA_ERR) 2710 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_4' 2711 &,8,MA_ERR) 2712 END IF 2713 END IF 2714 END IF 2715 END DO 2716 END DO 2717 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2718 &eomccsd_density1_4',9,MA_ERR) 2719 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 2720 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 2721 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_4',10,M 2722 &A_ERR) 2723 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_4' 2724 &,11,MA_ERR) 2725 END IF 2726 next = NXTASK(nprocs,1) 2727 END IF 2728 count = count + 1 2729 next = NXTASK(-nprocs,1) 2730 call GA_SYNC() 2731 RETURN 2732 END 2733 SUBROUTINE eomccsd_density1_4_1(d_a,k_a_offset,d_b,k_b_offset,d_c, 2734 &k_c_offset) 2735C $Id$ 2736C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2737C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2738C i1 ( p1 h3 )_dx + = 1 * Sum ( p2 ) * d ( p1 p2 )_d * x ( p2 h3 )_x 2739 IMPLICIT NONE 2740#include "global.fh" 2741#include "mafdecls.fh" 2742#include "sym.fh" 2743#include "errquit.fh" 2744#include "tce.fh" 2745 INTEGER d_a 2746 INTEGER k_a_offset 2747 INTEGER d_b 2748 INTEGER k_b_offset 2749 INTEGER d_c 2750 INTEGER k_c_offset 2751 INTEGER NXTASK 2752 INTEGER next 2753 INTEGER nprocs 2754 INTEGER count 2755 INTEGER p1b 2756 INTEGER h3b 2757 INTEGER dimc 2758 INTEGER l_c_sort 2759 INTEGER k_c_sort 2760 INTEGER p2b 2761 INTEGER p1b_1 2762 INTEGER p2b_1 2763 INTEGER p2b_2 2764 INTEGER h3b_2 2765 INTEGER dim_common 2766 INTEGER dima_sort 2767 INTEGER dima 2768 INTEGER dimb_sort 2769 INTEGER dimb 2770 INTEGER l_a_sort 2771 INTEGER k_a_sort 2772 INTEGER l_a 2773 INTEGER k_a 2774 INTEGER l_b_sort 2775 INTEGER k_b_sort 2776 INTEGER l_b 2777 INTEGER k_b 2778 INTEGER l_c 2779 INTEGER k_c 2780 EXTERNAL NXTASK 2781 nprocs = GA_NNODES() 2782 count = 0 2783 next = NXTASK(nprocs,1) 2784 DO p1b = noab+1,noab+nvab 2785 DO h3b = 1,noab 2786 IF (next.eq.count) THEN 2787 IF ((.not.restricted).or.(int_mb(k_spin+p1b-1)+int_mb(k_spin+h3b-1 2788 &).ne.4)) THEN 2789 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h3b-1)) THEN 2790 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h3b-1)) .eq. ieor(irrep_ 2791 &d,irrep_x)) THEN 2792 dimc = int_mb(k_range+p1b-1) * int_mb(k_range+h3b-1) 2793 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2794 & ERRQUIT('eomccsd_density1_4_1',0,MA_ERR) 2795 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2796 DO p2b = noab+1,noab+nvab 2797 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+p2b-1)) THEN 2798 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+p2b-1)) .eq. irrep_d) TH 2799 &EN 2800 CALL TCE_RESTRICTED_2(p1b,p2b,p1b_1,p2b_1) 2801 CALL TCE_RESTRICTED_2(p2b,h3b,p2b_2,h3b_2) 2802 dim_common = int_mb(k_range+p2b-1) 2803 dima_sort = int_mb(k_range+p1b-1) 2804 dima = dim_common * dima_sort 2805 dimb_sort = int_mb(k_range+h3b-1) 2806 dimb = dim_common * dimb_sort 2807 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2808 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2809 & ERRQUIT('eomccsd_density1_4_1',1,MA_ERR) 2810 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2811 &eomccsd_density1_4_1',2,MA_ERR) 2812 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 2813 & - 1 + (noab+nvab) * (p1b_1 - 1))) 2814 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 2815 &,int_mb(k_range+p2b-1),1,2,1.0d0) 2816 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_4_1',3, 2817 &MA_ERR) 2818 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2819 & ERRQUIT('eomccsd_density1_4_1',4,MA_ERR) 2820 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2821 &eomccsd_density1_4_1',5,MA_ERR) 2822 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 2823 & - 1 + noab * (p2b_2 - noab - 1))) 2824 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1) 2825 &,int_mb(k_range+h3b-1),2,1,1.0d0) 2826 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_4_1',6, 2827 &MA_ERR) 2828 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2829 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2830 &t),dima_sort) 2831 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_4_ 2832 &1',7,MA_ERR) 2833 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_4_ 2834 &1',8,MA_ERR) 2835 END IF 2836 END IF 2837 END IF 2838 END DO 2839 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2840 &eomccsd_density1_4_1',9,MA_ERR) 2841 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 2842 &,int_mb(k_range+p1b-1),2,1,1.0d0) 2843 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 2844 & 1 + noab * (p1b - noab - 1))) 2845 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_4_1',10 2846 &,MA_ERR) 2847 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_4_ 2848 &1',11,MA_ERR) 2849 END IF 2850 END IF 2851 END IF 2852 next = NXTASK(nprocs,1) 2853 END IF 2854 count = count + 1 2855 END DO 2856 END DO 2857 next = NXTASK(-nprocs,1) 2858 call GA_SYNC() 2859 RETURN 2860 END 2861 SUBROUTINE OFFSET_eomccsd_density1_4_1(l_a_offset,k_a_offset,size) 2862C $Id$ 2863C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2864C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2865C i1 ( p1 h3 )_dx 2866 IMPLICIT NONE 2867#include "global.fh" 2868#include "mafdecls.fh" 2869#include "sym.fh" 2870#include "errquit.fh" 2871#include "tce.fh" 2872 INTEGER l_a_offset 2873 INTEGER k_a_offset 2874 INTEGER size 2875 INTEGER length 2876 INTEGER addr 2877 INTEGER p1b 2878 INTEGER h3b 2879 length = 0 2880 DO p1b = noab+1,noab+nvab 2881 DO h3b = 1,noab 2882 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h3b-1)) THEN 2883 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h3b-1)) .eq. ieor(irrep_ 2884 &d,irrep_x)) THEN 2885 IF ((.not.restricted).or.(int_mb(k_spin+p1b-1)+int_mb(k_spin+h3b-1 2886 &).ne.4)) THEN 2887 length = length + 1 2888 END IF 2889 END IF 2890 END IF 2891 END DO 2892 END DO 2893 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2894 &set)) CALL ERRQUIT('eomccsd_density1_4_1',0,MA_ERR) 2895 int_mb(k_a_offset) = length 2896 addr = 0 2897 size = 0 2898 DO p1b = noab+1,noab+nvab 2899 DO h3b = 1,noab 2900 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h3b-1)) THEN 2901 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h3b-1)) .eq. ieor(irrep_ 2902 &d,irrep_x)) THEN 2903 IF ((.not.restricted).or.(int_mb(k_spin+p1b-1)+int_mb(k_spin+h3b-1 2904 &).ne.4)) THEN 2905 addr = addr + 1 2906 int_mb(k_a_offset+addr) = h3b - 1 + noab * (p1b - noab - 1) 2907 int_mb(k_a_offset+length+addr) = size 2908 size = size + int_mb(k_range+p1b-1) * int_mb(k_range+h3b-1) 2909 END IF 2910 END IF 2911 END IF 2912 END DO 2913 END DO 2914 RETURN 2915 END 2916 SUBROUTINE eomccsd_density1_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 2917 &k_c_offset) 2918C $Id$ 2919C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2920C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2921C i1 ( p1 h3 )_dtx + = 1 * x ( )_x * i2 ( p1 h3 )_dt 2922 IMPLICIT NONE 2923#include "global.fh" 2924#include "mafdecls.fh" 2925#include "sym.fh" 2926#include "errquit.fh" 2927#include "tce.fh" 2928 INTEGER d_a 2929 INTEGER k_a_offset 2930 INTEGER d_b 2931 INTEGER k_b_offset 2932 INTEGER d_c 2933 INTEGER k_c_offset 2934 INTEGER NXTASK 2935 INTEGER next 2936 INTEGER nprocs 2937 INTEGER count 2938 INTEGER p1b 2939 INTEGER h3b 2940 INTEGER dimc 2941 INTEGER l_c_sort 2942 INTEGER k_c_sort 2943 INTEGER p1b_2 2944 INTEGER h3b_2 2945 INTEGER dim_common 2946 INTEGER dima_sort 2947 INTEGER dima 2948 INTEGER dimb_sort 2949 INTEGER dimb 2950 INTEGER l_a_sort 2951 INTEGER k_a_sort 2952 INTEGER l_a 2953 INTEGER k_a 2954 INTEGER l_b_sort 2955 INTEGER k_b_sort 2956 INTEGER l_b 2957 INTEGER k_b 2958 INTEGER l_c 2959 INTEGER k_c 2960 EXTERNAL NXTASK 2961 nprocs = GA_NNODES() 2962 count = 0 2963 next = NXTASK(nprocs,1) 2964 DO p1b = noab+1,noab+nvab 2965 DO h3b = 1,noab 2966 IF (next.eq.count) THEN 2967 IF ((.not.restricted).or.(int_mb(k_spin+p1b-1)+int_mb(k_spin+h3b-1 2968 &).ne.4)) THEN 2969 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h3b-1)) THEN 2970 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h3b-1)) .eq. ieor(irrep_ 2971 &d,ieor(irrep_t,irrep_x))) THEN 2972 dimc = int_mb(k_range+p1b-1) * int_mb(k_range+h3b-1) 2973 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2974 & ERRQUIT('eomccsd_density1_4_2',0,MA_ERR) 2975 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2976 IF (0 .eq. irrep_x) THEN 2977 CALL TCE_RESTRICTED_2(p1b,h3b,p1b_2,h3b_2) 2978 dim_common = 1 2979 dima_sort = 1 2980 dima = dim_common * dima_sort 2981 dimb_sort = int_mb(k_range+p1b-1) * int_mb(k_range+h3b-1) 2982 dimb = dim_common * dimb_sort 2983 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2984 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2985 & ERRQUIT('eomccsd_density1_4_2',1,MA_ERR) 2986 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2987 &eomccsd_density1_4_2',2,MA_ERR) 2988 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),0) 2989 CALL TCE_SORT_0(dbl_mb(k_a),dbl_mb(k_a_sort),1.0d0) 2990 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_4_2',3, 2991 &MA_ERR) 2992 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2993 & ERRQUIT('eomccsd_density1_4_2',4,MA_ERR) 2994 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2995 &eomccsd_density1_4_2',5,MA_ERR) 2996 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 2997 & - 1 + noab * (p1b_2 - noab - 1))) 2998 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p1b-1) 2999 &,int_mb(k_range+h3b-1),2,1,1.0d0) 3000 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_4_2',6, 3001 &MA_ERR) 3002 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3003 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3004 &t),dima_sort) 3005 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_4_ 3006 &2',7,MA_ERR) 3007 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_4_ 3008 &2',8,MA_ERR) 3009 END IF 3010 END IF 3011 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3012 &eomccsd_density1_4_2',9,MA_ERR) 3013 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 3014 &,int_mb(k_range+p1b-1),2,1,1.0d0) 3015 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 3016 & 1 + noab * (p1b - noab - 1))) 3017 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_4_2',10 3018 &,MA_ERR) 3019 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_4_ 3020 &2',11,MA_ERR) 3021 END IF 3022 END IF 3023 END IF 3024 next = NXTASK(nprocs,1) 3025 END IF 3026 count = count + 1 3027 END DO 3028 END DO 3029 next = NXTASK(-nprocs,1) 3030 call GA_SYNC() 3031 RETURN 3032 END 3033 SUBROUTINE eomccsd_density1_4_2_1(d_a,k_a_offset,d_b,k_b_offset,d_ 3034 &c,k_c_offset) 3035C $Id$ 3036C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3037C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3038C i2 ( p1 h3 )_dt + = 1 * Sum ( p2 ) * d ( p1 p2 )_d * t ( p2 h3 )_t 3039 IMPLICIT NONE 3040#include "global.fh" 3041#include "mafdecls.fh" 3042#include "sym.fh" 3043#include "errquit.fh" 3044#include "tce.fh" 3045 INTEGER d_a 3046 INTEGER k_a_offset 3047 INTEGER d_b 3048 INTEGER k_b_offset 3049 INTEGER d_c 3050 INTEGER k_c_offset 3051 INTEGER NXTASK 3052 INTEGER next 3053 INTEGER nprocs 3054 INTEGER count 3055 INTEGER p1b 3056 INTEGER h3b 3057 INTEGER dimc 3058 INTEGER l_c_sort 3059 INTEGER k_c_sort 3060 INTEGER p2b 3061 INTEGER p1b_1 3062 INTEGER p2b_1 3063 INTEGER p2b_2 3064 INTEGER h3b_2 3065 INTEGER dim_common 3066 INTEGER dima_sort 3067 INTEGER dima 3068 INTEGER dimb_sort 3069 INTEGER dimb 3070 INTEGER l_a_sort 3071 INTEGER k_a_sort 3072 INTEGER l_a 3073 INTEGER k_a 3074 INTEGER l_b_sort 3075 INTEGER k_b_sort 3076 INTEGER l_b 3077 INTEGER k_b 3078 INTEGER l_c 3079 INTEGER k_c 3080 EXTERNAL NXTASK 3081 nprocs = GA_NNODES() 3082 count = 0 3083 next = NXTASK(nprocs,1) 3084 DO p1b = noab+1,noab+nvab 3085 DO h3b = 1,noab 3086 IF (next.eq.count) THEN 3087 IF ((.not.restricted).or.(int_mb(k_spin+p1b-1)+int_mb(k_spin+h3b-1 3088 &).ne.4)) THEN 3089 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h3b-1)) THEN 3090 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h3b-1)) .eq. ieor(irrep_ 3091 &d,irrep_t)) THEN 3092 dimc = int_mb(k_range+p1b-1) * int_mb(k_range+h3b-1) 3093 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3094 & ERRQUIT('eomccsd_density1_4_2_1',0,MA_ERR) 3095 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3096 DO p2b = noab+1,noab+nvab 3097 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+p2b-1)) THEN 3098 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+p2b-1)) .eq. irrep_d) TH 3099 &EN 3100 CALL TCE_RESTRICTED_2(p1b,p2b,p1b_1,p2b_1) 3101 CALL TCE_RESTRICTED_2(p2b,h3b,p2b_2,h3b_2) 3102 dim_common = int_mb(k_range+p2b-1) 3103 dima_sort = int_mb(k_range+p1b-1) 3104 dima = dim_common * dima_sort 3105 dimb_sort = int_mb(k_range+h3b-1) 3106 dimb = dim_common * dimb_sort 3107 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3108 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3109 & ERRQUIT('eomccsd_density1_4_2_1',1,MA_ERR) 3110 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3111 &eomccsd_density1_4_2_1',2,MA_ERR) 3112 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 3113 & - 1 + (noab+nvab) * (p1b_1 - 1))) 3114 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 3115 &,int_mb(k_range+p2b-1),1,2,1.0d0) 3116 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_4_2_1', 3117 &3,MA_ERR) 3118 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3119 & ERRQUIT('eomccsd_density1_4_2_1',4,MA_ERR) 3120 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3121 &eomccsd_density1_4_2_1',5,MA_ERR) 3122 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2 3123 & - 1 + noab * (p2b_2 - noab - 1))) 3124 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1) 3125 &,int_mb(k_range+h3b-1),2,1,1.0d0) 3126 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_4_2_1', 3127 &6,MA_ERR) 3128 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3129 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3130 &t),dima_sort) 3131 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_4_ 3132 &2_1',7,MA_ERR) 3133 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_4_ 3134 &2_1',8,MA_ERR) 3135 END IF 3136 END IF 3137 END IF 3138 END DO 3139 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3140 &eomccsd_density1_4_2_1',9,MA_ERR) 3141 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 3142 &,int_mb(k_range+p1b-1),2,1,1.0d0) 3143 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 3144 & 1 + noab * (p1b - noab - 1))) 3145 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_4_2_1', 3146 &10,MA_ERR) 3147 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_4_ 3148 &2_1',11,MA_ERR) 3149 END IF 3150 END IF 3151 END IF 3152 next = NXTASK(nprocs,1) 3153 END IF 3154 count = count + 1 3155 END DO 3156 END DO 3157 next = NXTASK(-nprocs,1) 3158 call GA_SYNC() 3159 RETURN 3160 END 3161 SUBROUTINE OFFSET_eomccsd_density1_4_2_1(l_a_offset,k_a_offset,siz 3162 &e) 3163C $Id$ 3164C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3165C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3166C i2 ( p1 h3 )_dt 3167 IMPLICIT NONE 3168#include "global.fh" 3169#include "mafdecls.fh" 3170#include "sym.fh" 3171#include "errquit.fh" 3172#include "tce.fh" 3173 INTEGER l_a_offset 3174 INTEGER k_a_offset 3175 INTEGER size 3176 INTEGER length 3177 INTEGER addr 3178 INTEGER p1b 3179 INTEGER h3b 3180 length = 0 3181 DO p1b = noab+1,noab+nvab 3182 DO h3b = 1,noab 3183 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h3b-1)) THEN 3184 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h3b-1)) .eq. ieor(irrep_ 3185 &d,irrep_t)) THEN 3186 IF ((.not.restricted).or.(int_mb(k_spin+p1b-1)+int_mb(k_spin+h3b-1 3187 &).ne.4)) THEN 3188 length = length + 1 3189 END IF 3190 END IF 3191 END IF 3192 END DO 3193 END DO 3194 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 3195 &set)) CALL ERRQUIT('eomccsd_density1_4_2_1',0,MA_ERR) 3196 int_mb(k_a_offset) = length 3197 addr = 0 3198 size = 0 3199 DO p1b = noab+1,noab+nvab 3200 DO h3b = 1,noab 3201 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h3b-1)) THEN 3202 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h3b-1)) .eq. ieor(irrep_ 3203 &d,irrep_t)) THEN 3204 IF ((.not.restricted).or.(int_mb(k_spin+p1b-1)+int_mb(k_spin+h3b-1 3205 &).ne.4)) THEN 3206 addr = addr + 1 3207 int_mb(k_a_offset+addr) = h3b - 1 + noab * (p1b - noab - 1) 3208 int_mb(k_a_offset+length+addr) = size 3209 size = size + int_mb(k_range+p1b-1) * int_mb(k_range+h3b-1) 3210 END IF 3211 END IF 3212 END IF 3213 END DO 3214 END DO 3215 RETURN 3216 END 3217 SUBROUTINE eomccsd_density1_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_ 3218 &c_offset) 3219C $Id$ 3220C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3221C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3222C i0 ( )_yxd + = 1 * Sum ( p8 h7 ) * d ( h7 p8 )_d * i1 ( p8 h7 )_yx 3223 IMPLICIT NONE 3224#include "global.fh" 3225#include "mafdecls.fh" 3226#include "sym.fh" 3227#include "errquit.fh" 3228#include "tce.fh" 3229 INTEGER d_a 3230 INTEGER k_a_offset 3231 INTEGER d_b 3232 INTEGER k_b_offset 3233 INTEGER d_c 3234 INTEGER k_c_offset 3235 INTEGER NXTASK 3236 INTEGER next 3237 INTEGER nprocs 3238 INTEGER count 3239 INTEGER dimc 3240 INTEGER l_c_sort 3241 INTEGER k_c_sort 3242 INTEGER h7b 3243 INTEGER p8b 3244 INTEGER h7b_1 3245 INTEGER p8b_1 3246 INTEGER p8b_2 3247 INTEGER h7b_2 3248 INTEGER dim_common 3249 INTEGER dima_sort 3250 INTEGER dima 3251 INTEGER dimb_sort 3252 INTEGER dimb 3253 INTEGER l_a_sort 3254 INTEGER k_a_sort 3255 INTEGER l_a 3256 INTEGER k_a 3257 INTEGER l_b_sort 3258 INTEGER k_b_sort 3259 INTEGER l_b 3260 INTEGER k_b 3261 INTEGER l_c 3262 INTEGER k_c 3263 EXTERNAL NXTASK 3264 nprocs = GA_NNODES() 3265 count = 0 3266 next = NXTASK(nprocs,1) 3267 IF (next.eq.count) THEN 3268 IF (0 .eq. ieor(irrep_y,ieor(irrep_x,irrep_d))) THEN 3269 dimc = 1 3270 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3271 & ERRQUIT('eomccsd_density1_5',0,MA_ERR) 3272 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3273 DO h7b = 1,noab 3274 DO p8b = noab+1,noab+nvab 3275 IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+p8b-1)) THEN 3276 IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+p8b-1)) .eq. irrep_d) TH 3277 &EN 3278 CALL TCE_RESTRICTED_2(h7b,p8b,h7b_1,p8b_1) 3279 CALL TCE_RESTRICTED_2(p8b,h7b,p8b_2,h7b_2) 3280 dim_common = int_mb(k_range+h7b-1) * int_mb(k_range+p8b-1) 3281 dima_sort = 1 3282 dima = dim_common * dima_sort 3283 dimb_sort = 1 3284 dimb = dim_common * dimb_sort 3285 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3286 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3287 & ERRQUIT('eomccsd_density1_5',1,MA_ERR) 3288 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3289 &eomccsd_density1_5',2,MA_ERR) 3290 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1 3291 & - 1 + (noab+nvab) * (h7b_1 - 1))) 3292 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 3293 &,int_mb(k_range+p8b-1),2,1,1.0d0) 3294 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5',3,MA 3295 &_ERR) 3296 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3297 & ERRQUIT('eomccsd_density1_5',4,MA_ERR) 3298 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3299 &eomccsd_density1_5',5,MA_ERR) 3300 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h7b_2 3301 & - 1 + noab * (p8b_2 - noab - 1))) 3302 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p8b-1) 3303 &,int_mb(k_range+h7b-1),1,2,1.0d0) 3304 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5',6,MA 3305 &_ERR) 3306 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3307 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3308 &t),dima_sort) 3309 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5' 3310 &,7,MA_ERR) 3311 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5' 3312 &,8,MA_ERR) 3313 END IF 3314 END IF 3315 END IF 3316 END DO 3317 END DO 3318 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3319 &eomccsd_density1_5',9,MA_ERR) 3320 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 3321 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 3322 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5',10,M 3323 &A_ERR) 3324 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5' 3325 &,11,MA_ERR) 3326 END IF 3327 next = NXTASK(nprocs,1) 3328 END IF 3329 count = count + 1 3330 next = NXTASK(-nprocs,1) 3331 call GA_SYNC() 3332 RETURN 3333 END 3334 SUBROUTINE eomccsd_density1_5_1(d_a,k_a_offset,d_b,k_b_offset,d_c, 3335 &k_c_offset) 3336C $Id$ 3337C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3338C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3339C i1 ( p8 h7 )_yx + = 1 * Sum ( h4 p3 ) * x ( p3 p8 h4 h7 )_x * y ( h4 p3 )_y 3340 IMPLICIT NONE 3341#include "global.fh" 3342#include "mafdecls.fh" 3343#include "sym.fh" 3344#include "errquit.fh" 3345#include "tce.fh" 3346 INTEGER d_a 3347 INTEGER k_a_offset 3348 INTEGER d_b 3349 INTEGER k_b_offset 3350 INTEGER d_c 3351 INTEGER k_c_offset 3352 INTEGER NXTASK 3353 INTEGER next 3354 INTEGER nprocs 3355 INTEGER count 3356 INTEGER p8b 3357 INTEGER h7b 3358 INTEGER dimc 3359 INTEGER l_c_sort 3360 INTEGER k_c_sort 3361 INTEGER p3b 3362 INTEGER h4b 3363 INTEGER p8b_1 3364 INTEGER p3b_1 3365 INTEGER h7b_1 3366 INTEGER h4b_1 3367 INTEGER h4b_2 3368 INTEGER p3b_2 3369 INTEGER dim_common 3370 INTEGER dima_sort 3371 INTEGER dima 3372 INTEGER dimb_sort 3373 INTEGER dimb 3374 INTEGER l_a_sort 3375 INTEGER k_a_sort 3376 INTEGER l_a 3377 INTEGER k_a 3378 INTEGER l_b_sort 3379 INTEGER k_b_sort 3380 INTEGER l_b 3381 INTEGER k_b 3382 INTEGER l_c 3383 INTEGER k_c 3384 EXTERNAL NXTASK 3385 nprocs = GA_NNODES() 3386 count = 0 3387 next = NXTASK(nprocs,1) 3388 DO p8b = noab+1,noab+nvab 3389 DO h7b = 1,noab 3390 IF (next.eq.count) THEN 3391 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 3392 &).ne.4)) THEN 3393 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 3394 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 3395 &y,irrep_x)) THEN 3396 dimc = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 3397 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3398 & ERRQUIT('eomccsd_density1_5_1',0,MA_ERR) 3399 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3400 DO p3b = noab+1,noab+nvab 3401 DO h4b = 1,noab 3402 IF (int_mb(k_spin+p8b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 3403 &7b-1)+int_mb(k_spin+h4b-1)) THEN 3404 IF (ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 3405 &k_sym+h7b-1),int_mb(k_sym+h4b-1)))) .eq. irrep_x) THEN 3406 CALL TCE_RESTRICTED_4(p8b,p3b,h7b,h4b,p8b_1,p3b_1,h7b_1,h4b_1) 3407 CALL TCE_RESTRICTED_2(h4b,p3b,h4b_2,p3b_2) 3408 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) 3409 dima_sort = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 3410 dima = dim_common * dima_sort 3411 dimb_sort = 1 3412 dimb = dim_common * dimb_sort 3413 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3414 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3415 & ERRQUIT('eomccsd_density1_5_1',1,MA_ERR) 3416 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3417 &eomccsd_density1_5_1',2,MA_ERR) 3418 IF ((p3b .le. p8b) .and. (h4b .le. h7b)) THEN 3419 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 3420 & - 1 + noab * (h4b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 3421 &1 - noab - 1))))) 3422 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 3423 &,int_mb(k_range+p8b-1),int_mb(k_range+h4b-1),int_mb(k_range+h7b-1) 3424 &,4,2,3,1,1.0d0) 3425 END IF 3426 IF ((p3b .le. p8b) .and. (h7b .lt. h4b)) THEN 3427 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 3428 & - 1 + noab * (h7b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 3429 &1 - noab - 1))))) 3430 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 3431 &,int_mb(k_range+p8b-1),int_mb(k_range+h7b-1),int_mb(k_range+h4b-1) 3432 &,3,2,4,1,-1.0d0) 3433 END IF 3434 IF ((p8b .lt. p3b) .and. (h4b .le. h7b)) THEN 3435 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 3436 & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 3437 &1 - noab - 1))))) 3438 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 3439 &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h7b-1) 3440 &,4,1,3,2,-1.0d0) 3441 END IF 3442 IF ((p8b .lt. p3b) .and. (h7b .lt. h4b)) THEN 3443 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 3444 & - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 3445 &1 - noab - 1))))) 3446 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 3447 &,int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),int_mb(k_range+h4b-1) 3448 &,3,1,4,2,1.0d0) 3449 END IF 3450 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_1',3, 3451 &MA_ERR) 3452 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3453 & ERRQUIT('eomccsd_density1_5_1',4,MA_ERR) 3454 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3455 &eomccsd_density1_5_1',5,MA_ERR) 3456 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 3457 & - noab - 1 + nvab * (h4b_2 - 1))) 3458 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 3459 &,int_mb(k_range+p3b-1),1,2,1.0d0) 3460 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_1',6, 3461 &MA_ERR) 3462 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3463 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3464 &t),dima_sort) 3465 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 3466 &1',7,MA_ERR) 3467 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 3468 &1',8,MA_ERR) 3469 END IF 3470 END IF 3471 END IF 3472 END DO 3473 END DO 3474 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3475 &eomccsd_density1_5_1',9,MA_ERR) 3476 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 3477 &,int_mb(k_range+p8b-1),2,1,1.0d0) 3478 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 3479 & 1 + noab * (p8b - noab - 1))) 3480 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_1',10 3481 &,MA_ERR) 3482 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 3483 &1',11,MA_ERR) 3484 END IF 3485 END IF 3486 END IF 3487 next = NXTASK(nprocs,1) 3488 END IF 3489 count = count + 1 3490 END DO 3491 END DO 3492 next = NXTASK(-nprocs,1) 3493 call GA_SYNC() 3494 RETURN 3495 END 3496 SUBROUTINE OFFSET_eomccsd_density1_5_1(l_a_offset,k_a_offset,size) 3497C $Id$ 3498C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3499C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3500C i1 ( p8 h7 )_yx 3501 IMPLICIT NONE 3502#include "global.fh" 3503#include "mafdecls.fh" 3504#include "sym.fh" 3505#include "errquit.fh" 3506#include "tce.fh" 3507 INTEGER l_a_offset 3508 INTEGER k_a_offset 3509 INTEGER size 3510 INTEGER length 3511 INTEGER addr 3512 INTEGER p8b 3513 INTEGER h7b 3514 length = 0 3515 DO p8b = noab+1,noab+nvab 3516 DO h7b = 1,noab 3517 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 3518 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 3519 &y,irrep_x)) THEN 3520 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 3521 &).ne.4)) THEN 3522 length = length + 1 3523 END IF 3524 END IF 3525 END IF 3526 END DO 3527 END DO 3528 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 3529 &set)) CALL ERRQUIT('eomccsd_density1_5_1',0,MA_ERR) 3530 int_mb(k_a_offset) = length 3531 addr = 0 3532 size = 0 3533 DO p8b = noab+1,noab+nvab 3534 DO h7b = 1,noab 3535 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 3536 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 3537 &y,irrep_x)) THEN 3538 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 3539 &).ne.4)) THEN 3540 addr = addr + 1 3541 int_mb(k_a_offset+addr) = h7b - 1 + noab * (p8b - noab - 1) 3542 int_mb(k_a_offset+length+addr) = size 3543 size = size + int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 3544 END IF 3545 END IF 3546 END IF 3547 END DO 3548 END DO 3549 RETURN 3550 END 3551 SUBROUTINE eomccsd_density1_5_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 3552 &k_c_offset) 3553C $Id$ 3554C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3555C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3556C i1 ( p8 h7 )_yxt + = -1 * Sum ( h1 ) * t ( p8 h1 )_t * i2 ( h1 h7 )_yx 3557 IMPLICIT NONE 3558#include "global.fh" 3559#include "mafdecls.fh" 3560#include "sym.fh" 3561#include "errquit.fh" 3562#include "tce.fh" 3563 INTEGER d_a 3564 INTEGER k_a_offset 3565 INTEGER d_b 3566 INTEGER k_b_offset 3567 INTEGER d_c 3568 INTEGER k_c_offset 3569 INTEGER NXTASK 3570 INTEGER next 3571 INTEGER nprocs 3572 INTEGER count 3573 INTEGER p8b 3574 INTEGER h7b 3575 INTEGER dimc 3576 INTEGER l_c_sort 3577 INTEGER k_c_sort 3578 INTEGER h1b 3579 INTEGER p8b_1 3580 INTEGER h1b_1 3581 INTEGER h1b_2 3582 INTEGER h7b_2 3583 INTEGER dim_common 3584 INTEGER dima_sort 3585 INTEGER dima 3586 INTEGER dimb_sort 3587 INTEGER dimb 3588 INTEGER l_a_sort 3589 INTEGER k_a_sort 3590 INTEGER l_a 3591 INTEGER k_a 3592 INTEGER l_b_sort 3593 INTEGER k_b_sort 3594 INTEGER l_b 3595 INTEGER k_b 3596 INTEGER l_c 3597 INTEGER k_c 3598 EXTERNAL NXTASK 3599 nprocs = GA_NNODES() 3600 count = 0 3601 next = NXTASK(nprocs,1) 3602 DO p8b = noab+1,noab+nvab 3603 DO h7b = 1,noab 3604 IF (next.eq.count) THEN 3605 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 3606 &).ne.4)) THEN 3607 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 3608 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 3609 &y,ieor(irrep_x,irrep_t))) THEN 3610 dimc = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 3611 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3612 & ERRQUIT('eomccsd_density1_5_2',0,MA_ERR) 3613 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3614 DO h1b = 1,noab 3615 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 3616 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 3617 &EN 3618 CALL TCE_RESTRICTED_2(p8b,h1b,p8b_1,h1b_1) 3619 CALL TCE_RESTRICTED_2(h1b,h7b,h1b_2,h7b_2) 3620 dim_common = int_mb(k_range+h1b-1) 3621 dima_sort = int_mb(k_range+p8b-1) 3622 dima = dim_common * dima_sort 3623 dimb_sort = int_mb(k_range+h7b-1) 3624 dimb = dim_common * dimb_sort 3625 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3626 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3627 & ERRQUIT('eomccsd_density1_5_2',1,MA_ERR) 3628 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3629 &eomccsd_density1_5_2',2,MA_ERR) 3630 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 3631 & - 1 + noab * (p8b_1 - noab - 1))) 3632 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 3633 &,int_mb(k_range+h1b-1),1,2,1.0d0) 3634 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_2',3, 3635 &MA_ERR) 3636 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3637 & ERRQUIT('eomccsd_density1_5_2',4,MA_ERR) 3638 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3639 &eomccsd_density1_5_2',5,MA_ERR) 3640 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h7b_2 3641 & - 1 + noab * (h1b_2 - 1))) 3642 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 3643 &,int_mb(k_range+h7b-1),2,1,1.0d0) 3644 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_2',6, 3645 &MA_ERR) 3646 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3647 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3648 &t),dima_sort) 3649 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 3650 &2',7,MA_ERR) 3651 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 3652 &2',8,MA_ERR) 3653 END IF 3654 END IF 3655 END IF 3656 END DO 3657 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3658 &eomccsd_density1_5_2',9,MA_ERR) 3659 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 3660 &,int_mb(k_range+p8b-1),2,1,-1.0d0) 3661 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 3662 & 1 + noab * (p8b - noab - 1))) 3663 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_2',10 3664 &,MA_ERR) 3665 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 3666 &2',11,MA_ERR) 3667 END IF 3668 END IF 3669 END IF 3670 next = NXTASK(nprocs,1) 3671 END IF 3672 count = count + 1 3673 END DO 3674 END DO 3675 next = NXTASK(-nprocs,1) 3676 call GA_SYNC() 3677 RETURN 3678 END 3679 SUBROUTINE eomccsd_density1_5_2_1(d_a,k_a_offset,d_b,k_b_offset,d_ 3680 &c,k_c_offset) 3681C $Id$ 3682C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3683C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3684C i2 ( h1 h7 )_yx + = 1 * Sum ( p4 ) * x ( p4 h7 )_x * y ( h1 p4 )_y 3685 IMPLICIT NONE 3686#include "global.fh" 3687#include "mafdecls.fh" 3688#include "sym.fh" 3689#include "errquit.fh" 3690#include "tce.fh" 3691 INTEGER d_a 3692 INTEGER k_a_offset 3693 INTEGER d_b 3694 INTEGER k_b_offset 3695 INTEGER d_c 3696 INTEGER k_c_offset 3697 INTEGER NXTASK 3698 INTEGER next 3699 INTEGER nprocs 3700 INTEGER count 3701 INTEGER h1b 3702 INTEGER h7b 3703 INTEGER dimc 3704 INTEGER l_c_sort 3705 INTEGER k_c_sort 3706 INTEGER p4b 3707 INTEGER p4b_1 3708 INTEGER h7b_1 3709 INTEGER h1b_2 3710 INTEGER p4b_2 3711 INTEGER dim_common 3712 INTEGER dima_sort 3713 INTEGER dima 3714 INTEGER dimb_sort 3715 INTEGER dimb 3716 INTEGER l_a_sort 3717 INTEGER k_a_sort 3718 INTEGER l_a 3719 INTEGER k_a 3720 INTEGER l_b_sort 3721 INTEGER k_b_sort 3722 INTEGER l_b 3723 INTEGER k_b 3724 INTEGER l_c 3725 INTEGER k_c 3726 EXTERNAL NXTASK 3727 nprocs = GA_NNODES() 3728 count = 0 3729 next = NXTASK(nprocs,1) 3730 DO h1b = 1,noab 3731 DO h7b = 1,noab 3732 IF (next.eq.count) THEN 3733 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 3734 &).ne.4)) THEN 3735 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 3736 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 3737 &y,irrep_x)) THEN 3738 dimc = int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 3739 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3740 & ERRQUIT('eomccsd_density1_5_2_1',0,MA_ERR) 3741 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3742 DO p4b = noab+1,noab+nvab 3743 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h7b-1)) THEN 3744 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h7b-1)) .eq. irrep_x) TH 3745 &EN 3746 CALL TCE_RESTRICTED_2(p4b,h7b,p4b_1,h7b_1) 3747 CALL TCE_RESTRICTED_2(h1b,p4b,h1b_2,p4b_2) 3748 dim_common = int_mb(k_range+p4b-1) 3749 dima_sort = int_mb(k_range+h7b-1) 3750 dima = dim_common * dima_sort 3751 dimb_sort = int_mb(k_range+h1b-1) 3752 dimb = dim_common * dimb_sort 3753 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3754 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3755 & ERRQUIT('eomccsd_density1_5_2_1',1,MA_ERR) 3756 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3757 &eomccsd_density1_5_2_1',2,MA_ERR) 3758 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 3759 & - 1 + noab * (p4b_1 - noab - 1))) 3760 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 3761 &,int_mb(k_range+h7b-1),2,1,1.0d0) 3762 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_2_1', 3763 &3,MA_ERR) 3764 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3765 & ERRQUIT('eomccsd_density1_5_2_1',4,MA_ERR) 3766 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3767 &eomccsd_density1_5_2_1',5,MA_ERR) 3768 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 3769 & - noab - 1 + nvab * (h1b_2 - 1))) 3770 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 3771 &,int_mb(k_range+p4b-1),1,2,1.0d0) 3772 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_2_1', 3773 &6,MA_ERR) 3774 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 3775 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 3776 &t),dima_sort) 3777 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 3778 &2_1',7,MA_ERR) 3779 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 3780 &2_1',8,MA_ERR) 3781 END IF 3782 END IF 3783 END IF 3784 END DO 3785 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 3786 &eomccsd_density1_5_2_1',9,MA_ERR) 3787 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 3788 &,int_mb(k_range+h7b-1),1,2,1.0d0) 3789 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 3790 & 1 + noab * (h1b - 1))) 3791 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_2_1', 3792 &10,MA_ERR) 3793 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 3794 &2_1',11,MA_ERR) 3795 END IF 3796 END IF 3797 END IF 3798 next = NXTASK(nprocs,1) 3799 END IF 3800 count = count + 1 3801 END DO 3802 END DO 3803 next = NXTASK(-nprocs,1) 3804 call GA_SYNC() 3805 RETURN 3806 END 3807 SUBROUTINE OFFSET_eomccsd_density1_5_2_1(l_a_offset,k_a_offset,siz 3808 &e) 3809C $Id$ 3810C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3811C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3812C i2 ( h1 h7 )_yx 3813 IMPLICIT NONE 3814#include "global.fh" 3815#include "mafdecls.fh" 3816#include "sym.fh" 3817#include "errquit.fh" 3818#include "tce.fh" 3819 INTEGER l_a_offset 3820 INTEGER k_a_offset 3821 INTEGER size 3822 INTEGER length 3823 INTEGER addr 3824 INTEGER h1b 3825 INTEGER h7b 3826 length = 0 3827 DO h1b = 1,noab 3828 DO h7b = 1,noab 3829 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 3830 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 3831 &y,irrep_x)) THEN 3832 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 3833 &).ne.4)) THEN 3834 length = length + 1 3835 END IF 3836 END IF 3837 END IF 3838 END DO 3839 END DO 3840 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 3841 &set)) CALL ERRQUIT('eomccsd_density1_5_2_1',0,MA_ERR) 3842 int_mb(k_a_offset) = length 3843 addr = 0 3844 size = 0 3845 DO h1b = 1,noab 3846 DO h7b = 1,noab 3847 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 3848 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 3849 &y,irrep_x)) THEN 3850 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 3851 &).ne.4)) THEN 3852 addr = addr + 1 3853 int_mb(k_a_offset+addr) = h7b - 1 + noab * (h1b - 1) 3854 int_mb(k_a_offset+length+addr) = size 3855 size = size + int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 3856 END IF 3857 END IF 3858 END IF 3859 END DO 3860 END DO 3861 RETURN 3862 END 3863 SUBROUTINE eomccsd_density1_5_2_2(d_a,k_a_offset,d_b,k_b_offset,d_ 3864 &c,k_c_offset) 3865C $Id$ 3866C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 3867C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 3868C i2 ( h1 h7 )_yx + = -1/2 * Sum ( h6 p5 p4 ) * x ( p4 p5 h6 h7 )_x * y ( h1 h6 p4 p5 )_y 3869 IMPLICIT NONE 3870#include "global.fh" 3871#include "mafdecls.fh" 3872#include "sym.fh" 3873#include "errquit.fh" 3874#include "tce.fh" 3875 INTEGER d_a 3876 INTEGER k_a_offset 3877 INTEGER d_b 3878 INTEGER k_b_offset 3879 INTEGER d_c 3880 INTEGER k_c_offset 3881 INTEGER NXTASK 3882 INTEGER next 3883 INTEGER nprocs 3884 INTEGER count 3885 INTEGER h1b 3886 INTEGER h7b 3887 INTEGER dimc 3888 INTEGER l_c_sort 3889 INTEGER k_c_sort 3890 INTEGER p4b 3891 INTEGER p5b 3892 INTEGER h6b 3893 INTEGER p4b_1 3894 INTEGER p5b_1 3895 INTEGER h7b_1 3896 INTEGER h6b_1 3897 INTEGER h1b_2 3898 INTEGER h6b_2 3899 INTEGER p4b_2 3900 INTEGER p5b_2 3901 INTEGER dim_common 3902 INTEGER dima_sort 3903 INTEGER dima 3904 INTEGER dimb_sort 3905 INTEGER dimb 3906 INTEGER l_a_sort 3907 INTEGER k_a_sort 3908 INTEGER l_a 3909 INTEGER k_a 3910 INTEGER l_b_sort 3911 INTEGER k_b_sort 3912 INTEGER l_b 3913 INTEGER k_b 3914 INTEGER nsuperp(2) 3915 INTEGER isuperp 3916 INTEGER l_c 3917 INTEGER k_c 3918 DOUBLE PRECISION FACTORIAL 3919 EXTERNAL NXTASK 3920 EXTERNAL FACTORIAL 3921 nprocs = GA_NNODES() 3922 count = 0 3923 next = NXTASK(nprocs,1) 3924 DO h1b = 1,noab 3925 DO h7b = 1,noab 3926 IF (next.eq.count) THEN 3927 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 3928 &).ne.4)) THEN 3929 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 3930 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 3931 &y,irrep_x)) THEN 3932 dimc = int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 3933 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 3934 & ERRQUIT('eomccsd_density1_5_2_2',0,MA_ERR) 3935 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 3936 DO p4b = noab+1,noab+nvab 3937 DO p5b = p4b,noab+nvab 3938 DO h6b = 1,noab 3939 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 3940 &7b-1)+int_mb(k_spin+h6b-1)) THEN 3941 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 3942 &k_sym+h7b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_x) THEN 3943 CALL TCE_RESTRICTED_4(p4b,p5b,h7b,h6b,p4b_1,p5b_1,h7b_1,h6b_1) 3944 CALL TCE_RESTRICTED_4(h1b,h6b,p4b,p5b,h1b_2,h6b_2,p4b_2,p5b_2) 3945 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_m 3946 &b(k_range+h6b-1) 3947 dima_sort = int_mb(k_range+h7b-1) 3948 dima = dim_common * dima_sort 3949 dimb_sort = int_mb(k_range+h1b-1) 3950 dimb = dim_common * dimb_sort 3951 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 3952 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 3953 & ERRQUIT('eomccsd_density1_5_2_2',1,MA_ERR) 3954 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 3955 &eomccsd_density1_5_2_2',2,MA_ERR) 3956 IF ((h6b .le. h7b)) THEN 3957 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 3958 & - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_ 3959 &1 - noab - 1))))) 3960 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 3961 &,int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h7b-1) 3962 &,4,3,2,1,1.0d0) 3963 END IF 3964 IF ((h7b .lt. h6b)) THEN 3965 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 3966 & - 1 + noab * (h7b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_ 3967 &1 - noab - 1))))) 3968 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 3969 &,int_mb(k_range+p5b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1) 3970 &,3,4,2,1,-1.0d0) 3971 END IF 3972 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_2_2', 3973 &3,MA_ERR) 3974 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 3975 & ERRQUIT('eomccsd_density1_5_2_2',4,MA_ERR) 3976 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 3977 &eomccsd_density1_5_2_2',5,MA_ERR) 3978 IF ((h6b .lt. h1b)) THEN 3979 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 3980 & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (h1b_2 - 1 + noab 3981 &* (h6b_2 - 1))))) 3982 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 3983 &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1) 3984 &,2,1,4,3,-1.0d0) 3985 END IF 3986 IF ((h1b .le. h6b)) THEN 3987 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 3988 & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab 3989 &* (h1b_2 - 1))))) 3990 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 3991 &,int_mb(k_range+h6b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1) 3992 &,1,2,4,3,1.0d0) 3993 END IF 3994 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_2_2', 3995 &6,MA_ERR) 3996 nsuperp(1) = 1 3997 nsuperp(2) = 1 3998 isuperp = 1 3999 IF (p4b .eq. p5b) THEN 4000 nsuperp(isuperp) = nsuperp(isuperp) + 1 4001 ELSE 4002 isuperp = isuperp + 1 4003 END IF 4004 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 4005 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 4006 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 4007 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4008 &2_2',7,MA_ERR) 4009 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4010 &2_2',8,MA_ERR) 4011 END IF 4012 END IF 4013 END IF 4014 END DO 4015 END DO 4016 END DO 4017 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4018 &eomccsd_density1_5_2_2',9,MA_ERR) 4019 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 4020 &,int_mb(k_range+h7b-1),1,2,-1.0d0/2.0d0) 4021 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 4022 & 1 + noab * (h1b - 1))) 4023 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_2_2', 4024 &10,MA_ERR) 4025 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4026 &2_2',11,MA_ERR) 4027 END IF 4028 END IF 4029 END IF 4030 next = NXTASK(nprocs,1) 4031 END IF 4032 count = count + 1 4033 END DO 4034 END DO 4035 next = NXTASK(-nprocs,1) 4036 call GA_SYNC() 4037 RETURN 4038 END 4039 SUBROUTINE eomccsd_density1_5_2_3(d_a,k_a_offset,d_b,k_b_offset,d_ 4040 &c,k_c_offset) 4041C $Id$ 4042C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4043C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4044C i2 ( h1 h7 )_ytx + = 1 * x ( )_x * i3 ( h1 h7 )_yt 4045 IMPLICIT NONE 4046#include "global.fh" 4047#include "mafdecls.fh" 4048#include "sym.fh" 4049#include "errquit.fh" 4050#include "tce.fh" 4051 INTEGER d_a 4052 INTEGER k_a_offset 4053 INTEGER d_b 4054 INTEGER k_b_offset 4055 INTEGER d_c 4056 INTEGER k_c_offset 4057 INTEGER NXTASK 4058 INTEGER next 4059 INTEGER nprocs 4060 INTEGER count 4061 INTEGER h1b 4062 INTEGER h7b 4063 INTEGER dimc 4064 INTEGER l_c_sort 4065 INTEGER k_c_sort 4066 INTEGER h1b_2 4067 INTEGER h7b_2 4068 INTEGER dim_common 4069 INTEGER dima_sort 4070 INTEGER dima 4071 INTEGER dimb_sort 4072 INTEGER dimb 4073 INTEGER l_a_sort 4074 INTEGER k_a_sort 4075 INTEGER l_a 4076 INTEGER k_a 4077 INTEGER l_b_sort 4078 INTEGER k_b_sort 4079 INTEGER l_b 4080 INTEGER k_b 4081 INTEGER l_c 4082 INTEGER k_c 4083 EXTERNAL NXTASK 4084 nprocs = GA_NNODES() 4085 count = 0 4086 next = NXTASK(nprocs,1) 4087 DO h1b = 1,noab 4088 DO h7b = 1,noab 4089 IF (next.eq.count) THEN 4090 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 4091 &).ne.4)) THEN 4092 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4093 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 4094 &y,ieor(irrep_t,irrep_x))) THEN 4095 dimc = int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 4096 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4097 & ERRQUIT('eomccsd_density1_5_2_3',0,MA_ERR) 4098 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4099 IF (0 .eq. irrep_x) THEN 4100 CALL TCE_RESTRICTED_2(h1b,h7b,h1b_2,h7b_2) 4101 dim_common = 1 4102 dima_sort = 1 4103 dima = dim_common * dima_sort 4104 dimb_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 4105 dimb = dim_common * dimb_sort 4106 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4107 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4108 & ERRQUIT('eomccsd_density1_5_2_3',1,MA_ERR) 4109 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4110 &eomccsd_density1_5_2_3',2,MA_ERR) 4111 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),0) 4112 CALL TCE_SORT_0(dbl_mb(k_a),dbl_mb(k_a_sort),1.0d0) 4113 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_2_3', 4114 &3,MA_ERR) 4115 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4116 & ERRQUIT('eomccsd_density1_5_2_3',4,MA_ERR) 4117 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4118 &eomccsd_density1_5_2_3',5,MA_ERR) 4119 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h7b_2 4120 & - 1 + noab * (h1b_2 - 1))) 4121 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 4122 &,int_mb(k_range+h7b-1),2,1,1.0d0) 4123 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_2_3', 4124 &6,MA_ERR) 4125 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4126 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4127 &t),dima_sort) 4128 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4129 &2_3',7,MA_ERR) 4130 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4131 &2_3',8,MA_ERR) 4132 END IF 4133 END IF 4134 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4135 &eomccsd_density1_5_2_3',9,MA_ERR) 4136 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 4137 &,int_mb(k_range+h1b-1),2,1,1.0d0) 4138 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 4139 & 1 + noab * (h1b - 1))) 4140 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_2_3', 4141 &10,MA_ERR) 4142 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4143 &2_3',11,MA_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 eomccsd_density1_5_2_3_1(d_a,k_a_offset,d_b,k_b_offset, 4157 &d_c,k_c_offset) 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 i3 ( h1 h7 )_yt + = 1 * Sum ( p3 ) * t ( p3 h7 )_t * y ( h1 p3 )_y 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 h1b 4179 INTEGER h7b 4180 INTEGER dimc 4181 INTEGER l_c_sort 4182 INTEGER k_c_sort 4183 INTEGER p3b 4184 INTEGER p3b_1 4185 INTEGER h7b_1 4186 INTEGER h1b_2 4187 INTEGER p3b_2 4188 INTEGER dim_common 4189 INTEGER dima_sort 4190 INTEGER dima 4191 INTEGER dimb_sort 4192 INTEGER dimb 4193 INTEGER l_a_sort 4194 INTEGER k_a_sort 4195 INTEGER l_a 4196 INTEGER k_a 4197 INTEGER l_b_sort 4198 INTEGER k_b_sort 4199 INTEGER l_b 4200 INTEGER k_b 4201 INTEGER l_c 4202 INTEGER k_c 4203 EXTERNAL NXTASK 4204 nprocs = GA_NNODES() 4205 count = 0 4206 next = NXTASK(nprocs,1) 4207 DO h1b = 1,noab 4208 DO h7b = 1,noab 4209 IF (next.eq.count) THEN 4210 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 4211 &).ne.4)) THEN 4212 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4213 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 4214 &y,irrep_t)) THEN 4215 dimc = int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 4216 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4217 & ERRQUIT('eomccsd_density1_5_2_3_1',0,MA_ERR) 4218 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4219 DO p3b = noab+1,noab+nvab 4220 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4221 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 4222 &EN 4223 CALL TCE_RESTRICTED_2(p3b,h7b,p3b_1,h7b_1) 4224 CALL TCE_RESTRICTED_2(h1b,p3b,h1b_2,p3b_2) 4225 dim_common = int_mb(k_range+p3b-1) 4226 dima_sort = int_mb(k_range+h7b-1) 4227 dima = dim_common * dima_sort 4228 dimb_sort = int_mb(k_range+h1b-1) 4229 dimb = dim_common * dimb_sort 4230 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4231 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4232 & ERRQUIT('eomccsd_density1_5_2_3_1',1,MA_ERR) 4233 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4234 &eomccsd_density1_5_2_3_1',2,MA_ERR) 4235 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 4236 & - 1 + noab * (p3b_1 - noab - 1))) 4237 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4238 &,int_mb(k_range+h7b-1),2,1,1.0d0) 4239 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_2_3_1 4240 &',3,MA_ERR) 4241 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4242 & ERRQUIT('eomccsd_density1_5_2_3_1',4,MA_ERR) 4243 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4244 &eomccsd_density1_5_2_3_1',5,MA_ERR) 4245 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4246 & - noab - 1 + nvab * (h1b_2 - 1))) 4247 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 4248 &,int_mb(k_range+p3b-1),1,2,1.0d0) 4249 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_2_3_1 4250 &',6,MA_ERR) 4251 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4252 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4253 &t),dima_sort) 4254 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4255 &2_3_1',7,MA_ERR) 4256 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4257 &2_3_1',8,MA_ERR) 4258 END IF 4259 END IF 4260 END IF 4261 END DO 4262 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4263 &eomccsd_density1_5_2_3_1',9,MA_ERR) 4264 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 4265 &,int_mb(k_range+h7b-1),1,2,1.0d0) 4266 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 4267 & 1 + noab * (h1b - 1))) 4268 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_2_3_1 4269 &',10,MA_ERR) 4270 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4271 &2_3_1',11,MA_ERR) 4272 END IF 4273 END IF 4274 END IF 4275 next = NXTASK(nprocs,1) 4276 END IF 4277 count = count + 1 4278 END DO 4279 END DO 4280 next = NXTASK(-nprocs,1) 4281 call GA_SYNC() 4282 RETURN 4283 END 4284 SUBROUTINE OFFSET_eomccsd_density1_5_2_3_1(l_a_offset,k_a_offset,s 4285 &ize) 4286C $Id$ 4287C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4288C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4289C i3 ( h1 h7 )_yt 4290 IMPLICIT NONE 4291#include "global.fh" 4292#include "mafdecls.fh" 4293#include "sym.fh" 4294#include "errquit.fh" 4295#include "tce.fh" 4296 INTEGER l_a_offset 4297 INTEGER k_a_offset 4298 INTEGER size 4299 INTEGER length 4300 INTEGER addr 4301 INTEGER h1b 4302 INTEGER h7b 4303 length = 0 4304 DO h1b = 1,noab 4305 DO h7b = 1,noab 4306 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4307 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 4308 &y,irrep_t)) THEN 4309 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 4310 &).ne.4)) THEN 4311 length = length + 1 4312 END IF 4313 END IF 4314 END IF 4315 END DO 4316 END DO 4317 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 4318 &set)) CALL ERRQUIT('eomccsd_density1_5_2_3_1',0,MA_ERR) 4319 int_mb(k_a_offset) = length 4320 addr = 0 4321 size = 0 4322 DO h1b = 1,noab 4323 DO h7b = 1,noab 4324 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4325 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 4326 &y,irrep_t)) THEN 4327 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 4328 &).ne.4)) THEN 4329 addr = addr + 1 4330 int_mb(k_a_offset+addr) = h7b - 1 + noab * (h1b - 1) 4331 int_mb(k_a_offset+length+addr) = size 4332 size = size + int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 4333 END IF 4334 END IF 4335 END IF 4336 END DO 4337 END DO 4338 RETURN 4339 END 4340 SUBROUTINE eomccsd_density1_5_2_3_2(d_a,k_a_offset,d_b,k_b_offset, 4341 &d_c,k_c_offset) 4342C $Id$ 4343C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4344C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4345C i3 ( h1 h7 )_yt + = -1/2 * Sum ( h5 p4 p3 ) * t ( p3 p4 h5 h7 )_t * y ( h1 h5 p3 p4 )_y 4346 IMPLICIT NONE 4347#include "global.fh" 4348#include "mafdecls.fh" 4349#include "sym.fh" 4350#include "errquit.fh" 4351#include "tce.fh" 4352 INTEGER d_a 4353 INTEGER k_a_offset 4354 INTEGER d_b 4355 INTEGER k_b_offset 4356 INTEGER d_c 4357 INTEGER k_c_offset 4358 INTEGER NXTASK 4359 INTEGER next 4360 INTEGER nprocs 4361 INTEGER count 4362 INTEGER h1b 4363 INTEGER h7b 4364 INTEGER dimc 4365 INTEGER l_c_sort 4366 INTEGER k_c_sort 4367 INTEGER p3b 4368 INTEGER p4b 4369 INTEGER h5b 4370 INTEGER p3b_1 4371 INTEGER p4b_1 4372 INTEGER h7b_1 4373 INTEGER h5b_1 4374 INTEGER h1b_2 4375 INTEGER h5b_2 4376 INTEGER p3b_2 4377 INTEGER p4b_2 4378 INTEGER dim_common 4379 INTEGER dima_sort 4380 INTEGER dima 4381 INTEGER dimb_sort 4382 INTEGER dimb 4383 INTEGER l_a_sort 4384 INTEGER k_a_sort 4385 INTEGER l_a 4386 INTEGER k_a 4387 INTEGER l_b_sort 4388 INTEGER k_b_sort 4389 INTEGER l_b 4390 INTEGER k_b 4391 INTEGER nsuperp(2) 4392 INTEGER isuperp 4393 INTEGER l_c 4394 INTEGER k_c 4395 DOUBLE PRECISION FACTORIAL 4396 EXTERNAL NXTASK 4397 EXTERNAL FACTORIAL 4398 nprocs = GA_NNODES() 4399 count = 0 4400 next = NXTASK(nprocs,1) 4401 DO h1b = 1,noab 4402 DO h7b = 1,noab 4403 IF (next.eq.count) THEN 4404 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 4405 &).ne.4)) THEN 4406 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4407 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 4408 &y,irrep_t)) THEN 4409 dimc = int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 4410 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4411 & ERRQUIT('eomccsd_density1_5_2_3_2',0,MA_ERR) 4412 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4413 DO p3b = noab+1,noab+nvab 4414 DO p4b = p3b,noab+nvab 4415 DO h5b = 1,noab 4416 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 4417 &7b-1)+int_mb(k_spin+h5b-1)) THEN 4418 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 4419 &k_sym+h7b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN 4420 CALL TCE_RESTRICTED_4(p3b,p4b,h7b,h5b,p3b_1,p4b_1,h7b_1,h5b_1) 4421 CALL TCE_RESTRICTED_4(h1b,h5b,p3b,p4b,h1b_2,h5b_2,p3b_2,p4b_2) 4422 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m 4423 &b(k_range+h5b-1) 4424 dima_sort = int_mb(k_range+h7b-1) 4425 dima = dim_common * dima_sort 4426 dimb_sort = int_mb(k_range+h1b-1) 4427 dimb = dim_common * dimb_sort 4428 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4429 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4430 & ERRQUIT('eomccsd_density1_5_2_3_2',1,MA_ERR) 4431 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4432 &eomccsd_density1_5_2_3_2',2,MA_ERR) 4433 IF ((h5b .le. h7b)) THEN 4434 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 4435 & - 1 + noab * (h5b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 4436 &1 - noab - 1))))) 4437 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4438 &,int_mb(k_range+p4b-1),int_mb(k_range+h5b-1),int_mb(k_range+h7b-1) 4439 &,4,3,2,1,1.0d0) 4440 END IF 4441 IF ((h7b .lt. h5b)) THEN 4442 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 4443 & - 1 + noab * (h7b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 4444 &1 - noab - 1))))) 4445 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4446 &,int_mb(k_range+p4b-1),int_mb(k_range+h7b-1),int_mb(k_range+h5b-1) 4447 &,3,4,2,1,-1.0d0) 4448 END IF 4449 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_2_3_2 4450 &',3,MA_ERR) 4451 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4452 & ERRQUIT('eomccsd_density1_5_2_3_2',4,MA_ERR) 4453 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4454 &eomccsd_density1_5_2_3_2',5,MA_ERR) 4455 IF ((h5b .lt. h1b)) THEN 4456 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 4457 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h1b_2 - 1 + noab 4458 &* (h5b_2 - 1))))) 4459 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 4460 &,int_mb(k_range+h1b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 4461 &,2,1,4,3,-1.0d0) 4462 END IF 4463 IF ((h1b .le. h5b)) THEN 4464 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 4465 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 4466 &* (h1b_2 - 1))))) 4467 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 4468 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 4469 &,1,2,4,3,1.0d0) 4470 END IF 4471 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_2_3_2 4472 &',6,MA_ERR) 4473 nsuperp(1) = 1 4474 nsuperp(2) = 1 4475 isuperp = 1 4476 IF (p3b .eq. p4b) THEN 4477 nsuperp(isuperp) = nsuperp(isuperp) + 1 4478 ELSE 4479 isuperp = isuperp + 1 4480 END IF 4481 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 4482 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 4483 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 4484 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4485 &2_3_2',7,MA_ERR) 4486 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4487 &2_3_2',8,MA_ERR) 4488 END IF 4489 END IF 4490 END IF 4491 END DO 4492 END DO 4493 END DO 4494 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4495 &eomccsd_density1_5_2_3_2',9,MA_ERR) 4496 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 4497 &,int_mb(k_range+h7b-1),1,2,-1.0d0/2.0d0) 4498 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 4499 & 1 + noab * (h1b - 1))) 4500 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_2_3_2 4501 &',10,MA_ERR) 4502 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4503 &2_3_2',11,MA_ERR) 4504 END IF 4505 END IF 4506 END IF 4507 next = NXTASK(nprocs,1) 4508 END IF 4509 count = count + 1 4510 END DO 4511 END DO 4512 next = NXTASK(-nprocs,1) 4513 call GA_SYNC() 4514 RETURN 4515 END 4516 SUBROUTINE eomccsd_density1_5_2_4(d_a,k_a_offset,d_b,k_b_offset,d_ 4517 &c,k_c_offset) 4518C $Id$ 4519C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4520C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4521C i2 ( h1 h7 )_yxt + = 1 * Sum ( p3 ) * t ( p3 h7 )_t * i3 ( h1 p3 )_yx 4522 IMPLICIT NONE 4523#include "global.fh" 4524#include "mafdecls.fh" 4525#include "sym.fh" 4526#include "errquit.fh" 4527#include "tce.fh" 4528 INTEGER d_a 4529 INTEGER k_a_offset 4530 INTEGER d_b 4531 INTEGER k_b_offset 4532 INTEGER d_c 4533 INTEGER k_c_offset 4534 INTEGER NXTASK 4535 INTEGER next 4536 INTEGER nprocs 4537 INTEGER count 4538 INTEGER h1b 4539 INTEGER h7b 4540 INTEGER dimc 4541 INTEGER l_c_sort 4542 INTEGER k_c_sort 4543 INTEGER p3b 4544 INTEGER p3b_1 4545 INTEGER h7b_1 4546 INTEGER h1b_2 4547 INTEGER p3b_2 4548 INTEGER dim_common 4549 INTEGER dima_sort 4550 INTEGER dima 4551 INTEGER dimb_sort 4552 INTEGER dimb 4553 INTEGER l_a_sort 4554 INTEGER k_a_sort 4555 INTEGER l_a 4556 INTEGER k_a 4557 INTEGER l_b_sort 4558 INTEGER k_b_sort 4559 INTEGER l_b 4560 INTEGER k_b 4561 INTEGER l_c 4562 INTEGER k_c 4563 EXTERNAL NXTASK 4564 nprocs = GA_NNODES() 4565 count = 0 4566 next = NXTASK(nprocs,1) 4567 DO h1b = 1,noab 4568 DO h7b = 1,noab 4569 IF (next.eq.count) THEN 4570 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 4571 &).ne.4)) THEN 4572 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4573 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 4574 &y,ieor(irrep_x,irrep_t))) THEN 4575 dimc = int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 4576 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4577 & ERRQUIT('eomccsd_density1_5_2_4',0,MA_ERR) 4578 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4579 DO p3b = noab+1,noab+nvab 4580 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4581 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 4582 &EN 4583 CALL TCE_RESTRICTED_2(p3b,h7b,p3b_1,h7b_1) 4584 CALL TCE_RESTRICTED_2(h1b,p3b,h1b_2,p3b_2) 4585 dim_common = int_mb(k_range+p3b-1) 4586 dima_sort = int_mb(k_range+h7b-1) 4587 dima = dim_common * dima_sort 4588 dimb_sort = int_mb(k_range+h1b-1) 4589 dimb = dim_common * dimb_sort 4590 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4591 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4592 & ERRQUIT('eomccsd_density1_5_2_4',1,MA_ERR) 4593 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4594 &eomccsd_density1_5_2_4',2,MA_ERR) 4595 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 4596 & - 1 + noab * (p3b_1 - noab - 1))) 4597 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 4598 &,int_mb(k_range+h7b-1),2,1,1.0d0) 4599 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_2_4', 4600 &3,MA_ERR) 4601 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4602 & ERRQUIT('eomccsd_density1_5_2_4',4,MA_ERR) 4603 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4604 &eomccsd_density1_5_2_4',5,MA_ERR) 4605 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4606 & - noab - 1 + nvab * (h1b_2 - 1))) 4607 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 4608 &,int_mb(k_range+p3b-1),1,2,1.0d0) 4609 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_2_4', 4610 &6,MA_ERR) 4611 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4612 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4613 &t),dima_sort) 4614 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4615 &2_4',7,MA_ERR) 4616 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4617 &2_4',8,MA_ERR) 4618 END IF 4619 END IF 4620 END IF 4621 END DO 4622 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4623 &eomccsd_density1_5_2_4',9,MA_ERR) 4624 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 4625 &,int_mb(k_range+h7b-1),1,2,1.0d0) 4626 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 4627 & 1 + noab * (h1b - 1))) 4628 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_2_4', 4629 &10,MA_ERR) 4630 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4631 &2_4',11,MA_ERR) 4632 END IF 4633 END IF 4634 END IF 4635 next = NXTASK(nprocs,1) 4636 END IF 4637 count = count + 1 4638 END DO 4639 END DO 4640 next = NXTASK(-nprocs,1) 4641 call GA_SYNC() 4642 RETURN 4643 END 4644 SUBROUTINE eomccsd_density1_5_2_4_1(d_a,k_a_offset,d_b,k_b_offset, 4645 &d_c,k_c_offset) 4646C $Id$ 4647C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4648C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4649C i3 ( h1 p3 )_yx + = 1 * Sum ( h6 p5 ) * x ( p5 h6 )_x * y ( h1 h6 p3 p5 )_y 4650 IMPLICIT NONE 4651#include "global.fh" 4652#include "mafdecls.fh" 4653#include "sym.fh" 4654#include "errquit.fh" 4655#include "tce.fh" 4656 INTEGER d_a 4657 INTEGER k_a_offset 4658 INTEGER d_b 4659 INTEGER k_b_offset 4660 INTEGER d_c 4661 INTEGER k_c_offset 4662 INTEGER NXTASK 4663 INTEGER next 4664 INTEGER nprocs 4665 INTEGER count 4666 INTEGER h1b 4667 INTEGER p3b 4668 INTEGER dimc 4669 INTEGER l_c_sort 4670 INTEGER k_c_sort 4671 INTEGER p5b 4672 INTEGER h6b 4673 INTEGER p5b_1 4674 INTEGER h6b_1 4675 INTEGER h1b_2 4676 INTEGER h6b_2 4677 INTEGER p3b_2 4678 INTEGER p5b_2 4679 INTEGER dim_common 4680 INTEGER dima_sort 4681 INTEGER dima 4682 INTEGER dimb_sort 4683 INTEGER dimb 4684 INTEGER l_a_sort 4685 INTEGER k_a_sort 4686 INTEGER l_a 4687 INTEGER k_a 4688 INTEGER l_b_sort 4689 INTEGER k_b_sort 4690 INTEGER l_b 4691 INTEGER k_b 4692 INTEGER l_c 4693 INTEGER k_c 4694 EXTERNAL NXTASK 4695 nprocs = GA_NNODES() 4696 count = 0 4697 next = NXTASK(nprocs,1) 4698 DO h1b = 1,noab 4699 DO p3b = noab+1,noab+nvab 4700 IF (next.eq.count) THEN 4701 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1 4702 &).ne.4)) THEN 4703 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4704 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4705 &y,irrep_x)) THEN 4706 dimc = int_mb(k_range+h1b-1) * int_mb(k_range+p3b-1) 4707 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4708 & ERRQUIT('eomccsd_density1_5_2_4_1',0,MA_ERR) 4709 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4710 DO p5b = noab+1,noab+nvab 4711 DO h6b = 1,noab 4712 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h6b-1)) THEN 4713 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h6b-1)) .eq. irrep_x) TH 4714 &EN 4715 CALL TCE_RESTRICTED_2(p5b,h6b,p5b_1,h6b_1) 4716 CALL TCE_RESTRICTED_4(h1b,h6b,p3b,p5b,h1b_2,h6b_2,p3b_2,p5b_2) 4717 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) 4718 dima_sort = 1 4719 dima = dim_common * dima_sort 4720 dimb_sort = int_mb(k_range+h1b-1) * int_mb(k_range+p3b-1) 4721 dimb = dim_common * dimb_sort 4722 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4723 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4724 & ERRQUIT('eomccsd_density1_5_2_4_1',1,MA_ERR) 4725 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4726 &eomccsd_density1_5_2_4_1',2,MA_ERR) 4727 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 4728 & - 1 + noab * (p5b_1 - noab - 1))) 4729 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 4730 &,int_mb(k_range+h6b-1),2,1,1.0d0) 4731 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_2_4_1 4732 &',3,MA_ERR) 4733 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4734 & ERRQUIT('eomccsd_density1_5_2_4_1',4,MA_ERR) 4735 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4736 &eomccsd_density1_5_2_4_1',5,MA_ERR) 4737 IF ((h6b .lt. h1b) .and. (p5b .lt. p3b)) THEN 4738 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4739 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h1b_2 - 1 + noab 4740 &* (h6b_2 - 1))))) 4741 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 4742 &,int_mb(k_range+h1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1) 4743 &,4,2,1,3,1.0d0) 4744 END IF 4745 IF ((h6b .lt. h1b) .and. (p3b .le. p5b)) THEN 4746 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 4747 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h1b_2 - 1 + noab 4748 &* (h6b_2 - 1))))) 4749 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 4750 &,int_mb(k_range+h1b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1) 4751 &,3,2,1,4,-1.0d0) 4752 END IF 4753 IF ((h1b .le. h6b) .and. (p5b .lt. p3b)) THEN 4754 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 4755 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab 4756 &* (h1b_2 - 1))))) 4757 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 4758 &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1) 4759 &,4,1,2,3,-1.0d0) 4760 END IF 4761 IF ((h1b .le. h6b) .and. (p3b .le. p5b)) THEN 4762 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 4763 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab 4764 &* (h1b_2 - 1))))) 4765 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 4766 &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1) 4767 &,3,1,2,4,1.0d0) 4768 END IF 4769 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_2_4_1 4770 &',6,MA_ERR) 4771 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4772 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4773 &t),dima_sort) 4774 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4775 &2_4_1',7,MA_ERR) 4776 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4777 &2_4_1',8,MA_ERR) 4778 END IF 4779 END IF 4780 END IF 4781 END DO 4782 END DO 4783 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4784 &eomccsd_density1_5_2_4_1',9,MA_ERR) 4785 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 4786 &,int_mb(k_range+h1b-1),2,1,1.0d0) 4787 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 4788 & noab - 1 + nvab * (h1b - 1))) 4789 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_2_4_1 4790 &',10,MA_ERR) 4791 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4792 &2_4_1',11,MA_ERR) 4793 END IF 4794 END IF 4795 END IF 4796 next = NXTASK(nprocs,1) 4797 END IF 4798 count = count + 1 4799 END DO 4800 END DO 4801 next = NXTASK(-nprocs,1) 4802 call GA_SYNC() 4803 RETURN 4804 END 4805 SUBROUTINE OFFSET_eomccsd_density1_5_2_4_1(l_a_offset,k_a_offset,s 4806 &ize) 4807C $Id$ 4808C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4809C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4810C i3 ( h1 p3 )_yx 4811 IMPLICIT NONE 4812#include "global.fh" 4813#include "mafdecls.fh" 4814#include "sym.fh" 4815#include "errquit.fh" 4816#include "tce.fh" 4817 INTEGER l_a_offset 4818 INTEGER k_a_offset 4819 INTEGER size 4820 INTEGER length 4821 INTEGER addr 4822 INTEGER h1b 4823 INTEGER p3b 4824 length = 0 4825 DO h1b = 1,noab 4826 DO p3b = noab+1,noab+nvab 4827 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4828 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4829 &y,irrep_x)) THEN 4830 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1 4831 &).ne.4)) THEN 4832 length = length + 1 4833 END IF 4834 END IF 4835 END IF 4836 END DO 4837 END DO 4838 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 4839 &set)) CALL ERRQUIT('eomccsd_density1_5_2_4_1',0,MA_ERR) 4840 int_mb(k_a_offset) = length 4841 addr = 0 4842 size = 0 4843 DO h1b = 1,noab 4844 DO p3b = noab+1,noab+nvab 4845 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+p3b-1)) THEN 4846 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 4847 &y,irrep_x)) THEN 4848 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1 4849 &).ne.4)) THEN 4850 addr = addr + 1 4851 int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h1b - 1) 4852 int_mb(k_a_offset+length+addr) = size 4853 size = size + int_mb(k_range+h1b-1) * int_mb(k_range+p3b-1) 4854 END IF 4855 END IF 4856 END IF 4857 END DO 4858 END DO 4859 RETURN 4860 END 4861 SUBROUTINE eomccsd_density1_5_3(d_a,k_a_offset,d_b,k_b_offset,d_c, 4862 &k_c_offset) 4863C $Id$ 4864C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4865C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4866C i1 ( p8 h7 )_ytx + = -1 * Sum ( h1 ) * x ( p8 h1 )_x * i2 ( h1 h7 )_yt 4867 IMPLICIT NONE 4868#include "global.fh" 4869#include "mafdecls.fh" 4870#include "sym.fh" 4871#include "errquit.fh" 4872#include "tce.fh" 4873 INTEGER d_a 4874 INTEGER k_a_offset 4875 INTEGER d_b 4876 INTEGER k_b_offset 4877 INTEGER d_c 4878 INTEGER k_c_offset 4879 INTEGER NXTASK 4880 INTEGER next 4881 INTEGER nprocs 4882 INTEGER count 4883 INTEGER p8b 4884 INTEGER h7b 4885 INTEGER dimc 4886 INTEGER l_c_sort 4887 INTEGER k_c_sort 4888 INTEGER h1b 4889 INTEGER p8b_1 4890 INTEGER h1b_1 4891 INTEGER h1b_2 4892 INTEGER h7b_2 4893 INTEGER dim_common 4894 INTEGER dima_sort 4895 INTEGER dima 4896 INTEGER dimb_sort 4897 INTEGER dimb 4898 INTEGER l_a_sort 4899 INTEGER k_a_sort 4900 INTEGER l_a 4901 INTEGER k_a 4902 INTEGER l_b_sort 4903 INTEGER k_b_sort 4904 INTEGER l_b 4905 INTEGER k_b 4906 INTEGER l_c 4907 INTEGER k_c 4908 EXTERNAL NXTASK 4909 nprocs = GA_NNODES() 4910 count = 0 4911 next = NXTASK(nprocs,1) 4912 DO p8b = noab+1,noab+nvab 4913 DO h7b = 1,noab 4914 IF (next.eq.count) THEN 4915 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 4916 &).ne.4)) THEN 4917 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 4918 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 4919 &y,ieor(irrep_t,irrep_x))) THEN 4920 dimc = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 4921 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 4922 & ERRQUIT('eomccsd_density1_5_3',0,MA_ERR) 4923 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 4924 DO h1b = 1,noab 4925 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)) THEN 4926 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH 4927 &EN 4928 CALL TCE_RESTRICTED_2(p8b,h1b,p8b_1,h1b_1) 4929 CALL TCE_RESTRICTED_2(h1b,h7b,h1b_2,h7b_2) 4930 dim_common = int_mb(k_range+h1b-1) 4931 dima_sort = int_mb(k_range+p8b-1) 4932 dima = dim_common * dima_sort 4933 dimb_sort = int_mb(k_range+h7b-1) 4934 dimb = dim_common * dimb_sort 4935 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 4936 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 4937 & ERRQUIT('eomccsd_density1_5_3',1,MA_ERR) 4938 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 4939 &eomccsd_density1_5_3',2,MA_ERR) 4940 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 4941 & - 1 + noab * (p8b_1 - noab - 1))) 4942 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 4943 &,int_mb(k_range+h1b-1),1,2,1.0d0) 4944 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_3',3, 4945 &MA_ERR) 4946 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 4947 & ERRQUIT('eomccsd_density1_5_3',4,MA_ERR) 4948 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 4949 &eomccsd_density1_5_3',5,MA_ERR) 4950 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h7b_2 4951 & - 1 + noab * (h1b_2 - 1))) 4952 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 4953 &,int_mb(k_range+h7b-1),2,1,1.0d0) 4954 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_3',6, 4955 &MA_ERR) 4956 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 4957 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 4958 &t),dima_sort) 4959 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4960 &3',7,MA_ERR) 4961 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4962 &3',8,MA_ERR) 4963 END IF 4964 END IF 4965 END IF 4966 END DO 4967 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 4968 &eomccsd_density1_5_3',9,MA_ERR) 4969 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 4970 &,int_mb(k_range+p8b-1),2,1,-1.0d0) 4971 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 4972 & 1 + noab * (p8b - noab - 1))) 4973 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_3',10 4974 &,MA_ERR) 4975 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 4976 &3',11,MA_ERR) 4977 END IF 4978 END IF 4979 END IF 4980 next = NXTASK(nprocs,1) 4981 END IF 4982 count = count + 1 4983 END DO 4984 END DO 4985 next = NXTASK(-nprocs,1) 4986 call GA_SYNC() 4987 RETURN 4988 END 4989 SUBROUTINE eomccsd_density1_5_3_1(d_a,k_a_offset,d_b,k_b_offset,d_ 4990 &c,k_c_offset) 4991C $Id$ 4992C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4993C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 4994C i2 ( h1 h7 )_yt + = 1 * Sum ( p3 ) * t ( p3 h7 )_t * y ( h1 p3 )_y 4995 IMPLICIT NONE 4996#include "global.fh" 4997#include "mafdecls.fh" 4998#include "sym.fh" 4999#include "errquit.fh" 5000#include "tce.fh" 5001 INTEGER d_a 5002 INTEGER k_a_offset 5003 INTEGER d_b 5004 INTEGER k_b_offset 5005 INTEGER d_c 5006 INTEGER k_c_offset 5007 INTEGER NXTASK 5008 INTEGER next 5009 INTEGER nprocs 5010 INTEGER count 5011 INTEGER h1b 5012 INTEGER h7b 5013 INTEGER dimc 5014 INTEGER l_c_sort 5015 INTEGER k_c_sort 5016 INTEGER p3b 5017 INTEGER p3b_1 5018 INTEGER h7b_1 5019 INTEGER h1b_2 5020 INTEGER p3b_2 5021 INTEGER dim_common 5022 INTEGER dima_sort 5023 INTEGER dima 5024 INTEGER dimb_sort 5025 INTEGER dimb 5026 INTEGER l_a_sort 5027 INTEGER k_a_sort 5028 INTEGER l_a 5029 INTEGER k_a 5030 INTEGER l_b_sort 5031 INTEGER k_b_sort 5032 INTEGER l_b 5033 INTEGER k_b 5034 INTEGER l_c 5035 INTEGER k_c 5036 EXTERNAL NXTASK 5037 nprocs = GA_NNODES() 5038 count = 0 5039 next = NXTASK(nprocs,1) 5040 DO h1b = 1,noab 5041 DO h7b = 1,noab 5042 IF (next.eq.count) THEN 5043 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 5044 &).ne.4)) THEN 5045 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 5046 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 5047 &y,irrep_t)) THEN 5048 dimc = int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 5049 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5050 & ERRQUIT('eomccsd_density1_5_3_1',0,MA_ERR) 5051 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5052 DO p3b = noab+1,noab+nvab 5053 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h7b-1)) THEN 5054 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 5055 &EN 5056 CALL TCE_RESTRICTED_2(p3b,h7b,p3b_1,h7b_1) 5057 CALL TCE_RESTRICTED_2(h1b,p3b,h1b_2,p3b_2) 5058 dim_common = int_mb(k_range+p3b-1) 5059 dima_sort = int_mb(k_range+h7b-1) 5060 dima = dim_common * dima_sort 5061 dimb_sort = int_mb(k_range+h1b-1) 5062 dimb = dim_common * dimb_sort 5063 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5064 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5065 & ERRQUIT('eomccsd_density1_5_3_1',1,MA_ERR) 5066 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5067 &eomccsd_density1_5_3_1',2,MA_ERR) 5068 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 5069 & - 1 + noab * (p3b_1 - noab - 1))) 5070 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5071 &,int_mb(k_range+h7b-1),2,1,1.0d0) 5072 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_3_1', 5073 &3,MA_ERR) 5074 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5075 & ERRQUIT('eomccsd_density1_5_3_1',4,MA_ERR) 5076 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5077 &eomccsd_density1_5_3_1',5,MA_ERR) 5078 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 5079 & - noab - 1 + nvab * (h1b_2 - 1))) 5080 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 5081 &,int_mb(k_range+p3b-1),1,2,1.0d0) 5082 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_3_1', 5083 &6,MA_ERR) 5084 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 5085 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 5086 &t),dima_sort) 5087 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5088 &3_1',7,MA_ERR) 5089 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5090 &3_1',8,MA_ERR) 5091 END IF 5092 END IF 5093 END IF 5094 END DO 5095 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5096 &eomccsd_density1_5_3_1',9,MA_ERR) 5097 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 5098 &,int_mb(k_range+h7b-1),1,2,1.0d0) 5099 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 5100 & 1 + noab * (h1b - 1))) 5101 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_3_1', 5102 &10,MA_ERR) 5103 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5104 &3_1',11,MA_ERR) 5105 END IF 5106 END IF 5107 END IF 5108 next = NXTASK(nprocs,1) 5109 END IF 5110 count = count + 1 5111 END DO 5112 END DO 5113 next = NXTASK(-nprocs,1) 5114 call GA_SYNC() 5115 RETURN 5116 END 5117 SUBROUTINE OFFSET_eomccsd_density1_5_3_1(l_a_offset,k_a_offset,siz 5118 &e) 5119C $Id$ 5120C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5121C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5122C i2 ( h1 h7 )_yt 5123 IMPLICIT NONE 5124#include "global.fh" 5125#include "mafdecls.fh" 5126#include "sym.fh" 5127#include "errquit.fh" 5128#include "tce.fh" 5129 INTEGER l_a_offset 5130 INTEGER k_a_offset 5131 INTEGER size 5132 INTEGER length 5133 INTEGER addr 5134 INTEGER h1b 5135 INTEGER h7b 5136 length = 0 5137 DO h1b = 1,noab 5138 DO h7b = 1,noab 5139 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 5140 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 5141 &y,irrep_t)) THEN 5142 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 5143 &).ne.4)) THEN 5144 length = length + 1 5145 END IF 5146 END IF 5147 END IF 5148 END DO 5149 END DO 5150 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 5151 &set)) CALL ERRQUIT('eomccsd_density1_5_3_1',0,MA_ERR) 5152 int_mb(k_a_offset) = length 5153 addr = 0 5154 size = 0 5155 DO h1b = 1,noab 5156 DO h7b = 1,noab 5157 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 5158 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 5159 &y,irrep_t)) THEN 5160 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 5161 &).ne.4)) THEN 5162 addr = addr + 1 5163 int_mb(k_a_offset+addr) = h7b - 1 + noab * (h1b - 1) 5164 int_mb(k_a_offset+length+addr) = size 5165 size = size + int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 5166 END IF 5167 END IF 5168 END IF 5169 END DO 5170 END DO 5171 RETURN 5172 END 5173 SUBROUTINE eomccsd_density1_5_3_2(d_a,k_a_offset,d_b,k_b_offset,d_ 5174 &c,k_c_offset) 5175C $Id$ 5176C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5177C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5178C i2 ( h1 h7 )_yt + = -1/2 * Sum ( h5 p4 p3 ) * t ( p3 p4 h5 h7 )_t * y ( h1 h5 p3 p4 )_y 5179 IMPLICIT NONE 5180#include "global.fh" 5181#include "mafdecls.fh" 5182#include "sym.fh" 5183#include "errquit.fh" 5184#include "tce.fh" 5185 INTEGER d_a 5186 INTEGER k_a_offset 5187 INTEGER d_b 5188 INTEGER k_b_offset 5189 INTEGER d_c 5190 INTEGER k_c_offset 5191 INTEGER NXTASK 5192 INTEGER next 5193 INTEGER nprocs 5194 INTEGER count 5195 INTEGER h1b 5196 INTEGER h7b 5197 INTEGER dimc 5198 INTEGER l_c_sort 5199 INTEGER k_c_sort 5200 INTEGER p3b 5201 INTEGER p4b 5202 INTEGER h5b 5203 INTEGER p3b_1 5204 INTEGER p4b_1 5205 INTEGER h7b_1 5206 INTEGER h5b_1 5207 INTEGER h1b_2 5208 INTEGER h5b_2 5209 INTEGER p3b_2 5210 INTEGER p4b_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 nsuperp(2) 5225 INTEGER isuperp 5226 INTEGER l_c 5227 INTEGER k_c 5228 DOUBLE PRECISION FACTORIAL 5229 EXTERNAL NXTASK 5230 EXTERNAL FACTORIAL 5231 nprocs = GA_NNODES() 5232 count = 0 5233 next = NXTASK(nprocs,1) 5234 DO h1b = 1,noab 5235 DO h7b = 1,noab 5236 IF (next.eq.count) THEN 5237 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+h7b-1 5238 &).ne.4)) THEN 5239 IF (int_mb(k_spin+h1b-1) .eq. int_mb(k_spin+h7b-1)) THEN 5240 IF (ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 5241 &y,irrep_t)) THEN 5242 dimc = int_mb(k_range+h1b-1) * int_mb(k_range+h7b-1) 5243 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5244 & ERRQUIT('eomccsd_density1_5_3_2',0,MA_ERR) 5245 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5246 DO p3b = noab+1,noab+nvab 5247 DO p4b = p3b,noab+nvab 5248 DO h5b = 1,noab 5249 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 5250 &7b-1)+int_mb(k_spin+h5b-1)) THEN 5251 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 5252 &k_sym+h7b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN 5253 CALL TCE_RESTRICTED_4(p3b,p4b,h7b,h5b,p3b_1,p4b_1,h7b_1,h5b_1) 5254 CALL TCE_RESTRICTED_4(h1b,h5b,p3b,p4b,h1b_2,h5b_2,p3b_2,p4b_2) 5255 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m 5256 &b(k_range+h5b-1) 5257 dima_sort = int_mb(k_range+h7b-1) 5258 dima = dim_common * dima_sort 5259 dimb_sort = int_mb(k_range+h1b-1) 5260 dimb = dim_common * dimb_sort 5261 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5262 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5263 & ERRQUIT('eomccsd_density1_5_3_2',1,MA_ERR) 5264 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5265 &eomccsd_density1_5_3_2',2,MA_ERR) 5266 IF ((h5b .le. h7b)) THEN 5267 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 5268 & - 1 + noab * (h5b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 5269 &1 - noab - 1))))) 5270 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5271 &,int_mb(k_range+p4b-1),int_mb(k_range+h5b-1),int_mb(k_range+h7b-1) 5272 &,4,3,2,1,1.0d0) 5273 END IF 5274 IF ((h7b .lt. h5b)) THEN 5275 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 5276 & - 1 + noab * (h7b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 5277 &1 - noab - 1))))) 5278 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5279 &,int_mb(k_range+p4b-1),int_mb(k_range+h7b-1),int_mb(k_range+h5b-1) 5280 &,3,4,2,1,-1.0d0) 5281 END IF 5282 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_3_2', 5283 &3,MA_ERR) 5284 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5285 & ERRQUIT('eomccsd_density1_5_3_2',4,MA_ERR) 5286 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5287 &eomccsd_density1_5_3_2',5,MA_ERR) 5288 IF ((h5b .lt. h1b)) THEN 5289 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 5290 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h1b_2 - 1 + noab 5291 &* (h5b_2 - 1))))) 5292 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 5293 &,int_mb(k_range+h1b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 5294 &,2,1,4,3,-1.0d0) 5295 END IF 5296 IF ((h1b .le. h5b)) THEN 5297 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 5298 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 5299 &* (h1b_2 - 1))))) 5300 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 5301 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 5302 &,1,2,4,3,1.0d0) 5303 END IF 5304 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_3_2', 5305 &6,MA_ERR) 5306 nsuperp(1) = 1 5307 nsuperp(2) = 1 5308 isuperp = 1 5309 IF (p3b .eq. p4b) THEN 5310 nsuperp(isuperp) = nsuperp(isuperp) + 1 5311 ELSE 5312 isuperp = isuperp + 1 5313 END IF 5314 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 5315 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 5316 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 5317 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5318 &3_2',7,MA_ERR) 5319 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5320 &3_2',8,MA_ERR) 5321 END IF 5322 END IF 5323 END IF 5324 END DO 5325 END DO 5326 END DO 5327 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5328 &eomccsd_density1_5_3_2',9,MA_ERR) 5329 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 5330 &,int_mb(k_range+h7b-1),1,2,-1.0d0/2.0d0) 5331 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 5332 & 1 + noab * (h1b - 1))) 5333 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_3_2', 5334 &10,MA_ERR) 5335 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5336 &3_2',11,MA_ERR) 5337 END IF 5338 END IF 5339 END IF 5340 next = NXTASK(nprocs,1) 5341 END IF 5342 count = count + 1 5343 END DO 5344 END DO 5345 next = NXTASK(-nprocs,1) 5346 call GA_SYNC() 5347 RETURN 5348 END 5349 SUBROUTINE eomccsd_density1_5_4(d_a,k_a_offset,d_b,k_b_offset,d_c, 5350 &k_c_offset) 5351C $Id$ 5352C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5353C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5354C i1 ( p8 h7 )_yxt + = 1 * t ( p8 h7 )_t * i2 ( )_yx 5355 IMPLICIT NONE 5356#include "global.fh" 5357#include "mafdecls.fh" 5358#include "sym.fh" 5359#include "errquit.fh" 5360#include "tce.fh" 5361 INTEGER d_a 5362 INTEGER k_a_offset 5363 INTEGER d_b 5364 INTEGER k_b_offset 5365 INTEGER d_c 5366 INTEGER k_c_offset 5367 INTEGER NXTASK 5368 INTEGER next 5369 INTEGER nprocs 5370 INTEGER count 5371 INTEGER p8b 5372 INTEGER h7b 5373 INTEGER dimc 5374 INTEGER l_c_sort 5375 INTEGER k_c_sort 5376 INTEGER p8b_1 5377 INTEGER h7b_1 5378 INTEGER dim_common 5379 INTEGER dima_sort 5380 INTEGER dima 5381 INTEGER dimb_sort 5382 INTEGER dimb 5383 INTEGER l_a_sort 5384 INTEGER k_a_sort 5385 INTEGER l_a 5386 INTEGER k_a 5387 INTEGER l_b_sort 5388 INTEGER k_b_sort 5389 INTEGER l_b 5390 INTEGER k_b 5391 INTEGER l_c 5392 INTEGER k_c 5393 EXTERNAL NXTASK 5394 nprocs = GA_NNODES() 5395 count = 0 5396 next = NXTASK(nprocs,1) 5397 DO p8b = noab+1,noab+nvab 5398 DO h7b = 1,noab 5399 IF (next.eq.count) THEN 5400 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 5401 &).ne.4)) THEN 5402 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 5403 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 5404 &y,ieor(irrep_x,irrep_t))) THEN 5405 dimc = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 5406 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5407 & ERRQUIT('eomccsd_density1_5_4',0,MA_ERR) 5408 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5409 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 5410 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 5411 &EN 5412 CALL TCE_RESTRICTED_2(p8b,h7b,p8b_1,h7b_1) 5413 dim_common = 1 5414 dima_sort = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 5415 dima = dim_common * dima_sort 5416 dimb_sort = 1 5417 dimb = dim_common * dimb_sort 5418 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5419 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5420 & ERRQUIT('eomccsd_density1_5_4',1,MA_ERR) 5421 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5422 &eomccsd_density1_5_4',2,MA_ERR) 5423 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 5424 & - 1 + noab * (p8b_1 - noab - 1))) 5425 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 5426 &,int_mb(k_range+h7b-1),2,1,1.0d0) 5427 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_4',3, 5428 &MA_ERR) 5429 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5430 & ERRQUIT('eomccsd_density1_5_4',4,MA_ERR) 5431 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5432 &eomccsd_density1_5_4',5,MA_ERR) 5433 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),0) 5434 CALL TCE_SORT_0(dbl_mb(k_b),dbl_mb(k_b_sort),1.0d0) 5435 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_4',6, 5436 &MA_ERR) 5437 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 5438 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 5439 &t),dima_sort) 5440 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5441 &4',7,MA_ERR) 5442 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5443 &4',8,MA_ERR) 5444 END IF 5445 END IF 5446 END IF 5447 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5448 &eomccsd_density1_5_4',9,MA_ERR) 5449 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 5450 &,int_mb(k_range+p8b-1),2,1,1.0d0) 5451 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 5452 & 1 + noab * (p8b - noab - 1))) 5453 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_4',10 5454 &,MA_ERR) 5455 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5456 &4',11,MA_ERR) 5457 END IF 5458 END IF 5459 END IF 5460 next = NXTASK(nprocs,1) 5461 END IF 5462 count = count + 1 5463 END DO 5464 END DO 5465 next = NXTASK(-nprocs,1) 5466 call GA_SYNC() 5467 RETURN 5468 END 5469 SUBROUTINE eomccsd_density1_5_4_1(d_a,k_a_offset,d_b,k_b_offset,d_ 5470 &c,k_c_offset) 5471C $Id$ 5472C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5473C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5474C i2 ( )_yx + = 1 * Sum ( h4 p3 ) * x ( p3 h4 )_x * y ( h4 p3 )_y 5475 IMPLICIT NONE 5476#include "global.fh" 5477#include "mafdecls.fh" 5478#include "sym.fh" 5479#include "errquit.fh" 5480#include "tce.fh" 5481 INTEGER d_a 5482 INTEGER k_a_offset 5483 INTEGER d_b 5484 INTEGER k_b_offset 5485 INTEGER d_c 5486 INTEGER k_c_offset 5487 INTEGER NXTASK 5488 INTEGER next 5489 INTEGER nprocs 5490 INTEGER count 5491 INTEGER dimc 5492 INTEGER l_c_sort 5493 INTEGER k_c_sort 5494 INTEGER p3b 5495 INTEGER h4b 5496 INTEGER p3b_1 5497 INTEGER h4b_1 5498 INTEGER h4b_2 5499 INTEGER p3b_2 5500 INTEGER dim_common 5501 INTEGER dima_sort 5502 INTEGER dima 5503 INTEGER dimb_sort 5504 INTEGER dimb 5505 INTEGER l_a_sort 5506 INTEGER k_a_sort 5507 INTEGER l_a 5508 INTEGER k_a 5509 INTEGER l_b_sort 5510 INTEGER k_b_sort 5511 INTEGER l_b 5512 INTEGER k_b 5513 INTEGER l_c 5514 INTEGER k_c 5515 EXTERNAL NXTASK 5516 nprocs = GA_NNODES() 5517 count = 0 5518 next = NXTASK(nprocs,1) 5519 IF (next.eq.count) THEN 5520 IF (0 .eq. ieor(irrep_y,irrep_x)) THEN 5521 dimc = 1 5522 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5523 & ERRQUIT('eomccsd_density1_5_4_1',0,MA_ERR) 5524 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5525 DO p3b = noab+1,noab+nvab 5526 DO h4b = 1,noab 5527 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN 5528 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_x) TH 5529 &EN 5530 CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1) 5531 CALL TCE_RESTRICTED_2(h4b,p3b,h4b_2,p3b_2) 5532 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) 5533 dima_sort = 1 5534 dima = dim_common * dima_sort 5535 dimb_sort = 1 5536 dimb = dim_common * dimb_sort 5537 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5538 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5539 & ERRQUIT('eomccsd_density1_5_4_1',1,MA_ERR) 5540 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5541 &eomccsd_density1_5_4_1',2,MA_ERR) 5542 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 5543 & - 1 + noab * (p3b_1 - noab - 1))) 5544 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5545 &,int_mb(k_range+h4b-1),2,1,1.0d0) 5546 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_4_1', 5547 &3,MA_ERR) 5548 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5549 & ERRQUIT('eomccsd_density1_5_4_1',4,MA_ERR) 5550 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5551 &eomccsd_density1_5_4_1',5,MA_ERR) 5552 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 5553 & - noab - 1 + nvab * (h4b_2 - 1))) 5554 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 5555 &,int_mb(k_range+p3b-1),1,2,1.0d0) 5556 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_4_1', 5557 &6,MA_ERR) 5558 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 5559 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 5560 &t),dima_sort) 5561 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5562 &4_1',7,MA_ERR) 5563 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5564 &4_1',8,MA_ERR) 5565 END IF 5566 END IF 5567 END IF 5568 END DO 5569 END DO 5570 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5571 &eomccsd_density1_5_4_1',9,MA_ERR) 5572 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 5573 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 5574 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_4_1', 5575 &10,MA_ERR) 5576 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5577 &4_1',11,MA_ERR) 5578 END IF 5579 next = NXTASK(nprocs,1) 5580 END IF 5581 count = count + 1 5582 next = NXTASK(-nprocs,1) 5583 call GA_SYNC() 5584 RETURN 5585 END 5586 SUBROUTINE OFFSET_eomccsd_density1_5_4_1(l_a_offset,k_a_offset,siz 5587 &e) 5588C $Id$ 5589C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5590C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5591C i2 ( )_yx 5592 IMPLICIT NONE 5593#include "global.fh" 5594#include "mafdecls.fh" 5595#include "sym.fh" 5596#include "errquit.fh" 5597#include "tce.fh" 5598 INTEGER l_a_offset 5599 INTEGER k_a_offset 5600 INTEGER size 5601 INTEGER length 5602 INTEGER addr 5603 length = 0 5604 IF (0 .eq. ieor(irrep_y,irrep_x)) THEN 5605 length = length + 1 5606 END IF 5607 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 5608 &set)) CALL ERRQUIT('eomccsd_density1_5_4_1',0,MA_ERR) 5609 int_mb(k_a_offset) = length 5610 addr = 0 5611 size = 0 5612 IF (0 .eq. ieor(irrep_y,irrep_x)) THEN 5613 addr = addr + 1 5614 int_mb(k_a_offset+addr) = 0 5615 int_mb(k_a_offset+length+addr) = size 5616 size = 1 5617 END IF 5618 RETURN 5619 END 5620 SUBROUTINE eomccsd_density1_5_4_2(d_a,k_a_offset,d_b,k_b_offset,d_ 5621 &c,k_c_offset) 5622C $Id$ 5623C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5624C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5625C i2 ( )_yx + = 1/4 * Sum ( h6 h5 p4 p3 ) * x ( p3 p4 h5 h6 )_x * y ( h5 h6 p3 p4 )_y 5626 IMPLICIT NONE 5627#include "global.fh" 5628#include "mafdecls.fh" 5629#include "sym.fh" 5630#include "errquit.fh" 5631#include "tce.fh" 5632 INTEGER d_a 5633 INTEGER k_a_offset 5634 INTEGER d_b 5635 INTEGER k_b_offset 5636 INTEGER d_c 5637 INTEGER k_c_offset 5638 INTEGER NXTASK 5639 INTEGER next 5640 INTEGER nprocs 5641 INTEGER count 5642 INTEGER dimc 5643 INTEGER l_c_sort 5644 INTEGER k_c_sort 5645 INTEGER p3b 5646 INTEGER p4b 5647 INTEGER h5b 5648 INTEGER h6b 5649 INTEGER p3b_1 5650 INTEGER p4b_1 5651 INTEGER h5b_1 5652 INTEGER h6b_1 5653 INTEGER h5b_2 5654 INTEGER h6b_2 5655 INTEGER p3b_2 5656 INTEGER p4b_2 5657 INTEGER dim_common 5658 INTEGER dima_sort 5659 INTEGER dima 5660 INTEGER dimb_sort 5661 INTEGER dimb 5662 INTEGER l_a_sort 5663 INTEGER k_a_sort 5664 INTEGER l_a 5665 INTEGER k_a 5666 INTEGER l_b_sort 5667 INTEGER k_b_sort 5668 INTEGER l_b 5669 INTEGER k_b 5670 INTEGER nsuperp(2) 5671 INTEGER isuperp 5672 INTEGER nsubh(2) 5673 INTEGER isubh 5674 INTEGER l_c 5675 INTEGER k_c 5676 DOUBLE PRECISION FACTORIAL 5677 EXTERNAL NXTASK 5678 EXTERNAL FACTORIAL 5679 nprocs = GA_NNODES() 5680 count = 0 5681 next = NXTASK(nprocs,1) 5682 IF (next.eq.count) THEN 5683 IF (0 .eq. ieor(irrep_y,irrep_x)) THEN 5684 dimc = 1 5685 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5686 & ERRQUIT('eomccsd_density1_5_4_2',0,MA_ERR) 5687 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5688 DO p3b = noab+1,noab+nvab 5689 DO p4b = p3b,noab+nvab 5690 DO h5b = 1,noab 5691 DO h6b = h5b,noab 5692 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 5693 &5b-1)+int_mb(k_spin+h6b-1)) THEN 5694 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 5695 &k_sym+h5b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_x) THEN 5696 CALL TCE_RESTRICTED_4(p3b,p4b,h5b,h6b,p3b_1,p4b_1,h5b_1,h6b_1) 5697 CALL TCE_RESTRICTED_4(h5b,h6b,p3b,p4b,h5b_2,h6b_2,p3b_2,p4b_2) 5698 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m 5699 &b(k_range+h5b-1) * int_mb(k_range+h6b-1) 5700 dima_sort = 1 5701 dima = dim_common * dima_sort 5702 dimb_sort = 1 5703 dimb = dim_common * dimb_sort 5704 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5705 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5706 & ERRQUIT('eomccsd_density1_5_4_2',1,MA_ERR) 5707 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5708 &eomccsd_density1_5_4_2',2,MA_ERR) 5709 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 5710 & - 1 + noab * (h5b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 5711 &1 - noab - 1))))) 5712 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 5713 &,int_mb(k_range+p4b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1) 5714 &,4,3,2,1,1.0d0) 5715 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_4_2', 5716 &3,MA_ERR) 5717 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5718 & ERRQUIT('eomccsd_density1_5_4_2',4,MA_ERR) 5719 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5720 &eomccsd_density1_5_4_2',5,MA_ERR) 5721 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 5722 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab 5723 &* (h5b_2 - 1))))) 5724 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 5725 &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 5726 &,2,1,4,3,1.0d0) 5727 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_4_2', 5728 &6,MA_ERR) 5729 nsuperp(1) = 1 5730 nsuperp(2) = 1 5731 isuperp = 1 5732 IF (p3b .eq. p4b) THEN 5733 nsuperp(isuperp) = nsuperp(isuperp) + 1 5734 ELSE 5735 isuperp = isuperp + 1 5736 END IF 5737 nsubh(1) = 1 5738 nsubh(2) = 1 5739 isubh = 1 5740 IF (h5b .eq. h6b) THEN 5741 nsubh(isubh) = nsubh(isubh) + 1 5742 ELSE 5743 isubh = isubh + 1 5744 END IF 5745 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,4.0d0/FACTORIAL( 5746 &nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsubh(1))/FACTORIAL(ns 5747 &ubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k_b_sort),dim_common,1. 5748 &0d0,dbl_mb(k_c_sort),dima_sort) 5749 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5750 &4_2',7,MA_ERR) 5751 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5752 &4_2',8,MA_ERR) 5753 END IF 5754 END IF 5755 END IF 5756 END DO 5757 END DO 5758 END DO 5759 END DO 5760 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5761 &eomccsd_density1_5_4_2',9,MA_ERR) 5762 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0/4.0d0) 5763 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 5764 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_4_2', 5765 &10,MA_ERR) 5766 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5767 &4_2',11,MA_ERR) 5768 END IF 5769 next = NXTASK(nprocs,1) 5770 END IF 5771 count = count + 1 5772 next = NXTASK(-nprocs,1) 5773 call GA_SYNC() 5774 RETURN 5775 END 5776 SUBROUTINE eomccsd_density1_5_5(d_a,k_a_offset,d_b,k_b_offset,d_c, 5777 &k_c_offset) 5778C $Id$ 5779C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5780C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5781C i1 ( p8 h7 )_ytx + = 1/2 * Sum ( h5 h6 p4 ) * x ( p4 p8 h5 h6 )_x * i2 ( h5 h6 h7 p4 )_yt 5782 IMPLICIT NONE 5783#include "global.fh" 5784#include "mafdecls.fh" 5785#include "sym.fh" 5786#include "errquit.fh" 5787#include "tce.fh" 5788 INTEGER d_a 5789 INTEGER k_a_offset 5790 INTEGER d_b 5791 INTEGER k_b_offset 5792 INTEGER d_c 5793 INTEGER k_c_offset 5794 INTEGER NXTASK 5795 INTEGER next 5796 INTEGER nprocs 5797 INTEGER count 5798 INTEGER p8b 5799 INTEGER h7b 5800 INTEGER dimc 5801 INTEGER l_c_sort 5802 INTEGER k_c_sort 5803 INTEGER p4b 5804 INTEGER h5b 5805 INTEGER h6b 5806 INTEGER p8b_1 5807 INTEGER p4b_1 5808 INTEGER h5b_1 5809 INTEGER h6b_1 5810 INTEGER h5b_2 5811 INTEGER h6b_2 5812 INTEGER h7b_2 5813 INTEGER p4b_2 5814 INTEGER dim_common 5815 INTEGER dima_sort 5816 INTEGER dima 5817 INTEGER dimb_sort 5818 INTEGER dimb 5819 INTEGER l_a_sort 5820 INTEGER k_a_sort 5821 INTEGER l_a 5822 INTEGER k_a 5823 INTEGER l_b_sort 5824 INTEGER k_b_sort 5825 INTEGER l_b 5826 INTEGER k_b 5827 INTEGER nsubh(2) 5828 INTEGER isubh 5829 INTEGER l_c 5830 INTEGER k_c 5831 DOUBLE PRECISION FACTORIAL 5832 EXTERNAL NXTASK 5833 EXTERNAL FACTORIAL 5834 nprocs = GA_NNODES() 5835 count = 0 5836 next = NXTASK(nprocs,1) 5837 DO p8b = noab+1,noab+nvab 5838 DO h7b = 1,noab 5839 IF (next.eq.count) THEN 5840 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 5841 &).ne.4)) THEN 5842 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 5843 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 5844 &y,ieor(irrep_t,irrep_x))) THEN 5845 dimc = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 5846 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 5847 & ERRQUIT('eomccsd_density1_5_5',0,MA_ERR) 5848 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 5849 DO p4b = noab+1,noab+nvab 5850 DO h5b = 1,noab 5851 DO h6b = h5b,noab 5852 IF (int_mb(k_spin+p8b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 5853 &5b-1)+int_mb(k_spin+h6b-1)) THEN 5854 IF (ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 5855 &k_sym+h5b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_x) THEN 5856 CALL TCE_RESTRICTED_4(p8b,p4b,h5b,h6b,p8b_1,p4b_1,h5b_1,h6b_1) 5857 CALL TCE_RESTRICTED_4(h5b,h6b,h7b,p4b,h5b_2,h6b_2,h7b_2,p4b_2) 5858 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h5b-1) * int_m 5859 &b(k_range+h6b-1) 5860 dima_sort = int_mb(k_range+p8b-1) 5861 dima = dim_common * dima_sort 5862 dimb_sort = int_mb(k_range+h7b-1) 5863 dimb = dim_common * dimb_sort 5864 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 5865 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 5866 & ERRQUIT('eomccsd_density1_5_5',1,MA_ERR) 5867 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 5868 &eomccsd_density1_5_5',2,MA_ERR) 5869 IF ((p4b .le. p8b)) THEN 5870 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 5871 & - 1 + noab * (h5b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p4b_ 5872 &1 - noab - 1))))) 5873 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 5874 &,int_mb(k_range+p8b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1) 5875 &,2,4,3,1,1.0d0) 5876 END IF 5877 IF ((p8b .lt. p4b)) THEN 5878 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 5879 & - 1 + noab * (h5b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p8b_ 5880 &1 - noab - 1))))) 5881 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 5882 &,int_mb(k_range+p4b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1) 5883 &,1,4,3,2,-1.0d0) 5884 END IF 5885 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_5',3, 5886 &MA_ERR) 5887 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 5888 & ERRQUIT('eomccsd_density1_5_5',4,MA_ERR) 5889 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 5890 &eomccsd_density1_5_5',5,MA_ERR) 5891 IF ((h7b .le. p4b)) THEN 5892 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 5893 & - noab - 1 + nvab * (h7b_2 - 1 + noab * (h6b_2 - 1 + noab * (h5b_ 5894 &2 - 1))))) 5895 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 5896 &,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),int_mb(k_range+p4b-1) 5897 &,3,2,1,4,1.0d0) 5898 END IF 5899 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_5',6, 5900 &MA_ERR) 5901 nsubh(1) = 1 5902 nsubh(2) = 1 5903 isubh = 1 5904 IF (h5b .eq. h6b) THEN 5905 nsubh(isubh) = nsubh(isubh) + 1 5906 ELSE 5907 isubh = isubh + 1 5908 END IF 5909 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 5910 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 5911 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 5912 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5913 &5',7,MA_ERR) 5914 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5915 &5',8,MA_ERR) 5916 END IF 5917 END IF 5918 END IF 5919 END DO 5920 END DO 5921 END DO 5922 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 5923 &eomccsd_density1_5_5',9,MA_ERR) 5924 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 5925 &,int_mb(k_range+p8b-1),2,1,1.0d0/2.0d0) 5926 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 5927 & 1 + noab * (p8b - noab - 1))) 5928 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_5',10 5929 &,MA_ERR) 5930 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 5931 &5',11,MA_ERR) 5932 END IF 5933 END IF 5934 END IF 5935 next = NXTASK(nprocs,1) 5936 END IF 5937 count = count + 1 5938 END DO 5939 END DO 5940 next = NXTASK(-nprocs,1) 5941 call GA_SYNC() 5942 RETURN 5943 END 5944 SUBROUTINE eomccsd_density1_5_5_1(d_a,k_a_offset,d_b,k_b_offset,d_ 5945 &c,k_c_offset) 5946C $Id$ 5947C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5948C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5949C i2 ( h5 h6 h7 p4 )_yt + = 1 * Sum ( p3 ) * t ( p3 h7 )_t * y ( h5 h6 p3 p4 )_y 5950 IMPLICIT NONE 5951#include "global.fh" 5952#include "mafdecls.fh" 5953#include "sym.fh" 5954#include "errquit.fh" 5955#include "tce.fh" 5956 INTEGER d_a 5957 INTEGER k_a_offset 5958 INTEGER d_b 5959 INTEGER k_b_offset 5960 INTEGER d_c 5961 INTEGER k_c_offset 5962 INTEGER NXTASK 5963 INTEGER next 5964 INTEGER nprocs 5965 INTEGER count 5966 INTEGER h5b 5967 INTEGER h6b 5968 INTEGER h7b 5969 INTEGER p4b 5970 INTEGER dimc 5971 INTEGER l_c_sort 5972 INTEGER k_c_sort 5973 INTEGER p3b 5974 INTEGER p3b_1 5975 INTEGER h7b_1 5976 INTEGER h5b_2 5977 INTEGER h6b_2 5978 INTEGER p4b_2 5979 INTEGER p3b_2 5980 INTEGER dim_common 5981 INTEGER dima_sort 5982 INTEGER dima 5983 INTEGER dimb_sort 5984 INTEGER dimb 5985 INTEGER l_a_sort 5986 INTEGER k_a_sort 5987 INTEGER l_a 5988 INTEGER k_a 5989 INTEGER l_b_sort 5990 INTEGER k_b_sort 5991 INTEGER l_b 5992 INTEGER k_b 5993 INTEGER l_c 5994 INTEGER k_c 5995 EXTERNAL NXTASK 5996 nprocs = GA_NNODES() 5997 count = 0 5998 next = NXTASK(nprocs,1) 5999 DO h5b = 1,noab 6000 DO h6b = h5b,noab 6001 DO h7b = 1,noab 6002 DO p4b = noab+1,noab+nvab 6003 IF (next.eq.count) THEN 6004 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 6005 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+p4b-1).ne.8)) THEN 6006 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 6007 &7b-1)+int_mb(k_spin+p4b-1)) THEN 6008 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 6009 &k_sym+h7b-1),int_mb(k_sym+p4b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 6010 &EN 6011 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 6012 &nge+h7b-1) * int_mb(k_range+p4b-1) 6013 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6014 & ERRQUIT('eomccsd_density1_5_5_1',0,MA_ERR) 6015 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6016 DO p3b = noab+1,noab+nvab 6017 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h7b-1)) THEN 6018 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 6019 &EN 6020 CALL TCE_RESTRICTED_2(p3b,h7b,p3b_1,h7b_1) 6021 CALL TCE_RESTRICTED_4(h5b,h6b,p4b,p3b,h5b_2,h6b_2,p4b_2,p3b_2) 6022 dim_common = int_mb(k_range+p3b-1) 6023 dima_sort = int_mb(k_range+h7b-1) 6024 dima = dim_common * dima_sort 6025 dimb_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb 6026 &(k_range+p4b-1) 6027 dimb = dim_common * dimb_sort 6028 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6029 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6030 & ERRQUIT('eomccsd_density1_5_5_1',1,MA_ERR) 6031 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6032 &eomccsd_density1_5_5_1',2,MA_ERR) 6033 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 6034 & - 1 + noab * (p3b_1 - noab - 1))) 6035 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 6036 &,int_mb(k_range+h7b-1),2,1,1.0d0) 6037 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_5_1', 6038 &3,MA_ERR) 6039 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6040 & ERRQUIT('eomccsd_density1_5_5_1',4,MA_ERR) 6041 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6042 &eomccsd_density1_5_5_1',5,MA_ERR) 6043 IF ((p3b .le. p4b)) THEN 6044 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 6045 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab 6046 &* (h5b_2 - 1))))) 6047 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 6048 &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 6049 &,4,2,1,3,1.0d0) 6050 END IF 6051 IF ((p4b .lt. p3b)) THEN 6052 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 6053 & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab 6054 &* (h5b_2 - 1))))) 6055 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 6056 &,int_mb(k_range+h6b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1) 6057 &,3,2,1,4,-1.0d0) 6058 END IF 6059 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_5_1', 6060 &6,MA_ERR) 6061 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6062 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6063 &t),dima_sort) 6064 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6065 &5_1',7,MA_ERR) 6066 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6067 &5_1',8,MA_ERR) 6068 END IF 6069 END IF 6070 END IF 6071 END DO 6072 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6073 &eomccsd_density1_5_5_1',9,MA_ERR) 6074 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1) 6075 &,int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+h7b-1) 6076 &,3,2,4,1,1.0d0) 6077 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p4b - 6078 & noab - 1 + nvab * (h7b - 1 + noab * (h6b - 1 + noab * (h5b - 1))) 6079 &)) 6080 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_5_1', 6081 &10,MA_ERR) 6082 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6083 &5_1',11,MA_ERR) 6084 END IF 6085 END IF 6086 END IF 6087 next = NXTASK(nprocs,1) 6088 END IF 6089 count = count + 1 6090 END DO 6091 END DO 6092 END DO 6093 END DO 6094 next = NXTASK(-nprocs,1) 6095 call GA_SYNC() 6096 RETURN 6097 END 6098 SUBROUTINE OFFSET_eomccsd_density1_5_5_1(l_a_offset,k_a_offset,siz 6099 &e) 6100C $Id$ 6101C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6102C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6103C i2 ( h5 h6 h7 p4 )_yt 6104 IMPLICIT NONE 6105#include "global.fh" 6106#include "mafdecls.fh" 6107#include "sym.fh" 6108#include "errquit.fh" 6109#include "tce.fh" 6110 INTEGER l_a_offset 6111 INTEGER k_a_offset 6112 INTEGER size 6113 INTEGER length 6114 INTEGER addr 6115 INTEGER h5b 6116 INTEGER h6b 6117 INTEGER h7b 6118 INTEGER p4b 6119 length = 0 6120 DO h5b = 1,noab 6121 DO h6b = h5b,noab 6122 DO h7b = 1,noab 6123 DO p4b = noab+1,noab+nvab 6124 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 6125 &7b-1)+int_mb(k_spin+p4b-1)) THEN 6126 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 6127 &k_sym+h7b-1),int_mb(k_sym+p4b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 6128 &EN 6129 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 6130 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+p4b-1).ne.8)) THEN 6131 length = length + 1 6132 END IF 6133 END IF 6134 END IF 6135 END DO 6136 END DO 6137 END DO 6138 END DO 6139 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 6140 &set)) CALL ERRQUIT('eomccsd_density1_5_5_1',0,MA_ERR) 6141 int_mb(k_a_offset) = length 6142 addr = 0 6143 size = 0 6144 DO h5b = 1,noab 6145 DO h6b = h5b,noab 6146 DO h7b = 1,noab 6147 DO p4b = noab+1,noab+nvab 6148 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 6149 &7b-1)+int_mb(k_spin+p4b-1)) THEN 6150 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 6151 &k_sym+h7b-1),int_mb(k_sym+p4b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 6152 &EN 6153 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 6154 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+p4b-1).ne.8)) THEN 6155 addr = addr + 1 6156 int_mb(k_a_offset+addr) = p4b - noab - 1 + nvab * (h7b - 1 + noab 6157 &* (h6b - 1 + noab * (h5b - 1))) 6158 int_mb(k_a_offset+length+addr) = size 6159 size = size + int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_ 6160 &mb(k_range+h7b-1) * int_mb(k_range+p4b-1) 6161 END IF 6162 END IF 6163 END IF 6164 END DO 6165 END DO 6166 END DO 6167 END DO 6168 RETURN 6169 END 6170 SUBROUTINE eomccsd_density1_5_6(d_a,k_a_offset,d_b,k_b_offset,d_c, 6171 &k_c_offset) 6172C $Id$ 6173C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6174C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6175C i1 ( p8 h7 )_yxt + = 1 * Sum ( h4 p3 ) * t ( p3 p8 h4 h7 )_t * i2 ( h4 p3 )_yx 6176 IMPLICIT NONE 6177#include "global.fh" 6178#include "mafdecls.fh" 6179#include "sym.fh" 6180#include "errquit.fh" 6181#include "tce.fh" 6182 INTEGER d_a 6183 INTEGER k_a_offset 6184 INTEGER d_b 6185 INTEGER k_b_offset 6186 INTEGER d_c 6187 INTEGER k_c_offset 6188 INTEGER NXTASK 6189 INTEGER next 6190 INTEGER nprocs 6191 INTEGER count 6192 INTEGER p8b 6193 INTEGER h7b 6194 INTEGER dimc 6195 INTEGER l_c_sort 6196 INTEGER k_c_sort 6197 INTEGER p3b 6198 INTEGER h4b 6199 INTEGER p8b_1 6200 INTEGER p3b_1 6201 INTEGER h7b_1 6202 INTEGER h4b_1 6203 INTEGER h4b_2 6204 INTEGER p3b_2 6205 INTEGER dim_common 6206 INTEGER dima_sort 6207 INTEGER dima 6208 INTEGER dimb_sort 6209 INTEGER dimb 6210 INTEGER l_a_sort 6211 INTEGER k_a_sort 6212 INTEGER l_a 6213 INTEGER k_a 6214 INTEGER l_b_sort 6215 INTEGER k_b_sort 6216 INTEGER l_b 6217 INTEGER k_b 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 p8b = noab+1,noab+nvab 6225 DO h7b = 1,noab 6226 IF (next.eq.count) THEN 6227 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 6228 &).ne.4)) THEN 6229 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 6230 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 6231 &y,ieor(irrep_x,irrep_t))) THEN 6232 dimc = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 6233 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6234 & ERRQUIT('eomccsd_density1_5_6',0,MA_ERR) 6235 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6236 DO p3b = noab+1,noab+nvab 6237 DO h4b = 1,noab 6238 IF (int_mb(k_spin+p8b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 6239 &7b-1)+int_mb(k_spin+h4b-1)) THEN 6240 IF (ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 6241 &k_sym+h7b-1),int_mb(k_sym+h4b-1)))) .eq. irrep_t) THEN 6242 CALL TCE_RESTRICTED_4(p8b,p3b,h7b,h4b,p8b_1,p3b_1,h7b_1,h4b_1) 6243 CALL TCE_RESTRICTED_2(h4b,p3b,h4b_2,p3b_2) 6244 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) 6245 dima_sort = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 6246 dima = dim_common * dima_sort 6247 dimb_sort = 1 6248 dimb = dim_common * dimb_sort 6249 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6250 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6251 & ERRQUIT('eomccsd_density1_5_6',1,MA_ERR) 6252 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6253 &eomccsd_density1_5_6',2,MA_ERR) 6254 IF ((p3b .le. p8b) .and. (h4b .le. h7b)) THEN 6255 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 6256 & - 1 + noab * (h4b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 6257 &1 - noab - 1))))) 6258 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 6259 &,int_mb(k_range+p8b-1),int_mb(k_range+h4b-1),int_mb(k_range+h7b-1) 6260 &,4,2,3,1,1.0d0) 6261 END IF 6262 IF ((p3b .le. p8b) .and. (h7b .lt. h4b)) THEN 6263 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 6264 & - 1 + noab * (h7b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 6265 &1 - noab - 1))))) 6266 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 6267 &,int_mb(k_range+p8b-1),int_mb(k_range+h7b-1),int_mb(k_range+h4b-1) 6268 &,3,2,4,1,-1.0d0) 6269 END IF 6270 IF ((p8b .lt. p3b) .and. (h4b .le. h7b)) THEN 6271 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 6272 & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 6273 &1 - noab - 1))))) 6274 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 6275 &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h7b-1) 6276 &,4,1,3,2,-1.0d0) 6277 END IF 6278 IF ((p8b .lt. p3b) .and. (h7b .lt. h4b)) THEN 6279 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 6280 & - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 6281 &1 - noab - 1))))) 6282 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 6283 &,int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),int_mb(k_range+h4b-1) 6284 &,3,1,4,2,1.0d0) 6285 END IF 6286 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_6',3, 6287 &MA_ERR) 6288 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6289 & ERRQUIT('eomccsd_density1_5_6',4,MA_ERR) 6290 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6291 &eomccsd_density1_5_6',5,MA_ERR) 6292 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 6293 & - noab - 1 + nvab * (h4b_2 - 1))) 6294 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 6295 &,int_mb(k_range+p3b-1),1,2,1.0d0) 6296 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_6',6, 6297 &MA_ERR) 6298 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6299 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6300 &t),dima_sort) 6301 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6302 &6',7,MA_ERR) 6303 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6304 &6',8,MA_ERR) 6305 END IF 6306 END IF 6307 END IF 6308 END DO 6309 END DO 6310 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6311 &eomccsd_density1_5_6',9,MA_ERR) 6312 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 6313 &,int_mb(k_range+p8b-1),2,1,1.0d0) 6314 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 6315 & 1 + noab * (p8b - noab - 1))) 6316 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_6',10 6317 &,MA_ERR) 6318 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6319 &6',11,MA_ERR) 6320 END IF 6321 END IF 6322 END IF 6323 next = NXTASK(nprocs,1) 6324 END IF 6325 count = count + 1 6326 END DO 6327 END DO 6328 next = NXTASK(-nprocs,1) 6329 call GA_SYNC() 6330 RETURN 6331 END 6332 SUBROUTINE eomccsd_density1_5_6_1(d_a,k_a_offset,d_b,k_b_offset,d_ 6333 &c,k_c_offset) 6334C $Id$ 6335C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6336C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6337C i2 ( h4 p3 )_yx + = 1 * x ( )_x * y ( h4 p3 )_y 6338 IMPLICIT NONE 6339#include "global.fh" 6340#include "mafdecls.fh" 6341#include "sym.fh" 6342#include "errquit.fh" 6343#include "tce.fh" 6344 INTEGER d_a 6345 INTEGER k_a_offset 6346 INTEGER d_b 6347 INTEGER k_b_offset 6348 INTEGER d_c 6349 INTEGER k_c_offset 6350 INTEGER NXTASK 6351 INTEGER next 6352 INTEGER nprocs 6353 INTEGER count 6354 INTEGER h4b 6355 INTEGER p3b 6356 INTEGER dimc 6357 INTEGER l_c_sort 6358 INTEGER k_c_sort 6359 INTEGER h4b_2 6360 INTEGER p3b_2 6361 INTEGER dim_common 6362 INTEGER dima_sort 6363 INTEGER dima 6364 INTEGER dimb_sort 6365 INTEGER dimb 6366 INTEGER l_a_sort 6367 INTEGER k_a_sort 6368 INTEGER l_a 6369 INTEGER k_a 6370 INTEGER l_b_sort 6371 INTEGER k_b_sort 6372 INTEGER l_b 6373 INTEGER k_b 6374 INTEGER l_c 6375 INTEGER k_c 6376 EXTERNAL NXTASK 6377 nprocs = GA_NNODES() 6378 count = 0 6379 next = NXTASK(nprocs,1) 6380 DO h4b = 1,noab 6381 DO p3b = noab+1,noab+nvab 6382 IF (next.eq.count) THEN 6383 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1 6384 &).ne.4)) THEN 6385 IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p3b-1)) THEN 6386 IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 6387 &y,irrep_x)) THEN 6388 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1) 6389 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6390 & ERRQUIT('eomccsd_density1_5_6_1',0,MA_ERR) 6391 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6392 IF (0 .eq. irrep_x) THEN 6393 CALL TCE_RESTRICTED_2(h4b,p3b,h4b_2,p3b_2) 6394 dim_common = 1 6395 dima_sort = 1 6396 dima = dim_common * dima_sort 6397 dimb_sort = int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1) 6398 dimb = dim_common * dimb_sort 6399 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6400 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6401 & ERRQUIT('eomccsd_density1_5_6_1',1,MA_ERR) 6402 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6403 &eomccsd_density1_5_6_1',2,MA_ERR) 6404 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),0) 6405 CALL TCE_SORT_0(dbl_mb(k_a),dbl_mb(k_a_sort),1.0d0) 6406 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_6_1', 6407 &3,MA_ERR) 6408 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6409 & ERRQUIT('eomccsd_density1_5_6_1',4,MA_ERR) 6410 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6411 &eomccsd_density1_5_6_1',5,MA_ERR) 6412 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 6413 & - noab - 1 + nvab * (h4b_2 - 1))) 6414 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 6415 &,int_mb(k_range+p3b-1),2,1,1.0d0) 6416 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_6_1', 6417 &6,MA_ERR) 6418 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6419 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6420 &t),dima_sort) 6421 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6422 &6_1',7,MA_ERR) 6423 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6424 &6_1',8,MA_ERR) 6425 END IF 6426 END IF 6427 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6428 &eomccsd_density1_5_6_1',9,MA_ERR) 6429 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 6430 &,int_mb(k_range+h4b-1),2,1,1.0d0) 6431 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 6432 & noab - 1 + nvab * (h4b - 1))) 6433 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_6_1', 6434 &10,MA_ERR) 6435 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6436 &6_1',11,MA_ERR) 6437 END IF 6438 END IF 6439 END IF 6440 next = NXTASK(nprocs,1) 6441 END IF 6442 count = count + 1 6443 END DO 6444 END DO 6445 next = NXTASK(-nprocs,1) 6446 call GA_SYNC() 6447 RETURN 6448 END 6449 SUBROUTINE OFFSET_eomccsd_density1_5_6_1(l_a_offset,k_a_offset,siz 6450 &e) 6451C $Id$ 6452C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6453C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6454C i2 ( h4 p3 )_yx 6455 IMPLICIT NONE 6456#include "global.fh" 6457#include "mafdecls.fh" 6458#include "sym.fh" 6459#include "errquit.fh" 6460#include "tce.fh" 6461 INTEGER l_a_offset 6462 INTEGER k_a_offset 6463 INTEGER size 6464 INTEGER length 6465 INTEGER addr 6466 INTEGER h4b 6467 INTEGER p3b 6468 length = 0 6469 DO h4b = 1,noab 6470 DO p3b = noab+1,noab+nvab 6471 IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p3b-1)) THEN 6472 IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 6473 &y,irrep_x)) THEN 6474 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1 6475 &).ne.4)) THEN 6476 length = length + 1 6477 END IF 6478 END IF 6479 END IF 6480 END DO 6481 END DO 6482 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 6483 &set)) CALL ERRQUIT('eomccsd_density1_5_6_1',0,MA_ERR) 6484 int_mb(k_a_offset) = length 6485 addr = 0 6486 size = 0 6487 DO h4b = 1,noab 6488 DO p3b = noab+1,noab+nvab 6489 IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p3b-1)) THEN 6490 IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 6491 &y,irrep_x)) THEN 6492 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1 6493 &).ne.4)) THEN 6494 addr = addr + 1 6495 int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h4b - 1) 6496 int_mb(k_a_offset+length+addr) = size 6497 size = size + int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1) 6498 END IF 6499 END IF 6500 END IF 6501 END DO 6502 END DO 6503 RETURN 6504 END 6505 SUBROUTINE eomccsd_density1_5_6_2(d_a,k_a_offset,d_b,k_b_offset,d_ 6506 &c,k_c_offset) 6507C $Id$ 6508C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6509C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6510C i2 ( h4 p3 )_yx + = 1 * Sum ( h6 p5 ) * x ( p5 h6 )_x * y ( h4 h6 p3 p5 )_y 6511 IMPLICIT NONE 6512#include "global.fh" 6513#include "mafdecls.fh" 6514#include "sym.fh" 6515#include "errquit.fh" 6516#include "tce.fh" 6517 INTEGER d_a 6518 INTEGER k_a_offset 6519 INTEGER d_b 6520 INTEGER k_b_offset 6521 INTEGER d_c 6522 INTEGER k_c_offset 6523 INTEGER NXTASK 6524 INTEGER next 6525 INTEGER nprocs 6526 INTEGER count 6527 INTEGER h4b 6528 INTEGER p3b 6529 INTEGER dimc 6530 INTEGER l_c_sort 6531 INTEGER k_c_sort 6532 INTEGER p5b 6533 INTEGER h6b 6534 INTEGER p5b_1 6535 INTEGER h6b_1 6536 INTEGER h4b_2 6537 INTEGER h6b_2 6538 INTEGER p3b_2 6539 INTEGER p5b_2 6540 INTEGER dim_common 6541 INTEGER dima_sort 6542 INTEGER dima 6543 INTEGER dimb_sort 6544 INTEGER dimb 6545 INTEGER l_a_sort 6546 INTEGER k_a_sort 6547 INTEGER l_a 6548 INTEGER k_a 6549 INTEGER l_b_sort 6550 INTEGER k_b_sort 6551 INTEGER l_b 6552 INTEGER k_b 6553 INTEGER l_c 6554 INTEGER k_c 6555 EXTERNAL NXTASK 6556 nprocs = GA_NNODES() 6557 count = 0 6558 next = NXTASK(nprocs,1) 6559 DO h4b = 1,noab 6560 DO p3b = noab+1,noab+nvab 6561 IF (next.eq.count) THEN 6562 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1 6563 &).ne.4)) THEN 6564 IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p3b-1)) THEN 6565 IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_ 6566 &y,irrep_x)) THEN 6567 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1) 6568 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6569 & ERRQUIT('eomccsd_density1_5_6_2',0,MA_ERR) 6570 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6571 DO p5b = noab+1,noab+nvab 6572 DO h6b = 1,noab 6573 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h6b-1)) THEN 6574 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h6b-1)) .eq. irrep_x) TH 6575 &EN 6576 CALL TCE_RESTRICTED_2(p5b,h6b,p5b_1,h6b_1) 6577 CALL TCE_RESTRICTED_4(h4b,h6b,p3b,p5b,h4b_2,h6b_2,p3b_2,p5b_2) 6578 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) 6579 dima_sort = 1 6580 dima = dim_common * dima_sort 6581 dimb_sort = int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1) 6582 dimb = dim_common * dimb_sort 6583 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6584 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6585 & ERRQUIT('eomccsd_density1_5_6_2',1,MA_ERR) 6586 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6587 &eomccsd_density1_5_6_2',2,MA_ERR) 6588 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 6589 & - 1 + noab * (p5b_1 - noab - 1))) 6590 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 6591 &,int_mb(k_range+h6b-1),2,1,1.0d0) 6592 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_6_2', 6593 &3,MA_ERR) 6594 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6595 & ERRQUIT('eomccsd_density1_5_6_2',4,MA_ERR) 6596 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6597 &eomccsd_density1_5_6_2',5,MA_ERR) 6598 IF ((h6b .lt. h4b) .and. (p5b .lt. p3b)) THEN 6599 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 6600 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h4b_2 - 1 + noab 6601 &* (h6b_2 - 1))))) 6602 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 6603 &,int_mb(k_range+h4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1) 6604 &,4,2,1,3,1.0d0) 6605 END IF 6606 IF ((h6b .lt. h4b) .and. (p3b .le. p5b)) THEN 6607 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 6608 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h4b_2 - 1 + noab 6609 &* (h6b_2 - 1))))) 6610 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 6611 &,int_mb(k_range+h4b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1) 6612 &,3,2,1,4,-1.0d0) 6613 END IF 6614 IF ((h4b .le. h6b) .and. (p5b .lt. p3b)) THEN 6615 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 6616 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab 6617 &* (h4b_2 - 1))))) 6618 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 6619 &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1) 6620 &,4,1,2,3,-1.0d0) 6621 END IF 6622 IF ((h4b .le. h6b) .and. (p3b .le. p5b)) THEN 6623 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 6624 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab 6625 &* (h4b_2 - 1))))) 6626 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 6627 &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1) 6628 &,3,1,2,4,1.0d0) 6629 END IF 6630 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_6_2', 6631 &6,MA_ERR) 6632 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6633 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6634 &t),dima_sort) 6635 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6636 &6_2',7,MA_ERR) 6637 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6638 &6_2',8,MA_ERR) 6639 END IF 6640 END IF 6641 END IF 6642 END DO 6643 END DO 6644 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6645 &eomccsd_density1_5_6_2',9,MA_ERR) 6646 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 6647 &,int_mb(k_range+h4b-1),2,1,1.0d0) 6648 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 6649 & noab - 1 + nvab * (h4b - 1))) 6650 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_6_2', 6651 &10,MA_ERR) 6652 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6653 &6_2',11,MA_ERR) 6654 END IF 6655 END IF 6656 END IF 6657 next = NXTASK(nprocs,1) 6658 END IF 6659 count = count + 1 6660 END DO 6661 END DO 6662 next = NXTASK(-nprocs,1) 6663 call GA_SYNC() 6664 RETURN 6665 END 6666 SUBROUTINE eomccsd_density1_5_7(d_a,k_a_offset,d_b,k_b_offset,d_c, 6667 &k_c_offset) 6668C $Id$ 6669C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6670C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6671C i1 ( p8 h7 )_yxt + = -1/2 * Sum ( h4 h5 p3 ) * t ( p3 p8 h4 h5 )_t * i2 ( h4 h5 h7 p3 )_yx 6672 IMPLICIT NONE 6673#include "global.fh" 6674#include "mafdecls.fh" 6675#include "sym.fh" 6676#include "errquit.fh" 6677#include "tce.fh" 6678 INTEGER d_a 6679 INTEGER k_a_offset 6680 INTEGER d_b 6681 INTEGER k_b_offset 6682 INTEGER d_c 6683 INTEGER k_c_offset 6684 INTEGER NXTASK 6685 INTEGER next 6686 INTEGER nprocs 6687 INTEGER count 6688 INTEGER p8b 6689 INTEGER h7b 6690 INTEGER dimc 6691 INTEGER l_c_sort 6692 INTEGER k_c_sort 6693 INTEGER p3b 6694 INTEGER h4b 6695 INTEGER h5b 6696 INTEGER p8b_1 6697 INTEGER p3b_1 6698 INTEGER h4b_1 6699 INTEGER h5b_1 6700 INTEGER h4b_2 6701 INTEGER h5b_2 6702 INTEGER h7b_2 6703 INTEGER p3b_2 6704 INTEGER dim_common 6705 INTEGER dima_sort 6706 INTEGER dima 6707 INTEGER dimb_sort 6708 INTEGER dimb 6709 INTEGER l_a_sort 6710 INTEGER k_a_sort 6711 INTEGER l_a 6712 INTEGER k_a 6713 INTEGER l_b_sort 6714 INTEGER k_b_sort 6715 INTEGER l_b 6716 INTEGER k_b 6717 INTEGER nsubh(2) 6718 INTEGER isubh 6719 INTEGER l_c 6720 INTEGER k_c 6721 DOUBLE PRECISION FACTORIAL 6722 EXTERNAL NXTASK 6723 EXTERNAL FACTORIAL 6724 nprocs = GA_NNODES() 6725 count = 0 6726 next = NXTASK(nprocs,1) 6727 DO p8b = noab+1,noab+nvab 6728 DO h7b = 1,noab 6729 IF (next.eq.count) THEN 6730 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 6731 &).ne.4)) THEN 6732 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 6733 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 6734 &y,ieor(irrep_x,irrep_t))) THEN 6735 dimc = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 6736 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6737 & ERRQUIT('eomccsd_density1_5_7',0,MA_ERR) 6738 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6739 DO p3b = noab+1,noab+nvab 6740 DO h4b = 1,noab 6741 DO h5b = h4b,noab 6742 IF (int_mb(k_spin+p8b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 6743 &4b-1)+int_mb(k_spin+h5b-1)) THEN 6744 IF (ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 6745 &k_sym+h4b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN 6746 CALL TCE_RESTRICTED_4(p8b,p3b,h4b,h5b,p8b_1,p3b_1,h4b_1,h5b_1) 6747 CALL TCE_RESTRICTED_4(h4b,h5b,h7b,p3b,h4b_2,h5b_2,h7b_2,p3b_2) 6748 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) * int_m 6749 &b(k_range+h5b-1) 6750 dima_sort = int_mb(k_range+p8b-1) 6751 dima = dim_common * dima_sort 6752 dimb_sort = int_mb(k_range+h7b-1) 6753 dimb = dim_common * dimb_sort 6754 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6755 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6756 & ERRQUIT('eomccsd_density1_5_7',1,MA_ERR) 6757 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6758 &eomccsd_density1_5_7',2,MA_ERR) 6759 IF ((p3b .le. p8b)) THEN 6760 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 6761 & - 1 + noab * (h4b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 6762 &1 - noab - 1))))) 6763 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 6764 &,int_mb(k_range+p8b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1) 6765 &,2,4,3,1,1.0d0) 6766 END IF 6767 IF ((p8b .lt. p3b)) THEN 6768 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 6769 & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 6770 &1 - noab - 1))))) 6771 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 6772 &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1) 6773 &,1,4,3,2,-1.0d0) 6774 END IF 6775 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_7',3, 6776 &MA_ERR) 6777 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6778 & ERRQUIT('eomccsd_density1_5_7',4,MA_ERR) 6779 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6780 &eomccsd_density1_5_7',5,MA_ERR) 6781 IF ((h7b .le. p3b)) THEN 6782 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 6783 & - noab - 1 + nvab * (h7b_2 - 1 + noab * (h5b_2 - 1 + noab * (h4b_ 6784 &2 - 1))))) 6785 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 6786 &,int_mb(k_range+h5b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1) 6787 &,3,2,1,4,1.0d0) 6788 END IF 6789 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_7',6, 6790 &MA_ERR) 6791 nsubh(1) = 1 6792 nsubh(2) = 1 6793 isubh = 1 6794 IF (h4b .eq. h5b) THEN 6795 nsubh(isubh) = nsubh(isubh) + 1 6796 ELSE 6797 isubh = isubh + 1 6798 END IF 6799 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 6800 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 6801 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 6802 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6803 &7',7,MA_ERR) 6804 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6805 &7',8,MA_ERR) 6806 END IF 6807 END IF 6808 END IF 6809 END DO 6810 END DO 6811 END DO 6812 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6813 &eomccsd_density1_5_7',9,MA_ERR) 6814 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 6815 &,int_mb(k_range+p8b-1),2,1,-1.0d0/2.0d0) 6816 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 6817 & 1 + noab * (p8b - noab - 1))) 6818 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_7',10 6819 &,MA_ERR) 6820 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6821 &7',11,MA_ERR) 6822 END IF 6823 END IF 6824 END IF 6825 next = NXTASK(nprocs,1) 6826 END IF 6827 count = count + 1 6828 END DO 6829 END DO 6830 next = NXTASK(-nprocs,1) 6831 call GA_SYNC() 6832 RETURN 6833 END 6834 SUBROUTINE eomccsd_density1_5_7_1(d_a,k_a_offset,d_b,k_b_offset,d_ 6835 &c,k_c_offset) 6836C $Id$ 6837C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6838C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6839C i2 ( h4 h5 h7 p3 )_yx + = 1 * Sum ( p6 ) * x ( p6 h7 )_x * y ( h4 h5 p3 p6 )_y 6840 IMPLICIT NONE 6841#include "global.fh" 6842#include "mafdecls.fh" 6843#include "sym.fh" 6844#include "errquit.fh" 6845#include "tce.fh" 6846 INTEGER d_a 6847 INTEGER k_a_offset 6848 INTEGER d_b 6849 INTEGER k_b_offset 6850 INTEGER d_c 6851 INTEGER k_c_offset 6852 INTEGER NXTASK 6853 INTEGER next 6854 INTEGER nprocs 6855 INTEGER count 6856 INTEGER h4b 6857 INTEGER h5b 6858 INTEGER h7b 6859 INTEGER p3b 6860 INTEGER dimc 6861 INTEGER l_c_sort 6862 INTEGER k_c_sort 6863 INTEGER p6b 6864 INTEGER p6b_1 6865 INTEGER h7b_1 6866 INTEGER h4b_2 6867 INTEGER h5b_2 6868 INTEGER p3b_2 6869 INTEGER p6b_2 6870 INTEGER dim_common 6871 INTEGER dima_sort 6872 INTEGER dima 6873 INTEGER dimb_sort 6874 INTEGER dimb 6875 INTEGER l_a_sort 6876 INTEGER k_a_sort 6877 INTEGER l_a 6878 INTEGER k_a 6879 INTEGER l_b_sort 6880 INTEGER k_b_sort 6881 INTEGER l_b 6882 INTEGER k_b 6883 INTEGER l_c 6884 INTEGER k_c 6885 EXTERNAL NXTASK 6886 nprocs = GA_NNODES() 6887 count = 0 6888 next = NXTASK(nprocs,1) 6889 DO h4b = 1,noab 6890 DO h5b = h4b,noab 6891 DO h7b = 1,noab 6892 DO p3b = noab+1,noab+nvab 6893 IF (next.eq.count) THEN 6894 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 6895 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN 6896 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h 6897 &7b-1)+int_mb(k_spin+p3b-1)) THEN 6898 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 6899 &k_sym+h7b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_y,irrep_x)) TH 6900 &EN 6901 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra 6902 &nge+h7b-1) * int_mb(k_range+p3b-1) 6903 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 6904 & ERRQUIT('eomccsd_density1_5_7_1',0,MA_ERR) 6905 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 6906 DO p6b = noab+1,noab+nvab 6907 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN 6908 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_x) TH 6909 &EN 6910 CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1) 6911 CALL TCE_RESTRICTED_4(h4b,h5b,p3b,p6b,h4b_2,h5b_2,p3b_2,p6b_2) 6912 dim_common = int_mb(k_range+p6b-1) 6913 dima_sort = int_mb(k_range+h7b-1) 6914 dima = dim_common * dima_sort 6915 dimb_sort = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb 6916 &(k_range+p3b-1) 6917 dimb = dim_common * dimb_sort 6918 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 6919 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 6920 & ERRQUIT('eomccsd_density1_5_7_1',1,MA_ERR) 6921 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 6922 &eomccsd_density1_5_7_1',2,MA_ERR) 6923 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 6924 & - 1 + noab * (p6b_1 - noab - 1))) 6925 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 6926 &,int_mb(k_range+h7b-1),2,1,1.0d0) 6927 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_7_1', 6928 &3,MA_ERR) 6929 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 6930 & ERRQUIT('eomccsd_density1_5_7_1',4,MA_ERR) 6931 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 6932 &eomccsd_density1_5_7_1',5,MA_ERR) 6933 IF ((p6b .lt. p3b)) THEN 6934 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 6935 & - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 6936 &* (h4b_2 - 1))))) 6937 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 6938 &,int_mb(k_range+h5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1) 6939 &,4,2,1,3,-1.0d0) 6940 END IF 6941 IF ((p3b .le. p6b)) THEN 6942 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 6943 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 6944 &* (h4b_2 - 1))))) 6945 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 6946 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1) 6947 &,3,2,1,4,1.0d0) 6948 END IF 6949 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_7_1', 6950 &6,MA_ERR) 6951 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 6952 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 6953 &t),dima_sort) 6954 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6955 &7_1',7,MA_ERR) 6956 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6957 &7_1',8,MA_ERR) 6958 END IF 6959 END IF 6960 END IF 6961 END DO 6962 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 6963 &eomccsd_density1_5_7_1',9,MA_ERR) 6964 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 6965 &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),int_mb(k_range+h7b-1) 6966 &,3,2,4,1,1.0d0) 6967 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 6968 & noab - 1 + nvab * (h7b - 1 + noab * (h5b - 1 + noab * (h4b - 1))) 6969 &)) 6970 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_7_1', 6971 &10,MA_ERR) 6972 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 6973 &7_1',11,MA_ERR) 6974 END IF 6975 END IF 6976 END IF 6977 next = NXTASK(nprocs,1) 6978 END IF 6979 count = count + 1 6980 END DO 6981 END DO 6982 END DO 6983 END DO 6984 next = NXTASK(-nprocs,1) 6985 call GA_SYNC() 6986 RETURN 6987 END 6988 SUBROUTINE OFFSET_eomccsd_density1_5_7_1(l_a_offset,k_a_offset,siz 6989 &e) 6990C $Id$ 6991C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6992C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6993C i2 ( h4 h5 h7 p3 )_yx 6994 IMPLICIT NONE 6995#include "global.fh" 6996#include "mafdecls.fh" 6997#include "sym.fh" 6998#include "errquit.fh" 6999#include "tce.fh" 7000 INTEGER l_a_offset 7001 INTEGER k_a_offset 7002 INTEGER size 7003 INTEGER length 7004 INTEGER addr 7005 INTEGER h4b 7006 INTEGER h5b 7007 INTEGER h7b 7008 INTEGER p3b 7009 length = 0 7010 DO h4b = 1,noab 7011 DO h5b = h4b,noab 7012 DO h7b = 1,noab 7013 DO p3b = noab+1,noab+nvab 7014 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h 7015 &7b-1)+int_mb(k_spin+p3b-1)) THEN 7016 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 7017 &k_sym+h7b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_y,irrep_x)) TH 7018 &EN 7019 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 7020 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN 7021 length = length + 1 7022 END IF 7023 END IF 7024 END IF 7025 END DO 7026 END DO 7027 END DO 7028 END DO 7029 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 7030 &set)) CALL ERRQUIT('eomccsd_density1_5_7_1',0,MA_ERR) 7031 int_mb(k_a_offset) = length 7032 addr = 0 7033 size = 0 7034 DO h4b = 1,noab 7035 DO h5b = h4b,noab 7036 DO h7b = 1,noab 7037 DO p3b = noab+1,noab+nvab 7038 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h 7039 &7b-1)+int_mb(k_spin+p3b-1)) THEN 7040 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 7041 &k_sym+h7b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_y,irrep_x)) TH 7042 &EN 7043 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 7044 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN 7045 addr = addr + 1 7046 int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h7b - 1 + noab 7047 &* (h5b - 1 + noab * (h4b - 1))) 7048 int_mb(k_a_offset+length+addr) = size 7049 size = size + int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_ 7050 &mb(k_range+h7b-1) * int_mb(k_range+p3b-1) 7051 END IF 7052 END IF 7053 END IF 7054 END DO 7055 END DO 7056 END DO 7057 END DO 7058 RETURN 7059 END 7060 SUBROUTINE eomccsd_density1_5_8(d_a,k_a_offset,d_b,k_b_offset,d_c, 7061 &k_c_offset) 7062C $Id$ 7063C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7064C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7065C i1 ( p8 h7 )_yttx + = -1/2 * x ( )_x * i2 ( p8 h7 )_ytt 7066 IMPLICIT NONE 7067#include "global.fh" 7068#include "mafdecls.fh" 7069#include "sym.fh" 7070#include "errquit.fh" 7071#include "tce.fh" 7072 INTEGER d_a 7073 INTEGER k_a_offset 7074 INTEGER d_b 7075 INTEGER k_b_offset 7076 INTEGER d_c 7077 INTEGER k_c_offset 7078 INTEGER NXTASK 7079 INTEGER next 7080 INTEGER nprocs 7081 INTEGER count 7082 INTEGER p8b 7083 INTEGER h7b 7084 INTEGER dimc 7085 INTEGER l_c_sort 7086 INTEGER k_c_sort 7087 INTEGER p8b_2 7088 INTEGER h7b_2 7089 INTEGER dim_common 7090 INTEGER dima_sort 7091 INTEGER dima 7092 INTEGER dimb_sort 7093 INTEGER dimb 7094 INTEGER l_a_sort 7095 INTEGER k_a_sort 7096 INTEGER l_a 7097 INTEGER k_a 7098 INTEGER l_b_sort 7099 INTEGER k_b_sort 7100 INTEGER l_b 7101 INTEGER k_b 7102 INTEGER l_c 7103 INTEGER k_c 7104 EXTERNAL NXTASK 7105 nprocs = GA_NNODES() 7106 count = 0 7107 next = NXTASK(nprocs,1) 7108 DO p8b = noab+1,noab+nvab 7109 DO h7b = 1,noab 7110 IF (next.eq.count) THEN 7111 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 7112 &).ne.4)) THEN 7113 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 7114 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 7115 &y,ieor(irrep_t,ieor(irrep_t,irrep_x)))) THEN 7116 dimc = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 7117 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7118 & ERRQUIT('eomccsd_density1_5_8',0,MA_ERR) 7119 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7120 IF (0 .eq. irrep_x) THEN 7121 CALL TCE_RESTRICTED_2(p8b,h7b,p8b_2,h7b_2) 7122 dim_common = 1 7123 dima_sort = 1 7124 dima = dim_common * dima_sort 7125 dimb_sort = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 7126 dimb = dim_common * dimb_sort 7127 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7128 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7129 & ERRQUIT('eomccsd_density1_5_8',1,MA_ERR) 7130 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7131 &eomccsd_density1_5_8',2,MA_ERR) 7132 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),0) 7133 CALL TCE_SORT_0(dbl_mb(k_a),dbl_mb(k_a_sort),1.0d0) 7134 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_8',3, 7135 &MA_ERR) 7136 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7137 & ERRQUIT('eomccsd_density1_5_8',4,MA_ERR) 7138 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7139 &eomccsd_density1_5_8',5,MA_ERR) 7140 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h7b_2 7141 & - 1 + noab * (p8b_2 - noab - 1))) 7142 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p8b-1) 7143 &,int_mb(k_range+h7b-1),2,1,1.0d0) 7144 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_8',6, 7145 &MA_ERR) 7146 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 7147 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 7148 &t),dima_sort) 7149 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 7150 &8',7,MA_ERR) 7151 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 7152 &8',8,MA_ERR) 7153 END IF 7154 END IF 7155 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7156 &eomccsd_density1_5_8',9,MA_ERR) 7157 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 7158 &,int_mb(k_range+p8b-1),2,1,-1.0d0/2.0d0) 7159 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 7160 & 1 + noab * (p8b - noab - 1))) 7161 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_8',10 7162 &,MA_ERR) 7163 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 7164 &8',11,MA_ERR) 7165 END IF 7166 END IF 7167 END IF 7168 next = NXTASK(nprocs,1) 7169 END IF 7170 count = count + 1 7171 END DO 7172 END DO 7173 next = NXTASK(-nprocs,1) 7174 call GA_SYNC() 7175 RETURN 7176 END 7177 SUBROUTINE eomccsd_density1_5_8_1(d_a,k_a_offset,d_b,k_b_offset,d_ 7178 &c,k_c_offset) 7179C $Id$ 7180C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7181C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7182C i2 ( p8 h7 )_ytt + = 1 * Sum ( h4 h5 p3 ) * t ( p3 p8 h4 h5 )_t * i3 ( h4 h5 h7 p3 )_yt 7183 IMPLICIT NONE 7184#include "global.fh" 7185#include "mafdecls.fh" 7186#include "sym.fh" 7187#include "errquit.fh" 7188#include "tce.fh" 7189 INTEGER d_a 7190 INTEGER k_a_offset 7191 INTEGER d_b 7192 INTEGER k_b_offset 7193 INTEGER d_c 7194 INTEGER k_c_offset 7195 INTEGER NXTASK 7196 INTEGER next 7197 INTEGER nprocs 7198 INTEGER count 7199 INTEGER p8b 7200 INTEGER h7b 7201 INTEGER dimc 7202 INTEGER l_c_sort 7203 INTEGER k_c_sort 7204 INTEGER p3b 7205 INTEGER h4b 7206 INTEGER h5b 7207 INTEGER p8b_1 7208 INTEGER p3b_1 7209 INTEGER h4b_1 7210 INTEGER h5b_1 7211 INTEGER h4b_2 7212 INTEGER h5b_2 7213 INTEGER h7b_2 7214 INTEGER p3b_2 7215 INTEGER dim_common 7216 INTEGER dima_sort 7217 INTEGER dima 7218 INTEGER dimb_sort 7219 INTEGER dimb 7220 INTEGER l_a_sort 7221 INTEGER k_a_sort 7222 INTEGER l_a 7223 INTEGER k_a 7224 INTEGER l_b_sort 7225 INTEGER k_b_sort 7226 INTEGER l_b 7227 INTEGER k_b 7228 INTEGER nsubh(2) 7229 INTEGER isubh 7230 INTEGER l_c 7231 INTEGER k_c 7232 DOUBLE PRECISION FACTORIAL 7233 EXTERNAL NXTASK 7234 EXTERNAL FACTORIAL 7235 nprocs = GA_NNODES() 7236 count = 0 7237 next = NXTASK(nprocs,1) 7238 DO p8b = noab+1,noab+nvab 7239 DO h7b = 1,noab 7240 IF (next.eq.count) THEN 7241 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 7242 &).ne.4)) THEN 7243 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 7244 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 7245 &y,ieor(irrep_t,irrep_t))) THEN 7246 dimc = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 7247 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7248 & ERRQUIT('eomccsd_density1_5_8_1',0,MA_ERR) 7249 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7250 DO p3b = noab+1,noab+nvab 7251 DO h4b = 1,noab 7252 DO h5b = h4b,noab 7253 IF (int_mb(k_spin+p8b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 7254 &4b-1)+int_mb(k_spin+h5b-1)) THEN 7255 IF (ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 7256 &k_sym+h4b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN 7257 CALL TCE_RESTRICTED_4(p8b,p3b,h4b,h5b,p8b_1,p3b_1,h4b_1,h5b_1) 7258 CALL TCE_RESTRICTED_4(h4b,h5b,h7b,p3b,h4b_2,h5b_2,h7b_2,p3b_2) 7259 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) * int_m 7260 &b(k_range+h5b-1) 7261 dima_sort = int_mb(k_range+p8b-1) 7262 dima = dim_common * dima_sort 7263 dimb_sort = int_mb(k_range+h7b-1) 7264 dimb = dim_common * dimb_sort 7265 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7266 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7267 & ERRQUIT('eomccsd_density1_5_8_1',1,MA_ERR) 7268 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7269 &eomccsd_density1_5_8_1',2,MA_ERR) 7270 IF ((p3b .le. p8b)) THEN 7271 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 7272 & - 1 + noab * (h4b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_ 7273 &1 - noab - 1))))) 7274 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7275 &,int_mb(k_range+p8b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1) 7276 &,2,4,3,1,1.0d0) 7277 END IF 7278 IF ((p8b .lt. p3b)) THEN 7279 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 7280 & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_ 7281 &1 - noab - 1))))) 7282 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 7283 &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1) 7284 &,1,4,3,2,-1.0d0) 7285 END IF 7286 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_8_1', 7287 &3,MA_ERR) 7288 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7289 & ERRQUIT('eomccsd_density1_5_8_1',4,MA_ERR) 7290 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7291 &eomccsd_density1_5_8_1',5,MA_ERR) 7292 IF ((h7b .le. p3b)) THEN 7293 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 7294 & - noab - 1 + nvab * (h7b_2 - 1 + noab * (h5b_2 - 1 + noab * (h4b_ 7295 &2 - 1))))) 7296 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 7297 &,int_mb(k_range+h5b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1) 7298 &,3,2,1,4,1.0d0) 7299 END IF 7300 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_8_1', 7301 &6,MA_ERR) 7302 nsubh(1) = 1 7303 nsubh(2) = 1 7304 isubh = 1 7305 IF (h4b .eq. h5b) THEN 7306 nsubh(isubh) = nsubh(isubh) + 1 7307 ELSE 7308 isubh = isubh + 1 7309 END IF 7310 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 7311 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 7312 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 7313 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 7314 &8_1',7,MA_ERR) 7315 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 7316 &8_1',8,MA_ERR) 7317 END IF 7318 END IF 7319 END IF 7320 END DO 7321 END DO 7322 END DO 7323 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7324 &eomccsd_density1_5_8_1',9,MA_ERR) 7325 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 7326 &,int_mb(k_range+p8b-1),2,1,1.0d0) 7327 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h7b - 7328 & 1 + noab * (p8b - noab - 1))) 7329 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_8_1', 7330 &10,MA_ERR) 7331 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 7332 &8_1',11,MA_ERR) 7333 END IF 7334 END IF 7335 END IF 7336 next = NXTASK(nprocs,1) 7337 END IF 7338 count = count + 1 7339 END DO 7340 END DO 7341 next = NXTASK(-nprocs,1) 7342 call GA_SYNC() 7343 RETURN 7344 END 7345 SUBROUTINE OFFSET_eomccsd_density1_5_8_1(l_a_offset,k_a_offset,siz 7346 &e) 7347C $Id$ 7348C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7349C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7350C i2 ( p8 h7 )_ytt 7351 IMPLICIT NONE 7352#include "global.fh" 7353#include "mafdecls.fh" 7354#include "sym.fh" 7355#include "errquit.fh" 7356#include "tce.fh" 7357 INTEGER l_a_offset 7358 INTEGER k_a_offset 7359 INTEGER size 7360 INTEGER length 7361 INTEGER addr 7362 INTEGER p8b 7363 INTEGER h7b 7364 length = 0 7365 DO p8b = noab+1,noab+nvab 7366 DO h7b = 1,noab 7367 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 7368 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 7369 &y,ieor(irrep_t,irrep_t))) THEN 7370 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 7371 &).ne.4)) THEN 7372 length = length + 1 7373 END IF 7374 END IF 7375 END IF 7376 END DO 7377 END DO 7378 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 7379 &set)) CALL ERRQUIT('eomccsd_density1_5_8_1',0,MA_ERR) 7380 int_mb(k_a_offset) = length 7381 addr = 0 7382 size = 0 7383 DO p8b = noab+1,noab+nvab 7384 DO h7b = 1,noab 7385 IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h7b-1)) THEN 7386 IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h7b-1)) .eq. ieor(irrep_ 7387 &y,ieor(irrep_t,irrep_t))) THEN 7388 IF ((.not.restricted).or.(int_mb(k_spin+p8b-1)+int_mb(k_spin+h7b-1 7389 &).ne.4)) THEN 7390 addr = addr + 1 7391 int_mb(k_a_offset+addr) = h7b - 1 + noab * (p8b - noab - 1) 7392 int_mb(k_a_offset+length+addr) = size 7393 size = size + int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1) 7394 END IF 7395 END IF 7396 END IF 7397 END DO 7398 END DO 7399 RETURN 7400 END 7401 SUBROUTINE eomccsd_density1_5_8_1_1(d_a,k_a_offset,d_b,k_b_offset, 7402 &d_c,k_c_offset) 7403C $Id$ 7404C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7405C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7406C i3 ( h4 h5 h7 p3 )_yt + = 1 * Sum ( p6 ) * t ( p6 h7 )_t * y ( h4 h5 p3 p6 )_y 7407 IMPLICIT NONE 7408#include "global.fh" 7409#include "mafdecls.fh" 7410#include "sym.fh" 7411#include "errquit.fh" 7412#include "tce.fh" 7413 INTEGER d_a 7414 INTEGER k_a_offset 7415 INTEGER d_b 7416 INTEGER k_b_offset 7417 INTEGER d_c 7418 INTEGER k_c_offset 7419 INTEGER NXTASK 7420 INTEGER next 7421 INTEGER nprocs 7422 INTEGER count 7423 INTEGER h4b 7424 INTEGER h5b 7425 INTEGER h7b 7426 INTEGER p3b 7427 INTEGER dimc 7428 INTEGER l_c_sort 7429 INTEGER k_c_sort 7430 INTEGER p6b 7431 INTEGER p6b_1 7432 INTEGER h7b_1 7433 INTEGER h4b_2 7434 INTEGER h5b_2 7435 INTEGER p3b_2 7436 INTEGER p6b_2 7437 INTEGER dim_common 7438 INTEGER dima_sort 7439 INTEGER dima 7440 INTEGER dimb_sort 7441 INTEGER dimb 7442 INTEGER l_a_sort 7443 INTEGER k_a_sort 7444 INTEGER l_a 7445 INTEGER k_a 7446 INTEGER l_b_sort 7447 INTEGER k_b_sort 7448 INTEGER l_b 7449 INTEGER k_b 7450 INTEGER l_c 7451 INTEGER k_c 7452 EXTERNAL NXTASK 7453 nprocs = GA_NNODES() 7454 count = 0 7455 next = NXTASK(nprocs,1) 7456 DO h4b = 1,noab 7457 DO h5b = h4b,noab 7458 DO h7b = 1,noab 7459 DO p3b = noab+1,noab+nvab 7460 IF (next.eq.count) THEN 7461 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 7462 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN 7463 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h 7464 &7b-1)+int_mb(k_spin+p3b-1)) THEN 7465 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 7466 &k_sym+h7b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 7467 &EN 7468 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra 7469 &nge+h7b-1) * int_mb(k_range+p3b-1) 7470 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7471 & ERRQUIT('eomccsd_density1_5_8_1_1',0,MA_ERR) 7472 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7473 DO p6b = noab+1,noab+nvab 7474 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN 7475 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 7476 &EN 7477 CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1) 7478 CALL TCE_RESTRICTED_4(h4b,h5b,p3b,p6b,h4b_2,h5b_2,p3b_2,p6b_2) 7479 dim_common = int_mb(k_range+p6b-1) 7480 dima_sort = int_mb(k_range+h7b-1) 7481 dima = dim_common * dima_sort 7482 dimb_sort = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb 7483 &(k_range+p3b-1) 7484 dimb = dim_common * dimb_sort 7485 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7486 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7487 & ERRQUIT('eomccsd_density1_5_8_1_1',1,MA_ERR) 7488 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7489 &eomccsd_density1_5_8_1_1',2,MA_ERR) 7490 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 7491 & - 1 + noab * (p6b_1 - noab - 1))) 7492 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 7493 &,int_mb(k_range+h7b-1),2,1,1.0d0) 7494 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_5_8_1_1 7495 &',3,MA_ERR) 7496 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7497 & ERRQUIT('eomccsd_density1_5_8_1_1',4,MA_ERR) 7498 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7499 &eomccsd_density1_5_8_1_1',5,MA_ERR) 7500 IF ((p6b .lt. p3b)) THEN 7501 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 7502 & - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 7503 &* (h4b_2 - 1))))) 7504 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 7505 &,int_mb(k_range+h5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1) 7506 &,4,2,1,3,-1.0d0) 7507 END IF 7508 IF ((p3b .le. p6b)) THEN 7509 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 7510 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 7511 &* (h4b_2 - 1))))) 7512 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 7513 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1) 7514 &,3,2,1,4,1.0d0) 7515 END IF 7516 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_5_8_1_1 7517 &',6,MA_ERR) 7518 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 7519 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 7520 &t),dima_sort) 7521 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_5_ 7522 &8_1_1',7,MA_ERR) 7523 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_5_ 7524 &8_1_1',8,MA_ERR) 7525 END IF 7526 END IF 7527 END IF 7528 END DO 7529 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7530 &eomccsd_density1_5_8_1_1',9,MA_ERR) 7531 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1) 7532 &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),int_mb(k_range+h7b-1) 7533 &,3,2,4,1,1.0d0) 7534 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b - 7535 & noab - 1 + nvab * (h7b - 1 + noab * (h5b - 1 + noab * (h4b - 1))) 7536 &)) 7537 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_5_8_1_1 7538 &',10,MA_ERR) 7539 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_5_ 7540 &8_1_1',11,MA_ERR) 7541 END IF 7542 END IF 7543 END IF 7544 next = NXTASK(nprocs,1) 7545 END IF 7546 count = count + 1 7547 END DO 7548 END DO 7549 END DO 7550 END DO 7551 next = NXTASK(-nprocs,1) 7552 call GA_SYNC() 7553 RETURN 7554 END 7555 SUBROUTINE OFFSET_eomccsd_density1_5_8_1_1(l_a_offset,k_a_offset,s 7556 &ize) 7557C $Id$ 7558C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7559C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7560C i3 ( h4 h5 h7 p3 )_yt 7561 IMPLICIT NONE 7562#include "global.fh" 7563#include "mafdecls.fh" 7564#include "sym.fh" 7565#include "errquit.fh" 7566#include "tce.fh" 7567 INTEGER l_a_offset 7568 INTEGER k_a_offset 7569 INTEGER size 7570 INTEGER length 7571 INTEGER addr 7572 INTEGER h4b 7573 INTEGER h5b 7574 INTEGER h7b 7575 INTEGER p3b 7576 length = 0 7577 DO h4b = 1,noab 7578 DO h5b = h4b,noab 7579 DO h7b = 1,noab 7580 DO p3b = noab+1,noab+nvab 7581 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h 7582 &7b-1)+int_mb(k_spin+p3b-1)) THEN 7583 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 7584 &k_sym+h7b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 7585 &EN 7586 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 7587 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN 7588 length = length + 1 7589 END IF 7590 END IF 7591 END IF 7592 END DO 7593 END DO 7594 END DO 7595 END DO 7596 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 7597 &set)) CALL ERRQUIT('eomccsd_density1_5_8_1_1',0,MA_ERR) 7598 int_mb(k_a_offset) = length 7599 addr = 0 7600 size = 0 7601 DO h4b = 1,noab 7602 DO h5b = h4b,noab 7603 DO h7b = 1,noab 7604 DO p3b = noab+1,noab+nvab 7605 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h 7606 &7b-1)+int_mb(k_spin+p3b-1)) THEN 7607 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 7608 &k_sym+h7b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 7609 &EN 7610 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 7611 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN 7612 addr = addr + 1 7613 int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h7b - 1 + noab 7614 &* (h5b - 1 + noab * (h4b - 1))) 7615 int_mb(k_a_offset+length+addr) = size 7616 size = size + int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_ 7617 &mb(k_range+h7b-1) * int_mb(k_range+p3b-1) 7618 END IF 7619 END IF 7620 END IF 7621 END DO 7622 END DO 7623 END DO 7624 END DO 7625 RETURN 7626 END 7627 SUBROUTINE eomccsd_density1_6(d_a,k_a_offset,d_b,k_b_offset,d_c,k_ 7628 &c_offset) 7629C $Id$ 7630C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7631C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7632C i0 ( )_yxd + = -1/2 * Sum ( p2 p1 ) * d ( p1 p2 )_d * i1 ( p2 p1 )_yx 7633 IMPLICIT NONE 7634#include "global.fh" 7635#include "mafdecls.fh" 7636#include "sym.fh" 7637#include "errquit.fh" 7638#include "tce.fh" 7639 INTEGER d_a 7640 INTEGER k_a_offset 7641 INTEGER d_b 7642 INTEGER k_b_offset 7643 INTEGER d_c 7644 INTEGER k_c_offset 7645 INTEGER NXTASK 7646 INTEGER next 7647 INTEGER nprocs 7648 INTEGER count 7649 INTEGER dimc 7650 INTEGER l_c_sort 7651 INTEGER k_c_sort 7652 INTEGER p1b 7653 INTEGER p2b 7654 INTEGER p1b_1 7655 INTEGER p2b_1 7656 INTEGER p2b_2 7657 INTEGER p1b_2 7658 INTEGER dim_common 7659 INTEGER dima_sort 7660 INTEGER dima 7661 INTEGER dimb_sort 7662 INTEGER dimb 7663 INTEGER l_a_sort 7664 INTEGER k_a_sort 7665 INTEGER l_a 7666 INTEGER k_a 7667 INTEGER l_b_sort 7668 INTEGER k_b_sort 7669 INTEGER l_b 7670 INTEGER k_b 7671 INTEGER l_c 7672 INTEGER k_c 7673 EXTERNAL NXTASK 7674 nprocs = GA_NNODES() 7675 count = 0 7676 next = NXTASK(nprocs,1) 7677 IF (next.eq.count) THEN 7678 IF (0 .eq. ieor(irrep_y,ieor(irrep_x,irrep_d))) THEN 7679 dimc = 1 7680 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7681 & ERRQUIT('eomccsd_density1_6',0,MA_ERR) 7682 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7683 DO p1b = noab+1,noab+nvab 7684 DO p2b = noab+1,noab+nvab 7685 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+p2b-1)) THEN 7686 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+p2b-1)) .eq. irrep_d) TH 7687 &EN 7688 CALL TCE_RESTRICTED_2(p1b,p2b,p1b_1,p2b_1) 7689 CALL TCE_RESTRICTED_2(p2b,p1b,p2b_2,p1b_2) 7690 dim_common = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) 7691 dima_sort = 1 7692 dima = dim_common * dima_sort 7693 dimb_sort = 1 7694 dimb = dim_common * dimb_sort 7695 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7696 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7697 & ERRQUIT('eomccsd_density1_6',1,MA_ERR) 7698 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7699 &eomccsd_density1_6',2,MA_ERR) 7700 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 7701 & - 1 + (noab+nvab) * (p1b_1 - 1))) 7702 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 7703 &,int_mb(k_range+p2b-1),2,1,1.0d0) 7704 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_6',3,MA 7705 &_ERR) 7706 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7707 & ERRQUIT('eomccsd_density1_6',4,MA_ERR) 7708 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7709 &eomccsd_density1_6',5,MA_ERR) 7710 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 7711 & - noab - 1 + nvab * (p2b_2 - noab - 1))) 7712 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1) 7713 &,int_mb(k_range+p1b-1),1,2,1.0d0) 7714 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_6',6,MA 7715 &_ERR) 7716 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 7717 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 7718 &t),dima_sort) 7719 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_6' 7720 &,7,MA_ERR) 7721 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_6' 7722 &,8,MA_ERR) 7723 END IF 7724 END IF 7725 END IF 7726 END DO 7727 END DO 7728 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7729 &eomccsd_density1_6',9,MA_ERR) 7730 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),-1.0d0/2.0d0) 7731 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 7732 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_6',10,M 7733 &A_ERR) 7734 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_6' 7735 &,11,MA_ERR) 7736 END IF 7737 next = NXTASK(nprocs,1) 7738 END IF 7739 count = count + 1 7740 next = NXTASK(-nprocs,1) 7741 call GA_SYNC() 7742 RETURN 7743 END 7744 SUBROUTINE eomccsd_density1_6_1(d_a,k_a_offset,d_b,k_b_offset,d_c, 7745 &k_c_offset) 7746C $Id$ 7747C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7748C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7749C i1 ( p2 p1 )_yx + = -1 * Sum ( h5 h4 p3 ) * x ( p2 p3 h4 h5 )_x * y ( h4 h5 p1 p3 )_y 7750 IMPLICIT NONE 7751#include "global.fh" 7752#include "mafdecls.fh" 7753#include "sym.fh" 7754#include "errquit.fh" 7755#include "tce.fh" 7756 INTEGER d_a 7757 INTEGER k_a_offset 7758 INTEGER d_b 7759 INTEGER k_b_offset 7760 INTEGER d_c 7761 INTEGER k_c_offset 7762 INTEGER NXTASK 7763 INTEGER next 7764 INTEGER nprocs 7765 INTEGER count 7766 INTEGER p2b 7767 INTEGER p1b 7768 INTEGER dimc 7769 INTEGER l_c_sort 7770 INTEGER k_c_sort 7771 INTEGER p3b 7772 INTEGER h4b 7773 INTEGER h5b 7774 INTEGER p2b_1 7775 INTEGER p3b_1 7776 INTEGER h4b_1 7777 INTEGER h5b_1 7778 INTEGER h4b_2 7779 INTEGER h5b_2 7780 INTEGER p1b_2 7781 INTEGER p3b_2 7782 INTEGER dim_common 7783 INTEGER dima_sort 7784 INTEGER dima 7785 INTEGER dimb_sort 7786 INTEGER dimb 7787 INTEGER l_a_sort 7788 INTEGER k_a_sort 7789 INTEGER l_a 7790 INTEGER k_a 7791 INTEGER l_b_sort 7792 INTEGER k_b_sort 7793 INTEGER l_b 7794 INTEGER k_b 7795 INTEGER nsubh(2) 7796 INTEGER isubh 7797 INTEGER l_c 7798 INTEGER k_c 7799 DOUBLE PRECISION FACTORIAL 7800 EXTERNAL NXTASK 7801 EXTERNAL FACTORIAL 7802 nprocs = GA_NNODES() 7803 count = 0 7804 next = NXTASK(nprocs,1) 7805 DO p2b = noab+1,noab+nvab 7806 DO p1b = noab+1,noab+nvab 7807 IF (next.eq.count) THEN 7808 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p1b-1 7809 &).ne.4)) THEN 7810 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 7811 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 7812 &y,irrep_x)) THEN 7813 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p1b-1) 7814 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 7815 & ERRQUIT('eomccsd_density1_6_1',0,MA_ERR) 7816 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 7817 DO p3b = noab+1,noab+nvab 7818 DO h4b = 1,noab 7819 DO h5b = h4b,noab 7820 IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 7821 &4b-1)+int_mb(k_spin+h5b-1)) THEN 7822 IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 7823 &k_sym+h4b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_x) THEN 7824 CALL TCE_RESTRICTED_4(p2b,p3b,h4b,h5b,p2b_1,p3b_1,h4b_1,h5b_1) 7825 CALL TCE_RESTRICTED_4(h4b,h5b,p1b,p3b,h4b_2,h5b_2,p1b_2,p3b_2) 7826 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) * int_m 7827 &b(k_range+h5b-1) 7828 dima_sort = int_mb(k_range+p2b-1) 7829 dima = dim_common * dima_sort 7830 dimb_sort = int_mb(k_range+p1b-1) 7831 dimb = dim_common * dimb_sort 7832 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 7833 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 7834 & ERRQUIT('eomccsd_density1_6_1',1,MA_ERR) 7835 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 7836 &eomccsd_density1_6_1',2,MA_ERR) 7837 IF ((p3b .lt. p2b)) THEN 7838 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 7839 & - 1 + noab * (h4b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p3b_ 7840 &1 - noab - 1))))) 7841 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 7842 &,int_mb(k_range+p2b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1) 7843 &,2,4,3,1,-1.0d0) 7844 END IF 7845 IF ((p2b .le. p3b)) THEN 7846 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 7847 & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p2b_ 7848 &1 - noab - 1))))) 7849 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 7850 &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1) 7851 &,1,4,3,2,1.0d0) 7852 END IF 7853 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_6_1',3, 7854 &MA_ERR) 7855 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 7856 & ERRQUIT('eomccsd_density1_6_1',4,MA_ERR) 7857 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 7858 &eomccsd_density1_6_1',5,MA_ERR) 7859 IF ((p3b .lt. p1b)) THEN 7860 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 7861 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 7862 &* (h4b_2 - 1))))) 7863 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 7864 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p1b-1) 7865 &,4,2,1,3,-1.0d0) 7866 END IF 7867 IF ((p1b .le. p3b)) THEN 7868 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 7869 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 7870 &* (h4b_2 - 1))))) 7871 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 7872 &,int_mb(k_range+h5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p3b-1) 7873 &,3,2,1,4,1.0d0) 7874 END IF 7875 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_6_1',6, 7876 &MA_ERR) 7877 nsubh(1) = 1 7878 nsubh(2) = 1 7879 isubh = 1 7880 IF (h4b .eq. h5b) THEN 7881 nsubh(isubh) = nsubh(isubh) + 1 7882 ELSE 7883 isubh = isubh + 1 7884 END IF 7885 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 7886 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 7887 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 7888 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_6_ 7889 &1',7,MA_ERR) 7890 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_6_ 7891 &1',8,MA_ERR) 7892 END IF 7893 END IF 7894 END IF 7895 END DO 7896 END DO 7897 END DO 7898 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 7899 &eomccsd_density1_6_1',9,MA_ERR) 7900 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 7901 &,int_mb(k_range+p2b-1),2,1,-1.0d0) 7902 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b - 7903 & noab - 1 + nvab * (p2b - noab - 1))) 7904 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_6_1',10 7905 &,MA_ERR) 7906 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_6_ 7907 &1',11,MA_ERR) 7908 END IF 7909 END IF 7910 END IF 7911 next = NXTASK(nprocs,1) 7912 END IF 7913 count = count + 1 7914 END DO 7915 END DO 7916 next = NXTASK(-nprocs,1) 7917 call GA_SYNC() 7918 RETURN 7919 END 7920 SUBROUTINE OFFSET_eomccsd_density1_6_1(l_a_offset,k_a_offset,size) 7921C $Id$ 7922C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7923C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7924C i1 ( p2 p1 )_yx 7925 IMPLICIT NONE 7926#include "global.fh" 7927#include "mafdecls.fh" 7928#include "sym.fh" 7929#include "errquit.fh" 7930#include "tce.fh" 7931 INTEGER l_a_offset 7932 INTEGER k_a_offset 7933 INTEGER size 7934 INTEGER length 7935 INTEGER addr 7936 INTEGER p2b 7937 INTEGER p1b 7938 length = 0 7939 DO p2b = noab+1,noab+nvab 7940 DO p1b = noab+1,noab+nvab 7941 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 7942 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 7943 &y,irrep_x)) THEN 7944 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p1b-1 7945 &).ne.4)) THEN 7946 length = length + 1 7947 END IF 7948 END IF 7949 END IF 7950 END DO 7951 END DO 7952 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 7953 &set)) CALL ERRQUIT('eomccsd_density1_6_1',0,MA_ERR) 7954 int_mb(k_a_offset) = length 7955 addr = 0 7956 size = 0 7957 DO p2b = noab+1,noab+nvab 7958 DO p1b = noab+1,noab+nvab 7959 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 7960 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 7961 &y,irrep_x)) THEN 7962 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p1b-1 7963 &).ne.4)) THEN 7964 addr = addr + 1 7965 int_mb(k_a_offset+addr) = p1b - noab - 1 + nvab * (p2b - noab - 1) 7966 int_mb(k_a_offset+length+addr) = size 7967 size = size + int_mb(k_range+p2b-1) * int_mb(k_range+p1b-1) 7968 END IF 7969 END IF 7970 END IF 7971 END DO 7972 END DO 7973 RETURN 7974 END 7975 SUBROUTINE eomccsd_density1_6_2(d_a,k_a_offset,d_b,k_b_offset,d_c, 7976 &k_c_offset) 7977C $Id$ 7978C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 7979C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7980C i1 ( p2 p1 )_yxt + = -2 * Sum ( h3 ) * t ( p2 h3 )_t * i2 ( h3 p1 )_yx 7981 IMPLICIT NONE 7982#include "global.fh" 7983#include "mafdecls.fh" 7984#include "sym.fh" 7985#include "errquit.fh" 7986#include "tce.fh" 7987 INTEGER d_a 7988 INTEGER k_a_offset 7989 INTEGER d_b 7990 INTEGER k_b_offset 7991 INTEGER d_c 7992 INTEGER k_c_offset 7993 INTEGER NXTASK 7994 INTEGER next 7995 INTEGER nprocs 7996 INTEGER count 7997 INTEGER p2b 7998 INTEGER p1b 7999 INTEGER dimc 8000 INTEGER l_c_sort 8001 INTEGER k_c_sort 8002 INTEGER h3b 8003 INTEGER p2b_1 8004 INTEGER h3b_1 8005 INTEGER h3b_2 8006 INTEGER p1b_2 8007 INTEGER dim_common 8008 INTEGER dima_sort 8009 INTEGER dima 8010 INTEGER dimb_sort 8011 INTEGER dimb 8012 INTEGER l_a_sort 8013 INTEGER k_a_sort 8014 INTEGER l_a 8015 INTEGER k_a 8016 INTEGER l_b_sort 8017 INTEGER k_b_sort 8018 INTEGER l_b 8019 INTEGER k_b 8020 INTEGER l_c 8021 INTEGER k_c 8022 EXTERNAL NXTASK 8023 nprocs = GA_NNODES() 8024 count = 0 8025 next = NXTASK(nprocs,1) 8026 DO p2b = noab+1,noab+nvab 8027 DO p1b = noab+1,noab+nvab 8028 IF (next.eq.count) THEN 8029 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p1b-1 8030 &).ne.4)) THEN 8031 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 8032 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 8033 &y,ieor(irrep_x,irrep_t))) THEN 8034 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p1b-1) 8035 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8036 & ERRQUIT('eomccsd_density1_6_2',0,MA_ERR) 8037 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8038 DO h3b = 1,noab 8039 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h3b-1)) THEN 8040 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h3b-1)) .eq. irrep_t) TH 8041 &EN 8042 CALL TCE_RESTRICTED_2(p2b,h3b,p2b_1,h3b_1) 8043 CALL TCE_RESTRICTED_2(h3b,p1b,h3b_2,p1b_2) 8044 dim_common = int_mb(k_range+h3b-1) 8045 dima_sort = int_mb(k_range+p2b-1) 8046 dima = dim_common * dima_sort 8047 dimb_sort = int_mb(k_range+p1b-1) 8048 dimb = dim_common * dimb_sort 8049 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8050 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8051 & ERRQUIT('eomccsd_density1_6_2',1,MA_ERR) 8052 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8053 &eomccsd_density1_6_2',2,MA_ERR) 8054 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 8055 & - 1 + noab * (p2b_1 - noab - 1))) 8056 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 8057 &,int_mb(k_range+h3b-1),1,2,1.0d0) 8058 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_6_2',3, 8059 &MA_ERR) 8060 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8061 & ERRQUIT('eomccsd_density1_6_2',4,MA_ERR) 8062 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8063 &eomccsd_density1_6_2',5,MA_ERR) 8064 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 8065 & - noab - 1 + nvab * (h3b_2 - 1))) 8066 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 8067 &,int_mb(k_range+p1b-1),2,1,1.0d0) 8068 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_6_2',6, 8069 &MA_ERR) 8070 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 8071 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 8072 &t),dima_sort) 8073 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8074 &2',7,MA_ERR) 8075 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8076 &2',8,MA_ERR) 8077 END IF 8078 END IF 8079 END IF 8080 END DO 8081 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8082 &eomccsd_density1_6_2',9,MA_ERR) 8083 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 8084 &,int_mb(k_range+p2b-1),2,1,-2.0d0/1.0d0) 8085 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b - 8086 & noab - 1 + nvab * (p2b - noab - 1))) 8087 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_6_2',10 8088 &,MA_ERR) 8089 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8090 &2',11,MA_ERR) 8091 END IF 8092 END IF 8093 END IF 8094 next = NXTASK(nprocs,1) 8095 END IF 8096 count = count + 1 8097 END DO 8098 END DO 8099 next = NXTASK(-nprocs,1) 8100 call GA_SYNC() 8101 RETURN 8102 END 8103 SUBROUTINE eomccsd_density1_6_2_1(d_a,k_a_offset,d_b,k_b_offset,d_ 8104 &c,k_c_offset) 8105C $Id$ 8106C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8107C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8108C i2 ( h3 p1 )_yx + = 1 * Sum ( h5 p4 ) * x ( p4 h5 )_x * y ( h3 h5 p1 p4 )_y 8109 IMPLICIT NONE 8110#include "global.fh" 8111#include "mafdecls.fh" 8112#include "sym.fh" 8113#include "errquit.fh" 8114#include "tce.fh" 8115 INTEGER d_a 8116 INTEGER k_a_offset 8117 INTEGER d_b 8118 INTEGER k_b_offset 8119 INTEGER d_c 8120 INTEGER k_c_offset 8121 INTEGER NXTASK 8122 INTEGER next 8123 INTEGER nprocs 8124 INTEGER count 8125 INTEGER h3b 8126 INTEGER p1b 8127 INTEGER dimc 8128 INTEGER l_c_sort 8129 INTEGER k_c_sort 8130 INTEGER p4b 8131 INTEGER h5b 8132 INTEGER p4b_1 8133 INTEGER h5b_1 8134 INTEGER h3b_2 8135 INTEGER h5b_2 8136 INTEGER p1b_2 8137 INTEGER p4b_2 8138 INTEGER dim_common 8139 INTEGER dima_sort 8140 INTEGER dima 8141 INTEGER dimb_sort 8142 INTEGER dimb 8143 INTEGER l_a_sort 8144 INTEGER k_a_sort 8145 INTEGER l_a 8146 INTEGER k_a 8147 INTEGER l_b_sort 8148 INTEGER k_b_sort 8149 INTEGER l_b 8150 INTEGER k_b 8151 INTEGER l_c 8152 INTEGER k_c 8153 EXTERNAL NXTASK 8154 nprocs = GA_NNODES() 8155 count = 0 8156 next = NXTASK(nprocs,1) 8157 DO h3b = 1,noab 8158 DO p1b = noab+1,noab+nvab 8159 IF (next.eq.count) THEN 8160 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+p1b-1 8161 &).ne.4)) THEN 8162 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+p1b-1)) THEN 8163 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 8164 &y,irrep_x)) THEN 8165 dimc = int_mb(k_range+h3b-1) * int_mb(k_range+p1b-1) 8166 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8167 & ERRQUIT('eomccsd_density1_6_2_1',0,MA_ERR) 8168 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8169 DO p4b = noab+1,noab+nvab 8170 DO h5b = 1,noab 8171 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h5b-1)) THEN 8172 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h5b-1)) .eq. irrep_x) TH 8173 &EN 8174 CALL TCE_RESTRICTED_2(p4b,h5b,p4b_1,h5b_1) 8175 CALL TCE_RESTRICTED_4(h3b,h5b,p1b,p4b,h3b_2,h5b_2,p1b_2,p4b_2) 8176 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h5b-1) 8177 dima_sort = 1 8178 dima = dim_common * dima_sort 8179 dimb_sort = int_mb(k_range+h3b-1) * int_mb(k_range+p1b-1) 8180 dimb = dim_common * dimb_sort 8181 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8182 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8183 & ERRQUIT('eomccsd_density1_6_2_1',1,MA_ERR) 8184 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8185 &eomccsd_density1_6_2_1',2,MA_ERR) 8186 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 8187 & - 1 + noab * (p4b_1 - noab - 1))) 8188 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 8189 &,int_mb(k_range+h5b-1),2,1,1.0d0) 8190 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_6_2_1', 8191 &3,MA_ERR) 8192 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8193 & ERRQUIT('eomccsd_density1_6_2_1',4,MA_ERR) 8194 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8195 &eomccsd_density1_6_2_1',5,MA_ERR) 8196 IF ((h5b .lt. h3b) .and. (p4b .lt. p1b)) THEN 8197 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 8198 & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (h3b_2 - 1 + noab 8199 &* (h5b_2 - 1))))) 8200 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 8201 &,int_mb(k_range+h3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p1b-1) 8202 &,4,2,1,3,1.0d0) 8203 END IF 8204 IF ((h5b .lt. h3b) .and. (p1b .le. p4b)) THEN 8205 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 8206 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (h3b_2 - 1 + noab 8207 &* (h5b_2 - 1))))) 8208 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 8209 &,int_mb(k_range+h3b-1),int_mb(k_range+p1b-1),int_mb(k_range+p4b-1) 8210 &,3,2,1,4,-1.0d0) 8211 END IF 8212 IF ((h3b .le. h5b) .and. (p4b .lt. p1b)) THEN 8213 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 8214 & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 8215 &* (h3b_2 - 1))))) 8216 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 8217 &,int_mb(k_range+h5b-1),int_mb(k_range+p4b-1),int_mb(k_range+p1b-1) 8218 &,4,1,2,3,-1.0d0) 8219 END IF 8220 IF ((h3b .le. h5b) .and. (p1b .le. p4b)) THEN 8221 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 8222 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 8223 &* (h3b_2 - 1))))) 8224 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 8225 &,int_mb(k_range+h5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p4b-1) 8226 &,3,1,2,4,1.0d0) 8227 END IF 8228 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_6_2_1', 8229 &6,MA_ERR) 8230 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 8231 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 8232 &t),dima_sort) 8233 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8234 &2_1',7,MA_ERR) 8235 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8236 &2_1',8,MA_ERR) 8237 END IF 8238 END IF 8239 END IF 8240 END DO 8241 END DO 8242 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8243 &eomccsd_density1_6_2_1',9,MA_ERR) 8244 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 8245 &,int_mb(k_range+h3b-1),2,1,1.0d0) 8246 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b - 8247 & noab - 1 + nvab * (h3b - 1))) 8248 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_6_2_1', 8249 &10,MA_ERR) 8250 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8251 &2_1',11,MA_ERR) 8252 END IF 8253 END IF 8254 END IF 8255 next = NXTASK(nprocs,1) 8256 END IF 8257 count = count + 1 8258 END DO 8259 END DO 8260 next = NXTASK(-nprocs,1) 8261 call GA_SYNC() 8262 RETURN 8263 END 8264 SUBROUTINE OFFSET_eomccsd_density1_6_2_1(l_a_offset,k_a_offset,siz 8265 &e) 8266C $Id$ 8267C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8268C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8269C i2 ( h3 p1 )_yx 8270 IMPLICIT NONE 8271#include "global.fh" 8272#include "mafdecls.fh" 8273#include "sym.fh" 8274#include "errquit.fh" 8275#include "tce.fh" 8276 INTEGER l_a_offset 8277 INTEGER k_a_offset 8278 INTEGER size 8279 INTEGER length 8280 INTEGER addr 8281 INTEGER h3b 8282 INTEGER p1b 8283 length = 0 8284 DO h3b = 1,noab 8285 DO p1b = noab+1,noab+nvab 8286 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+p1b-1)) THEN 8287 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 8288 &y,irrep_x)) THEN 8289 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+p1b-1 8290 &).ne.4)) THEN 8291 length = length + 1 8292 END IF 8293 END IF 8294 END IF 8295 END DO 8296 END DO 8297 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 8298 &set)) CALL ERRQUIT('eomccsd_density1_6_2_1',0,MA_ERR) 8299 int_mb(k_a_offset) = length 8300 addr = 0 8301 size = 0 8302 DO h3b = 1,noab 8303 DO p1b = noab+1,noab+nvab 8304 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+p1b-1)) THEN 8305 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 8306 &y,irrep_x)) THEN 8307 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+p1b-1 8308 &).ne.4)) THEN 8309 addr = addr + 1 8310 int_mb(k_a_offset+addr) = p1b - noab - 1 + nvab * (h3b - 1) 8311 int_mb(k_a_offset+length+addr) = size 8312 size = size + int_mb(k_range+h3b-1) * int_mb(k_range+p1b-1) 8313 END IF 8314 END IF 8315 END IF 8316 END DO 8317 END DO 8318 RETURN 8319 END 8320 SUBROUTINE eomccsd_density1_6_3(d_a,k_a_offset,d_b,k_b_offset,d_c, 8321 &k_c_offset) 8322C $Id$ 8323C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8324C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8325C i1 ( p2 p1 )_ytx + = 1 * x ( )_x * i2 ( p2 p1 )_yt 8326 IMPLICIT NONE 8327#include "global.fh" 8328#include "mafdecls.fh" 8329#include "sym.fh" 8330#include "errquit.fh" 8331#include "tce.fh" 8332 INTEGER d_a 8333 INTEGER k_a_offset 8334 INTEGER d_b 8335 INTEGER k_b_offset 8336 INTEGER d_c 8337 INTEGER k_c_offset 8338 INTEGER NXTASK 8339 INTEGER next 8340 INTEGER nprocs 8341 INTEGER count 8342 INTEGER p2b 8343 INTEGER p1b 8344 INTEGER dimc 8345 INTEGER l_c_sort 8346 INTEGER k_c_sort 8347 INTEGER p2b_2 8348 INTEGER p1b_2 8349 INTEGER dim_common 8350 INTEGER dima_sort 8351 INTEGER dima 8352 INTEGER dimb_sort 8353 INTEGER dimb 8354 INTEGER l_a_sort 8355 INTEGER k_a_sort 8356 INTEGER l_a 8357 INTEGER k_a 8358 INTEGER l_b_sort 8359 INTEGER k_b_sort 8360 INTEGER l_b 8361 INTEGER k_b 8362 INTEGER l_c 8363 INTEGER k_c 8364 EXTERNAL NXTASK 8365 nprocs = GA_NNODES() 8366 count = 0 8367 next = NXTASK(nprocs,1) 8368 DO p2b = noab+1,noab+nvab 8369 DO p1b = noab+1,noab+nvab 8370 IF (next.eq.count) THEN 8371 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p1b-1 8372 &).ne.4)) THEN 8373 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 8374 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 8375 &y,ieor(irrep_t,irrep_x))) THEN 8376 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p1b-1) 8377 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8378 & ERRQUIT('eomccsd_density1_6_3',0,MA_ERR) 8379 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8380 IF (0 .eq. irrep_x) THEN 8381 CALL TCE_RESTRICTED_2(p2b,p1b,p2b_2,p1b_2) 8382 dim_common = 1 8383 dima_sort = 1 8384 dima = dim_common * dima_sort 8385 dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+p1b-1) 8386 dimb = dim_common * dimb_sort 8387 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8388 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8389 & ERRQUIT('eomccsd_density1_6_3',1,MA_ERR) 8390 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8391 &eomccsd_density1_6_3',2,MA_ERR) 8392 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),0) 8393 CALL TCE_SORT_0(dbl_mb(k_a),dbl_mb(k_a_sort),1.0d0) 8394 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_6_3',3, 8395 &MA_ERR) 8396 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8397 & ERRQUIT('eomccsd_density1_6_3',4,MA_ERR) 8398 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8399 &eomccsd_density1_6_3',5,MA_ERR) 8400 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 8401 & - noab - 1 + nvab * (p2b_2 - noab - 1))) 8402 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1) 8403 &,int_mb(k_range+p1b-1),2,1,1.0d0) 8404 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_6_3',6, 8405 &MA_ERR) 8406 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 8407 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 8408 &t),dima_sort) 8409 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8410 &3',7,MA_ERR) 8411 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8412 &3',8,MA_ERR) 8413 END IF 8414 END IF 8415 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8416 &eomccsd_density1_6_3',9,MA_ERR) 8417 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 8418 &,int_mb(k_range+p2b-1),2,1,1.0d0) 8419 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b - 8420 & noab - 1 + nvab * (p2b - noab - 1))) 8421 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_6_3',10 8422 &,MA_ERR) 8423 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8424 &3',11,MA_ERR) 8425 END IF 8426 END IF 8427 END IF 8428 next = NXTASK(nprocs,1) 8429 END IF 8430 count = count + 1 8431 END DO 8432 END DO 8433 next = NXTASK(-nprocs,1) 8434 call GA_SYNC() 8435 RETURN 8436 END 8437 SUBROUTINE eomccsd_density1_6_3_1(d_a,k_a_offset,d_b,k_b_offset,d_ 8438 &c,k_c_offset) 8439C $Id$ 8440C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8441C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8442C i2 ( p2 p1 )_yt + = -1 * Sum ( h5 h4 p3 ) * t ( p2 p3 h4 h5 )_t * y ( h4 h5 p1 p3 )_y 8443 IMPLICIT NONE 8444#include "global.fh" 8445#include "mafdecls.fh" 8446#include "sym.fh" 8447#include "errquit.fh" 8448#include "tce.fh" 8449 INTEGER d_a 8450 INTEGER k_a_offset 8451 INTEGER d_b 8452 INTEGER k_b_offset 8453 INTEGER d_c 8454 INTEGER k_c_offset 8455 INTEGER NXTASK 8456 INTEGER next 8457 INTEGER nprocs 8458 INTEGER count 8459 INTEGER p2b 8460 INTEGER p1b 8461 INTEGER dimc 8462 INTEGER l_c_sort 8463 INTEGER k_c_sort 8464 INTEGER p3b 8465 INTEGER h4b 8466 INTEGER h5b 8467 INTEGER p2b_1 8468 INTEGER p3b_1 8469 INTEGER h4b_1 8470 INTEGER h5b_1 8471 INTEGER h4b_2 8472 INTEGER h5b_2 8473 INTEGER p1b_2 8474 INTEGER p3b_2 8475 INTEGER dim_common 8476 INTEGER dima_sort 8477 INTEGER dima 8478 INTEGER dimb_sort 8479 INTEGER dimb 8480 INTEGER l_a_sort 8481 INTEGER k_a_sort 8482 INTEGER l_a 8483 INTEGER k_a 8484 INTEGER l_b_sort 8485 INTEGER k_b_sort 8486 INTEGER l_b 8487 INTEGER k_b 8488 INTEGER nsubh(2) 8489 INTEGER isubh 8490 INTEGER l_c 8491 INTEGER k_c 8492 DOUBLE PRECISION FACTORIAL 8493 EXTERNAL NXTASK 8494 EXTERNAL FACTORIAL 8495 nprocs = GA_NNODES() 8496 count = 0 8497 next = NXTASK(nprocs,1) 8498 DO p2b = noab+1,noab+nvab 8499 DO p1b = noab+1,noab+nvab 8500 IF (next.eq.count) THEN 8501 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p1b-1 8502 &).ne.4)) THEN 8503 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 8504 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 8505 &y,irrep_t)) THEN 8506 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p1b-1) 8507 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 8508 & ERRQUIT('eomccsd_density1_6_3_1',0,MA_ERR) 8509 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 8510 DO p3b = noab+1,noab+nvab 8511 DO h4b = 1,noab 8512 DO h5b = h4b,noab 8513 IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 8514 &4b-1)+int_mb(k_spin+h5b-1)) THEN 8515 IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 8516 &k_sym+h4b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN 8517 CALL TCE_RESTRICTED_4(p2b,p3b,h4b,h5b,p2b_1,p3b_1,h4b_1,h5b_1) 8518 CALL TCE_RESTRICTED_4(h4b,h5b,p1b,p3b,h4b_2,h5b_2,p1b_2,p3b_2) 8519 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) * int_m 8520 &b(k_range+h5b-1) 8521 dima_sort = int_mb(k_range+p2b-1) 8522 dima = dim_common * dima_sort 8523 dimb_sort = int_mb(k_range+p1b-1) 8524 dimb = dim_common * dimb_sort 8525 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 8526 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 8527 & ERRQUIT('eomccsd_density1_6_3_1',1,MA_ERR) 8528 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 8529 &eomccsd_density1_6_3_1',2,MA_ERR) 8530 IF ((p3b .lt. p2b)) THEN 8531 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 8532 & - 1 + noab * (h4b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p3b_ 8533 &1 - noab - 1))))) 8534 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 8535 &,int_mb(k_range+p2b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1) 8536 &,2,4,3,1,-1.0d0) 8537 END IF 8538 IF ((p2b .le. p3b)) THEN 8539 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1 8540 & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p2b_ 8541 &1 - noab - 1))))) 8542 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 8543 &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1) 8544 &,1,4,3,2,1.0d0) 8545 END IF 8546 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_density1_6_3_1', 8547 &3,MA_ERR) 8548 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 8549 & ERRQUIT('eomccsd_density1_6_3_1',4,MA_ERR) 8550 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 8551 &eomccsd_density1_6_3_1',5,MA_ERR) 8552 IF ((p3b .lt. p1b)) THEN 8553 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 8554 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 8555 &* (h4b_2 - 1))))) 8556 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 8557 &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p1b-1) 8558 &,4,2,1,3,-1.0d0) 8559 END IF 8560 IF ((p1b .le. p3b)) THEN 8561 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 8562 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (h5b_2 - 1 + noab 8563 &* (h4b_2 - 1))))) 8564 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 8565 &,int_mb(k_range+h5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p3b-1) 8566 &,3,2,1,4,1.0d0) 8567 END IF 8568 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_density1_6_3_1', 8569 &6,MA_ERR) 8570 nsubh(1) = 1 8571 nsubh(2) = 1 8572 isubh = 1 8573 IF (h4b .eq. h5b) THEN 8574 nsubh(isubh) = nsubh(isubh) + 1 8575 ELSE 8576 isubh = isubh + 1 8577 END IF 8578 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 8579 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 8580 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 8581 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8582 &3_1',7,MA_ERR) 8583 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8584 &3_1',8,MA_ERR) 8585 END IF 8586 END IF 8587 END IF 8588 END DO 8589 END DO 8590 END DO 8591 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 8592 &eomccsd_density1_6_3_1',9,MA_ERR) 8593 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 8594 &,int_mb(k_range+p2b-1),2,1,-1.0d0) 8595 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b - 8596 & noab - 1 + nvab * (p2b - noab - 1))) 8597 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_density1_6_3_1', 8598 &10,MA_ERR) 8599 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_density1_6_ 8600 &3_1',11,MA_ERR) 8601 END IF 8602 END IF 8603 END IF 8604 next = NXTASK(nprocs,1) 8605 END IF 8606 count = count + 1 8607 END DO 8608 END DO 8609 next = NXTASK(-nprocs,1) 8610 call GA_SYNC() 8611 RETURN 8612 END 8613 SUBROUTINE OFFSET_eomccsd_density1_6_3_1(l_a_offset,k_a_offset,siz 8614 &e) 8615C $Id$ 8616C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8617C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 8618C i2 ( p2 p1 )_yt 8619 IMPLICIT NONE 8620#include "global.fh" 8621#include "mafdecls.fh" 8622#include "sym.fh" 8623#include "errquit.fh" 8624#include "tce.fh" 8625 INTEGER l_a_offset 8626 INTEGER k_a_offset 8627 INTEGER size 8628 INTEGER length 8629 INTEGER addr 8630 INTEGER p2b 8631 INTEGER p1b 8632 length = 0 8633 DO p2b = noab+1,noab+nvab 8634 DO p1b = noab+1,noab+nvab 8635 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 8636 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 8637 &y,irrep_t)) THEN 8638 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p1b-1 8639 &).ne.4)) THEN 8640 length = length + 1 8641 END IF 8642 END IF 8643 END IF 8644 END DO 8645 END DO 8646 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 8647 &set)) CALL ERRQUIT('eomccsd_density1_6_3_1',0,MA_ERR) 8648 int_mb(k_a_offset) = length 8649 addr = 0 8650 size = 0 8651 DO p2b = noab+1,noab+nvab 8652 DO p1b = noab+1,noab+nvab 8653 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 8654 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 8655 &y,irrep_t)) THEN 8656 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p1b-1 8657 &).ne.4)) THEN 8658 addr = addr + 1 8659 int_mb(k_a_offset+addr) = p1b - noab - 1 + nvab * (p2b - noab - 1) 8660 int_mb(k_a_offset+length+addr) = size 8661 size = size + int_mb(k_range+p2b-1) * int_mb(k_range+p1b-1) 8662 END IF 8663 END IF 8664 END IF 8665 END DO 8666 END DO 8667 RETURN 8668 END 8669