1 SUBROUTINE eomccsd_o1(d_f1,d_i0,d_t1,d_x1,d_x2,k_f1_offset,k_i0_of 2 &fset,k_t1_offset,k_x1_offset,k_x2_offset) 3C $Id$ 4C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6C i0 ( p2 h1 )_xf + = -1 * Sum ( h3 ) * x ( p2 h3 )_x * i1 ( h3 h1 )_f 7C i1 ( h3 h1 )_f + = 1 * f ( h3 h1 )_f 8C i1 ( h3 h1 )_ft + = 1 * Sum ( p4 ) * t ( p4 h1 )_t * f ( h3 p4 )_f 9C i0 ( p2 h1 )_xf + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * f ( p2 p3 )_f 10C i0 ( p2 h1 )_xf + = 1 * Sum ( p4 h3 ) * x ( p2 p4 h1 h3 )_x * f ( h3 p4 )_f 11C i0 ( p2 h1 )_fxt + = -1 * Sum ( h3 ) * t ( p2 h3 )_t * i1 ( h3 h1 )_fx 12C i1 ( h3 h1 )_fx + = 1 * Sum ( p4 ) * x ( p4 h1 )_x * f ( h3 p4 )_f 13 IMPLICIT NONE 14#include "global.fh" 15#include "mafdecls.fh" 16#include "util.fh" 17#include "errquit.fh" 18#include "tce.fh" 19 INTEGER d_i0 20 INTEGER k_i0_offset 21 INTEGER d_x1 22 INTEGER k_x1_offset 23 INTEGER d_i1 24 INTEGER k_i1_offset 25 INTEGER d_f1 26 INTEGER k_f1_offset 27 INTEGER d_x2 28 INTEGER k_x2_offset 29 INTEGER d_t1 30 INTEGER k_t1_offset 31 INTEGER l_i1_offset 32 INTEGER size_i1 33 CHARACTER*255 filename 34 CALL OFFSET_eomccsd_o1_1_1(l_i1_offset,k_i1_offset,size_i1) 35 CALL TCE_FILENAME('eomccsd_o1_1_1_i1',filename) 36 CALL CREATEFILE(filename,d_i1,size_i1) 37 CALL eomccsd_o1_1_1(d_f1,k_f1_offset,d_i1,k_i1_offset) 38 CALL eomccsd_o1_1_2(d_t1,k_t1_offset,d_f1,k_f1_offset,d_i1,k_i1_of 39 &fset) 40 CALL RECONCILEFILE(d_i1,size_i1) 41 CALL eomccsd_o1_1(d_x1,k_x1_offset,d_i1,k_i1_offset,d_i0,k_i0_offs 42 &et) 43 CALL DELETEFILE(d_i1) 44 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('eomccsd_o1',-1,M 45 &A_ERR) 46 CALL eomccsd_o1_2(d_x1,k_x1_offset,d_f1,k_f1_offset,d_i0,k_i0_offs 47 &et) 48 CALL eomccsd_o1_3(d_x2,k_x2_offset,d_f1,k_f1_offset,d_i0,k_i0_offs 49 &et) 50 CALL OFFSET_eomccsd_o1_4_1(l_i1_offset,k_i1_offset,size_i1) 51 CALL TCE_FILENAME('eomccsd_o1_4_1_i1',filename) 52 CALL CREATEFILE(filename,d_i1,size_i1) 53 CALL eomccsd_o1_4_1(d_x1,k_x1_offset,d_f1,k_f1_offset,d_i1,k_i1_of 54 &fset) 55 CALL RECONCILEFILE(d_i1,size_i1) 56 CALL eomccsd_o1_4(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offs 57 &et) 58 CALL DELETEFILE(d_i1) 59 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('eomccsd_o1',-1,M 60 &A_ERR) 61 RETURN 62 END 63 SUBROUTINE eomccsd_o1_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offs 64 &et) 65C $Id$ 66C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 67C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 68C i0 ( p2 h1 )_xf + = -1 * Sum ( h3 ) * x ( p2 h3 )_x * i1 ( h3 h1 )_f 69 IMPLICIT NONE 70#include "global.fh" 71#include "mafdecls.fh" 72#include "sym.fh" 73#include "errquit.fh" 74#include "tce.fh" 75 INTEGER d_a 76 INTEGER k_a_offset 77 INTEGER d_b 78 INTEGER k_b_offset 79 INTEGER d_c 80 INTEGER k_c_offset 81 INTEGER NXTASK 82 INTEGER next 83 INTEGER nprocs 84 INTEGER count 85 INTEGER p2b 86 INTEGER h1b 87 INTEGER dimc 88 INTEGER l_c_sort 89 INTEGER k_c_sort 90 INTEGER h3b 91 INTEGER p2b_1 92 INTEGER h3b_1 93 INTEGER h3b_2 94 INTEGER h1b_2 95 INTEGER dim_common 96 INTEGER dima_sort 97 INTEGER dima 98 INTEGER dimb_sort 99 INTEGER dimb 100 INTEGER l_a_sort 101 INTEGER k_a_sort 102 INTEGER l_a 103 INTEGER k_a 104 INTEGER l_b_sort 105 INTEGER k_b_sort 106 INTEGER l_b 107 INTEGER k_b 108 INTEGER l_c 109 INTEGER k_c 110 EXTERNAL NXTASK 111 nprocs = GA_NNODES() 112 count = 0 113 next = NXTASK(nprocs,1) 114 DO p2b = noab+1,noab+nvab 115 DO h1b = 1,noab 116 IF (next.eq.count) THEN 117 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 118 &).ne.4)) THEN 119 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 120 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 121 &x,irrep_f)) THEN 122 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 123 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 124 & ERRQUIT('eomccsd_o1_1',0,MA_ERR) 125 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 126 DO h3b = 1,noab 127 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h3b-1)) THEN 128 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH 129 &EN 130 CALL TCE_RESTRICTED_2(p2b,h3b,p2b_1,h3b_1) 131 CALL TCE_RESTRICTED_2(h3b,h1b,h3b_2,h1b_2) 132 dim_common = int_mb(k_range+h3b-1) 133 dima_sort = int_mb(k_range+p2b-1) 134 dima = dim_common * dima_sort 135 dimb_sort = int_mb(k_range+h1b-1) 136 dimb = dim_common * dimb_sort 137 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 138 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 139 & ERRQUIT('eomccsd_o1_1',1,MA_ERR) 140 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 141 &eomccsd_o1_1',2,MA_ERR) 142 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 143 & - 1 + noab * (p2b_1 - noab - 1))) 144 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 145 &,int_mb(k_range+h3b-1),1,2,1.0d0) 146 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_o1_1',3,MA_ERR) 147 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 148 & ERRQUIT('eomccsd_o1_1',4,MA_ERR) 149 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 150 &eomccsd_o1_1',5,MA_ERR) 151 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 152 & - 1 + noab * (h3b_2 - 1))) 153 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 154 &,int_mb(k_range+h1b-1),2,1,1.0d0) 155 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_o1_1',6,MA_ERR) 156 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 157 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 158 &t),dima_sort) 159 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_o1_1',7,MA_ 160 &ERR) 161 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_o1_1',8,MA_ 162 &ERR) 163 END IF 164 END IF 165 END IF 166 END DO 167 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 168 &eomccsd_o1_1',9,MA_ERR) 169 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 170 &,int_mb(k_range+p2b-1),2,1,-1.0d0) 171 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 172 & 1 + noab * (p2b - noab - 1))) 173 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_o1_1',10,MA_ERR) 174 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_o1_1',11,MA 175 &_ERR) 176 END IF 177 END IF 178 END IF 179 next = NXTASK(nprocs,1) 180 END IF 181 count = count + 1 182 END DO 183 END DO 184 next = NXTASK(-nprocs,1) 185 call GA_SYNC() 186 RETURN 187 END 188 SUBROUTINE eomccsd_o1_1_1(d_a,k_a_offset,d_c,k_c_offset) 189C $Id$ 190C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 191C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 192C i1 ( h3 h1 )_f + = 1 * f ( h3 h1 )_f 193 IMPLICIT NONE 194#include "global.fh" 195#include "mafdecls.fh" 196#include "sym.fh" 197#include "errquit.fh" 198#include "tce.fh" 199 INTEGER d_a 200 INTEGER k_a_offset 201 INTEGER d_c 202 INTEGER k_c_offset 203 INTEGER NXTASK 204 INTEGER next 205 INTEGER nprocs 206 INTEGER count 207 INTEGER h3b 208 INTEGER h1b 209 INTEGER dimc 210 INTEGER h3b_1 211 INTEGER h1b_1 212 INTEGER dim_common 213 INTEGER dima_sort 214 INTEGER dima 215 INTEGER l_a_sort 216 INTEGER k_a_sort 217 INTEGER l_a 218 INTEGER k_a 219 INTEGER l_c 220 INTEGER k_c 221 EXTERNAL NXTASK 222 nprocs = GA_NNODES() 223 count = 0 224 next = NXTASK(nprocs,1) 225 DO h3b = 1,noab 226 DO h1b = 1,noab 227 IF (next.eq.count) THEN 228 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h1b-1 229 &).ne.4)) THEN 230 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 231 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 232 &EN 233 dimc = int_mb(k_range+h3b-1) * int_mb(k_range+h1b-1) 234 CALL TCE_RESTRICTED_2(h3b,h1b,h3b_1,h1b_1) 235 dim_common = 1 236 dima_sort = int_mb(k_range+h3b-1) * int_mb(k_range+h1b-1) 237 dima = dim_common * dima_sort 238 IF (dima .gt. 0) THEN 239 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 240 & ERRQUIT('eomccsd_o1_1_1',0,MA_ERR) 241 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 242 &eomccsd_o1_1_1',1,MA_ERR) 243 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 244 & - 1 + (noab+nvab) * (h3b_1 - 1))) 245 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1) 246 &,int_mb(k_range+h1b-1),2,1,1.0d0) 247 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_o1_1_1',2,MA_ERR 248 &) 249 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 250 &eomccsd_o1_1_1',3,MA_ERR) 251 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 252 &,int_mb(k_range+h3b-1),2,1,1.0d0) 253 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 254 & 1 + noab * (h3b - 1))) 255 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_o1_1_1',4,MA_ERR 256 &) 257 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_o1_1_1',5,M 258 &A_ERR) 259 END IF 260 END IF 261 END IF 262 END IF 263 next = NXTASK(nprocs,1) 264 END IF 265 count = count + 1 266 END DO 267 END DO 268 next = NXTASK(-nprocs,1) 269 call GA_SYNC() 270 RETURN 271 END 272 SUBROUTINE OFFSET_eomccsd_o1_1_1(l_a_offset,k_a_offset,size) 273C $Id$ 274C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 275C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 276C i1 ( h3 h1 )_f 277 IMPLICIT NONE 278#include "global.fh" 279#include "mafdecls.fh" 280#include "sym.fh" 281#include "errquit.fh" 282#include "tce.fh" 283 INTEGER l_a_offset 284 INTEGER k_a_offset 285 INTEGER size 286 INTEGER length 287 INTEGER addr 288 INTEGER h3b 289 INTEGER h1b 290 length = 0 291 DO h3b = 1,noab 292 DO h1b = 1,noab 293 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 294 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 295 &EN 296 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h1b-1 297 &).ne.4)) THEN 298 length = length + 1 299 END IF 300 END IF 301 END IF 302 END DO 303 END DO 304 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 305 &set)) CALL ERRQUIT('eomccsd_o1_1_1',0,MA_ERR) 306 int_mb(k_a_offset) = length 307 addr = 0 308 size = 0 309 DO h3b = 1,noab 310 DO h1b = 1,noab 311 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 312 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH 313 &EN 314 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h1b-1 315 &).ne.4)) THEN 316 addr = addr + 1 317 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h3b - 1) 318 int_mb(k_a_offset+length+addr) = size 319 size = size + int_mb(k_range+h3b-1) * int_mb(k_range+h1b-1) 320 END IF 321 END IF 322 END IF 323 END DO 324 END DO 325 RETURN 326 END 327 SUBROUTINE eomccsd_o1_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_of 328 &fset) 329C $Id$ 330C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 331C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 332C i1 ( h3 h1 )_ft + = 1 * Sum ( p4 ) * t ( p4 h1 )_t * f ( h3 p4 )_f 333 IMPLICIT NONE 334#include "global.fh" 335#include "mafdecls.fh" 336#include "sym.fh" 337#include "errquit.fh" 338#include "tce.fh" 339 INTEGER d_a 340 INTEGER k_a_offset 341 INTEGER d_b 342 INTEGER k_b_offset 343 INTEGER d_c 344 INTEGER k_c_offset 345 INTEGER NXTASK 346 INTEGER next 347 INTEGER nprocs 348 INTEGER count 349 INTEGER h3b 350 INTEGER h1b 351 INTEGER dimc 352 INTEGER l_c_sort 353 INTEGER k_c_sort 354 INTEGER p4b 355 INTEGER p4b_1 356 INTEGER h1b_1 357 INTEGER h3b_2 358 INTEGER p4b_2 359 INTEGER dim_common 360 INTEGER dima_sort 361 INTEGER dima 362 INTEGER dimb_sort 363 INTEGER dimb 364 INTEGER l_a_sort 365 INTEGER k_a_sort 366 INTEGER l_a 367 INTEGER k_a 368 INTEGER l_b_sort 369 INTEGER k_b_sort 370 INTEGER l_b 371 INTEGER k_b 372 INTEGER l_c 373 INTEGER k_c 374 EXTERNAL NXTASK 375 nprocs = GA_NNODES() 376 count = 0 377 next = NXTASK(nprocs,1) 378 DO h3b = 1,noab 379 DO h1b = 1,noab 380 IF (next.eq.count) THEN 381 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h1b-1 382 &).ne.4)) THEN 383 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 384 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 385 &f,irrep_t)) THEN 386 dimc = int_mb(k_range+h3b-1) * int_mb(k_range+h1b-1) 387 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 388 & ERRQUIT('eomccsd_o1_1_2',0,MA_ERR) 389 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 390 DO p4b = noab+1,noab+nvab 391 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h1b-1)) THEN 392 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 393 &EN 394 CALL TCE_RESTRICTED_2(p4b,h1b,p4b_1,h1b_1) 395 CALL TCE_RESTRICTED_2(h3b,p4b,h3b_2,p4b_2) 396 dim_common = int_mb(k_range+p4b-1) 397 dima_sort = int_mb(k_range+h1b-1) 398 dima = dim_common * dima_sort 399 dimb_sort = int_mb(k_range+h3b-1) 400 dimb = dim_common * dimb_sort 401 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 402 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 403 & ERRQUIT('eomccsd_o1_1_2',1,MA_ERR) 404 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 405 &eomccsd_o1_1_2',2,MA_ERR) 406 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 407 & - 1 + noab * (p4b_1 - noab - 1))) 408 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 409 &,int_mb(k_range+h1b-1),2,1,1.0d0) 410 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_o1_1_2',3,MA_ERR 411 &) 412 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 413 & ERRQUIT('eomccsd_o1_1_2',4,MA_ERR) 414 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 415 &eomccsd_o1_1_2',5,MA_ERR) 416 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 417 & - 1 + (noab+nvab) * (h3b_2 - 1))) 418 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 419 &,int_mb(k_range+p4b-1),1,2,1.0d0) 420 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_o1_1_2',6,MA_ERR 421 &) 422 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 423 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 424 &t),dima_sort) 425 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_o1_1_2',7,M 426 &A_ERR) 427 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_o1_1_2',8,M 428 &A_ERR) 429 END IF 430 END IF 431 END IF 432 END DO 433 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 434 &eomccsd_o1_1_2',9,MA_ERR) 435 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 436 &,int_mb(k_range+h1b-1),1,2,1.0d0) 437 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 438 & 1 + noab * (h3b - 1))) 439 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_o1_1_2',10,MA_ER 440 &R) 441 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_o1_1_2',11, 442 &MA_ERR) 443 END IF 444 END IF 445 END IF 446 next = NXTASK(nprocs,1) 447 END IF 448 count = count + 1 449 END DO 450 END DO 451 next = NXTASK(-nprocs,1) 452 call GA_SYNC() 453 RETURN 454 END 455 SUBROUTINE eomccsd_o1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offs 456 &et) 457C $Id$ 458C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 459C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 460C i0 ( p2 h1 )_xf + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * f ( p2 p3 )_f 461 IMPLICIT NONE 462#include "global.fh" 463#include "mafdecls.fh" 464#include "sym.fh" 465#include "errquit.fh" 466#include "tce.fh" 467 INTEGER d_a 468 INTEGER k_a_offset 469 INTEGER d_b 470 INTEGER k_b_offset 471 INTEGER d_c 472 INTEGER k_c_offset 473 INTEGER NXTASK 474 INTEGER next 475 INTEGER nprocs 476 INTEGER count 477 INTEGER p2b 478 INTEGER h1b 479 INTEGER dimc 480 INTEGER l_c_sort 481 INTEGER k_c_sort 482 INTEGER p3b 483 INTEGER p3b_1 484 INTEGER h1b_1 485 INTEGER p2b_2 486 INTEGER p3b_2 487 INTEGER dim_common 488 INTEGER dima_sort 489 INTEGER dima 490 INTEGER dimb_sort 491 INTEGER dimb 492 INTEGER l_a_sort 493 INTEGER k_a_sort 494 INTEGER l_a 495 INTEGER k_a 496 INTEGER l_b_sort 497 INTEGER k_b_sort 498 INTEGER l_b 499 INTEGER k_b 500 INTEGER l_c 501 INTEGER k_c 502 EXTERNAL NXTASK 503 nprocs = GA_NNODES() 504 count = 0 505 next = NXTASK(nprocs,1) 506 DO p2b = noab+1,noab+nvab 507 DO h1b = 1,noab 508 IF (next.eq.count) THEN 509 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 510 &).ne.4)) THEN 511 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 512 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 513 &x,irrep_f)) THEN 514 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 515 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 516 & ERRQUIT('eomccsd_o1_2',0,MA_ERR) 517 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 518 DO p3b = noab+1,noab+nvab 519 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 520 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH 521 &EN 522 CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1) 523 CALL TCE_RESTRICTED_2(p2b,p3b,p2b_2,p3b_2) 524 dim_common = int_mb(k_range+p3b-1) 525 dima_sort = int_mb(k_range+h1b-1) 526 dima = dim_common * dima_sort 527 dimb_sort = int_mb(k_range+p2b-1) 528 dimb = dim_common * dimb_sort 529 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 530 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 531 & ERRQUIT('eomccsd_o1_2',1,MA_ERR) 532 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 533 &eomccsd_o1_2',2,MA_ERR) 534 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 535 & - 1 + noab * (p3b_1 - noab - 1))) 536 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 537 &,int_mb(k_range+h1b-1),2,1,1.0d0) 538 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_o1_2',3,MA_ERR) 539 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 540 & ERRQUIT('eomccsd_o1_2',4,MA_ERR) 541 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 542 &eomccsd_o1_2',5,MA_ERR) 543 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 544 & - 1 + (noab+nvab) * (p2b_2 - 1))) 545 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1) 546 &,int_mb(k_range+p3b-1),1,2,1.0d0) 547 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_o1_2',6,MA_ERR) 548 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 549 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 550 &t),dima_sort) 551 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_o1_2',7,MA_ 552 &ERR) 553 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_o1_2',8,MA_ 554 &ERR) 555 END IF 556 END IF 557 END IF 558 END DO 559 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 560 &eomccsd_o1_2',9,MA_ERR) 561 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1) 562 &,int_mb(k_range+h1b-1),1,2,1.0d0) 563 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 564 & 1 + noab * (p2b - noab - 1))) 565 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_o1_2',10,MA_ERR) 566 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_o1_2',11,MA 567 &_ERR) 568 END IF 569 END IF 570 END IF 571 next = NXTASK(nprocs,1) 572 END IF 573 count = count + 1 574 END DO 575 END DO 576 next = NXTASK(-nprocs,1) 577 call GA_SYNC() 578 RETURN 579 END 580 SUBROUTINE eomccsd_o1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offs 581 &et) 582C $Id$ 583C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 584C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 585C i0 ( p2 h1 )_xf + = 1 * Sum ( p4 h3 ) * x ( p2 p4 h1 h3 )_x * f ( h3 p4 )_f 586 IMPLICIT NONE 587#include "global.fh" 588#include "mafdecls.fh" 589#include "sym.fh" 590#include "errquit.fh" 591#include "tce.fh" 592 INTEGER d_a 593 INTEGER k_a_offset 594 INTEGER d_b 595 INTEGER k_b_offset 596 INTEGER d_c 597 INTEGER k_c_offset 598 INTEGER NXTASK 599 INTEGER next 600 INTEGER nprocs 601 INTEGER count 602 INTEGER p2b 603 INTEGER h1b 604 INTEGER dimc 605 INTEGER l_c_sort 606 INTEGER k_c_sort 607 INTEGER p4b 608 INTEGER h3b 609 INTEGER p2b_1 610 INTEGER p4b_1 611 INTEGER h1b_1 612 INTEGER h3b_1 613 INTEGER h3b_2 614 INTEGER p4b_2 615 INTEGER dim_common 616 INTEGER dima_sort 617 INTEGER dima 618 INTEGER dimb_sort 619 INTEGER dimb 620 INTEGER l_a_sort 621 INTEGER k_a_sort 622 INTEGER l_a 623 INTEGER k_a 624 INTEGER l_b_sort 625 INTEGER k_b_sort 626 INTEGER l_b 627 INTEGER k_b 628 INTEGER l_c 629 INTEGER k_c 630 EXTERNAL NXTASK 631 nprocs = GA_NNODES() 632 count = 0 633 next = NXTASK(nprocs,1) 634 DO p2b = noab+1,noab+nvab 635 DO h1b = 1,noab 636 IF (next.eq.count) THEN 637 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 638 &).ne.4)) THEN 639 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 640 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 641 &x,irrep_f)) THEN 642 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 643 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 644 & ERRQUIT('eomccsd_o1_3',0,MA_ERR) 645 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 646 DO p4b = noab+1,noab+nvab 647 DO h3b = 1,noab 648 IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 649 &1b-1)+int_mb(k_spin+h3b-1)) THEN 650 IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 651 &k_sym+h1b-1),int_mb(k_sym+h3b-1)))) .eq. irrep_x) THEN 652 CALL TCE_RESTRICTED_4(p2b,p4b,h1b,h3b,p2b_1,p4b_1,h1b_1,h3b_1) 653 CALL TCE_RESTRICTED_2(h3b,p4b,h3b_2,p4b_2) 654 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h3b-1) 655 dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 656 dima = dim_common * dima_sort 657 dimb_sort = 1 658 dimb = dim_common * dimb_sort 659 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 660 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 661 & ERRQUIT('eomccsd_o1_3',1,MA_ERR) 662 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 663 &eomccsd_o1_3',2,MA_ERR) 664 IF ((p4b .lt. p2b) .and. (h3b .lt. h1b)) THEN 665 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 666 & - 1 + noab * (h3b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p4b_ 667 &1 - noab - 1))))) 668 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 669 &,int_mb(k_range+p2b-1),int_mb(k_range+h3b-1),int_mb(k_range+h1b-1) 670 &,4,2,3,1,1.0d0) 671 END IF 672 IF ((p4b .lt. p2b) .and. (h1b .le. h3b)) THEN 673 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 674 & - 1 + noab * (h1b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p4b_ 675 &1 - noab - 1))))) 676 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 677 &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+h3b-1) 678 &,3,2,4,1,-1.0d0) 679 END IF 680 IF ((p2b .le. p4b) .and. (h3b .lt. h1b)) THEN 681 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 682 & - 1 + noab * (h3b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p2b_ 683 &1 - noab - 1))))) 684 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 685 &,int_mb(k_range+p4b-1),int_mb(k_range+h3b-1),int_mb(k_range+h1b-1) 686 &,4,1,3,2,-1.0d0) 687 END IF 688 IF ((p2b .le. p4b) .and. (h1b .le. h3b)) THEN 689 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 690 & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p2b_ 691 &1 - noab - 1))))) 692 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 693 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h3b-1) 694 &,3,1,4,2,1.0d0) 695 END IF 696 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_o1_3',3,MA_ERR) 697 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 698 & ERRQUIT('eomccsd_o1_3',4,MA_ERR) 699 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 700 &eomccsd_o1_3',5,MA_ERR) 701 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 702 & - 1 + (noab+nvab) * (h3b_2 - 1))) 703 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 704 &,int_mb(k_range+p4b-1),1,2,1.0d0) 705 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_o1_3',6,MA_ERR) 706 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 707 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 708 &t),dima_sort) 709 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_o1_3',7,MA_ 710 &ERR) 711 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_o1_3',8,MA_ 712 &ERR) 713 END IF 714 END IF 715 END IF 716 END DO 717 END DO 718 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 719 &eomccsd_o1_3',9,MA_ERR) 720 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 721 &,int_mb(k_range+p2b-1),2,1,1.0d0) 722 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 723 & 1 + noab * (p2b - noab - 1))) 724 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_o1_3',10,MA_ERR) 725 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_o1_3',11,MA 726 &_ERR) 727 END IF 728 END IF 729 END IF 730 next = NXTASK(nprocs,1) 731 END IF 732 count = count + 1 733 END DO 734 END DO 735 next = NXTASK(-nprocs,1) 736 call GA_SYNC() 737 RETURN 738 END 739 SUBROUTINE eomccsd_o1_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offs 740 &et) 741C $Id$ 742C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 743C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 744C i0 ( p2 h1 )_fxt + = -1 * Sum ( h3 ) * t ( p2 h3 )_t * i1 ( h3 h1 )_fx 745 IMPLICIT NONE 746#include "global.fh" 747#include "mafdecls.fh" 748#include "sym.fh" 749#include "errquit.fh" 750#include "tce.fh" 751 INTEGER d_a 752 INTEGER k_a_offset 753 INTEGER d_b 754 INTEGER k_b_offset 755 INTEGER d_c 756 INTEGER k_c_offset 757 INTEGER NXTASK 758 INTEGER next 759 INTEGER nprocs 760 INTEGER count 761 INTEGER p2b 762 INTEGER h1b 763 INTEGER dimc 764 INTEGER l_c_sort 765 INTEGER k_c_sort 766 INTEGER h3b 767 INTEGER p2b_1 768 INTEGER h3b_1 769 INTEGER h3b_2 770 INTEGER h1b_2 771 INTEGER dim_common 772 INTEGER dima_sort 773 INTEGER dima 774 INTEGER dimb_sort 775 INTEGER dimb 776 INTEGER l_a_sort 777 INTEGER k_a_sort 778 INTEGER l_a 779 INTEGER k_a 780 INTEGER l_b_sort 781 INTEGER k_b_sort 782 INTEGER l_b 783 INTEGER k_b 784 INTEGER l_c 785 INTEGER k_c 786 EXTERNAL NXTASK 787 nprocs = GA_NNODES() 788 count = 0 789 next = NXTASK(nprocs,1) 790 DO p2b = noab+1,noab+nvab 791 DO h1b = 1,noab 792 IF (next.eq.count) THEN 793 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 794 &).ne.4)) THEN 795 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 796 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 797 &f,ieor(irrep_x,irrep_t))) THEN 798 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 799 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 800 & ERRQUIT('eomccsd_o1_4',0,MA_ERR) 801 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 802 DO h3b = 1,noab 803 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h3b-1)) THEN 804 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h3b-1)) .eq. irrep_t) TH 805 &EN 806 CALL TCE_RESTRICTED_2(p2b,h3b,p2b_1,h3b_1) 807 CALL TCE_RESTRICTED_2(h3b,h1b,h3b_2,h1b_2) 808 dim_common = int_mb(k_range+h3b-1) 809 dima_sort = int_mb(k_range+p2b-1) 810 dima = dim_common * dima_sort 811 dimb_sort = int_mb(k_range+h1b-1) 812 dimb = dim_common * dimb_sort 813 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 814 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 815 & ERRQUIT('eomccsd_o1_4',1,MA_ERR) 816 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 817 &eomccsd_o1_4',2,MA_ERR) 818 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 819 & - 1 + noab * (p2b_1 - noab - 1))) 820 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 821 &,int_mb(k_range+h3b-1),1,2,1.0d0) 822 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_o1_4',3,MA_ERR) 823 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 824 & ERRQUIT('eomccsd_o1_4',4,MA_ERR) 825 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 826 &eomccsd_o1_4',5,MA_ERR) 827 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 828 & - 1 + noab * (h3b_2 - 1))) 829 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 830 &,int_mb(k_range+h1b-1),2,1,1.0d0) 831 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_o1_4',6,MA_ERR) 832 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 833 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 834 &t),dima_sort) 835 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_o1_4',7,MA_ 836 &ERR) 837 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_o1_4',8,MA_ 838 &ERR) 839 END IF 840 END IF 841 END IF 842 END DO 843 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 844 &eomccsd_o1_4',9,MA_ERR) 845 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 846 &,int_mb(k_range+p2b-1),2,1,-1.0d0) 847 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 848 & 1 + noab * (p2b - noab - 1))) 849 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_o1_4',10,MA_ERR) 850 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_o1_4',11,MA 851 &_ERR) 852 END IF 853 END IF 854 END IF 855 next = NXTASK(nprocs,1) 856 END IF 857 count = count + 1 858 END DO 859 END DO 860 next = NXTASK(-nprocs,1) 861 call GA_SYNC() 862 RETURN 863 END 864 SUBROUTINE eomccsd_o1_4_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_of 865 &fset) 866C $Id$ 867C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 868C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 869C i1 ( h3 h1 )_fx + = 1 * Sum ( p4 ) * x ( p4 h1 )_x * f ( h3 p4 )_f 870 IMPLICIT NONE 871#include "global.fh" 872#include "mafdecls.fh" 873#include "sym.fh" 874#include "errquit.fh" 875#include "tce.fh" 876 INTEGER d_a 877 INTEGER k_a_offset 878 INTEGER d_b 879 INTEGER k_b_offset 880 INTEGER d_c 881 INTEGER k_c_offset 882 INTEGER NXTASK 883 INTEGER next 884 INTEGER nprocs 885 INTEGER count 886 INTEGER h3b 887 INTEGER h1b 888 INTEGER dimc 889 INTEGER l_c_sort 890 INTEGER k_c_sort 891 INTEGER p4b 892 INTEGER p4b_1 893 INTEGER h1b_1 894 INTEGER h3b_2 895 INTEGER p4b_2 896 INTEGER dim_common 897 INTEGER dima_sort 898 INTEGER dima 899 INTEGER dimb_sort 900 INTEGER dimb 901 INTEGER l_a_sort 902 INTEGER k_a_sort 903 INTEGER l_a 904 INTEGER k_a 905 INTEGER l_b_sort 906 INTEGER k_b_sort 907 INTEGER l_b 908 INTEGER k_b 909 INTEGER l_c 910 INTEGER k_c 911 EXTERNAL NXTASK 912 nprocs = GA_NNODES() 913 count = 0 914 next = NXTASK(nprocs,1) 915 DO h3b = 1,noab 916 DO h1b = 1,noab 917 IF (next.eq.count) THEN 918 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h1b-1 919 &).ne.4)) THEN 920 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 921 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 922 &f,irrep_x)) THEN 923 dimc = int_mb(k_range+h3b-1) * int_mb(k_range+h1b-1) 924 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 925 & ERRQUIT('eomccsd_o1_4_1',0,MA_ERR) 926 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 927 DO p4b = noab+1,noab+nvab 928 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h1b-1)) THEN 929 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH 930 &EN 931 CALL TCE_RESTRICTED_2(p4b,h1b,p4b_1,h1b_1) 932 CALL TCE_RESTRICTED_2(h3b,p4b,h3b_2,p4b_2) 933 dim_common = int_mb(k_range+p4b-1) 934 dima_sort = int_mb(k_range+h1b-1) 935 dima = dim_common * dima_sort 936 dimb_sort = int_mb(k_range+h3b-1) 937 dimb = dim_common * dimb_sort 938 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 939 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 940 & ERRQUIT('eomccsd_o1_4_1',1,MA_ERR) 941 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 942 &eomccsd_o1_4_1',2,MA_ERR) 943 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 944 & - 1 + noab * (p4b_1 - noab - 1))) 945 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 946 &,int_mb(k_range+h1b-1),2,1,1.0d0) 947 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsd_o1_4_1',3,MA_ERR 948 &) 949 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 950 & ERRQUIT('eomccsd_o1_4_1',4,MA_ERR) 951 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 952 &eomccsd_o1_4_1',5,MA_ERR) 953 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 954 & - 1 + (noab+nvab) * (h3b_2 - 1))) 955 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 956 &,int_mb(k_range+p4b-1),1,2,1.0d0) 957 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsd_o1_4_1',6,MA_ERR 958 &) 959 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 960 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 961 &t),dima_sort) 962 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsd_o1_4_1',7,M 963 &A_ERR) 964 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsd_o1_4_1',8,M 965 &A_ERR) 966 END IF 967 END IF 968 END IF 969 END DO 970 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 971 &eomccsd_o1_4_1',9,MA_ERR) 972 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h3b-1) 973 &,int_mb(k_range+h1b-1),1,2,1.0d0) 974 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 975 & 1 + noab * (h3b - 1))) 976 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsd_o1_4_1',10,MA_ER 977 &R) 978 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsd_o1_4_1',11, 979 &MA_ERR) 980 END IF 981 END IF 982 END IF 983 next = NXTASK(nprocs,1) 984 END IF 985 count = count + 1 986 END DO 987 END DO 988 next = NXTASK(-nprocs,1) 989 call GA_SYNC() 990 RETURN 991 END 992 SUBROUTINE OFFSET_eomccsd_o1_4_1(l_a_offset,k_a_offset,size) 993C $Id$ 994C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 995C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 996C i1 ( h3 h1 )_fx 997 IMPLICIT NONE 998#include "global.fh" 999#include "mafdecls.fh" 1000#include "sym.fh" 1001#include "errquit.fh" 1002#include "tce.fh" 1003 INTEGER l_a_offset 1004 INTEGER k_a_offset 1005 INTEGER size 1006 INTEGER length 1007 INTEGER addr 1008 INTEGER h3b 1009 INTEGER h1b 1010 length = 0 1011 DO h3b = 1,noab 1012 DO h1b = 1,noab 1013 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1014 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1015 &f,irrep_x)) THEN 1016 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h1b-1 1017 &).ne.4)) THEN 1018 length = length + 1 1019 END IF 1020 END IF 1021 END IF 1022 END DO 1023 END DO 1024 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1025 &set)) CALL ERRQUIT('eomccsd_o1_4_1',0,MA_ERR) 1026 int_mb(k_a_offset) = length 1027 addr = 0 1028 size = 0 1029 DO h3b = 1,noab 1030 DO h1b = 1,noab 1031 IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1032 IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 1033 &f,irrep_x)) THEN 1034 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h1b-1 1035 &).ne.4)) THEN 1036 addr = addr + 1 1037 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h3b - 1) 1038 int_mb(k_a_offset+length+addr) = size 1039 size = size + int_mb(k_range+h3b-1) * int_mb(k_range+h1b-1) 1040 END IF 1041 END IF 1042 END IF 1043 END DO 1044 END DO 1045 RETURN 1046 END 1047