1 SUBROUTINE nr0(d_f1,d_i0,d_t1,d_v2,d_x1,d_x2,k_f1_offset,k_i0_offs 2 &et,k_t1_offset,k_v2_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 ( )_xf + = 1 * Sum ( p2 h1 ) * x ( p2 h1 )_x * f ( h1 p2 )_f 7C i0 ( )_xv + = 1/4 * Sum ( p3 p4 h1 h2 ) * x ( p3 p4 h1 h2 )_x * v ( h1 h2 p3 p4 )_v 8C i0 ( )_vxt + = 1 * Sum ( h2 p1 ) * t ( p1 h2 )_t * i1 ( h2 p1 )_vx 9C i1 ( h2 p1 )_vx + = 1 * Sum ( h3 p4 ) * x ( p4 h3 )_x * v ( h2 h3 p1 p4 )_v 10 IMPLICIT NONE 11#include "global.fh" 12#include "mafdecls.fh" 13#include "util.fh" 14#include "errquit.fh" 15#include "tce.fh" 16 INTEGER d_i0 17 INTEGER k_i0_offset 18 INTEGER d_x1 19 INTEGER k_x1_offset 20 INTEGER d_f1 21 INTEGER k_f1_offset 22 INTEGER d_x2 23 INTEGER k_x2_offset 24 INTEGER d_v2 25 INTEGER k_v2_offset 26 INTEGER d_t1 27 INTEGER k_t1_offset 28 INTEGER d_i1 29 INTEGER k_i1_offset 30 INTEGER l_i1_offset 31 INTEGER size_i1 32 CHARACTER*255 filename 33 CALL nr0_1(d_x1,k_x1_offset,d_f1,k_f1_offset,d_i0,k_i0_offset) 34 CALL nr0_2(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i0,k_i0_offset) 35 CALL OFFSET_nr0_3_1(l_i1_offset,k_i1_offset,size_i1) 36 CALL TCE_FILENAME('nr0_3_1_i1',filename) 37 CALL CREATEFILE(filename,d_i1,size_i1) 38 CALL nr0_3_1(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset) 39 CALL RECONCILEFILE(d_i1,size_i1) 40 CALL nr0_3(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset) 41 CALL DELETEFILE(d_i1) 42 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('nr0',-1,MA_ERR) 43 RETURN 44 END 45 SUBROUTINE nr0_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 46C $Id$ 47C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 48C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 49C i0 ( )_xf + = 1 * Sum ( p2 h1 ) * x ( p2 h1 )_x * f ( h1 p2 )_f 50 IMPLICIT NONE 51#include "global.fh" 52#include "mafdecls.fh" 53#include "sym.fh" 54#include "errquit.fh" 55#include "tce.fh" 56 INTEGER d_a 57 INTEGER k_a_offset 58 INTEGER d_b 59 INTEGER k_b_offset 60 INTEGER d_c 61 INTEGER k_c_offset 62 INTEGER nxtask 63 INTEGER next 64 INTEGER nprocs 65 INTEGER count 66 INTEGER dimc 67 INTEGER l_c_sort 68 INTEGER k_c_sort 69 INTEGER p2b 70 INTEGER h1b 71 INTEGER p2b_1 72 INTEGER h1b_1 73 INTEGER h1b_2 74 INTEGER p2b_2 75 INTEGER dim_common 76 INTEGER dima_sort 77 INTEGER dima 78 INTEGER dimb_sort 79 INTEGER dimb 80 INTEGER l_a_sort 81 INTEGER k_a_sort 82 INTEGER l_a 83 INTEGER k_a 84 INTEGER l_b_sort 85 INTEGER k_b_sort 86 INTEGER l_b 87 INTEGER k_b 88 INTEGER l_c 89 INTEGER k_c 90 EXTERNAL nxtask 91 nprocs = GA_NNODES() 92 count = 0 93 next = nxtask(nprocs,1) 94 IF (next.eq.count) THEN 95 IF (0 .eq. ieor(irrep_x,irrep_f)) THEN 96 dimc = 1 97 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 98 & ERRQUIT('nr0_1',0,MA_ERR) 99 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 100 DO p2b = noab+1,noab+nvab 101 DO h1b = 1,noab 102 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 103 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH 104 &EN 105 CALL TCE_RESTRICTED_2(p2b,h1b,p2b_1,h1b_1) 106 CALL TCE_RESTRICTED_2(h1b,p2b,h1b_2,p2b_2) 107 dim_common = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 108 dima_sort = 1 109 dima = dim_common * dima_sort 110 dimb_sort = 1 111 dimb = dim_common * dimb_sort 112 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 113 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 114 & ERRQUIT('nr0_1',1,MA_ERR) 115 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 116 &nr0_1',2,MA_ERR) 117 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 118 & - 1 + noab * (p2b_1 - noab - 1))) 119 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 120 &,int_mb(k_range+h1b-1),2,1,1.0d0) 121 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_1',3,MA_ERR) 122 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 123 & ERRQUIT('nr0_1',4,MA_ERR) 124 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 125 &nr0_1',5,MA_ERR) 126 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 127 & - 1 + (noab+nvab) * (h1b_2 - 1))) 128 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 129 &,int_mb(k_range+p2b-1),1,2,1.0d0) 130 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_1',6,MA_ERR) 131 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 132 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 133 &t),dima_sort) 134 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_1',7,MA_ERR) 135 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_1',8,MA_ERR) 136 END IF 137 END IF 138 END IF 139 END DO 140 END DO 141 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 142 &nr0_1',9,MA_ERR) 143 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 144 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 145 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_1',10,MA_ERR) 146 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_1',11,MA_ERR) 147 END IF 148 next = nxtask(nprocs,1) 149 END IF 150 count = count + 1 151 next = nxtask(-nprocs,1) 152 call GA_SYNC() 153 RETURN 154 END 155 SUBROUTINE nr0_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 156C $Id$ 157C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 158C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 159C i0 ( )_xv + = 1/4 * Sum ( p3 p4 h1 h2 ) * x ( p3 p4 h1 h2 )_x * v ( h1 h2 p3 p4 )_v 160 IMPLICIT NONE 161#include "global.fh" 162#include "mafdecls.fh" 163#include "sym.fh" 164#include "errquit.fh" 165#include "tce.fh" 166 INTEGER d_a 167 INTEGER k_a_offset 168 INTEGER d_b 169 INTEGER k_b_offset 170 INTEGER d_c 171 INTEGER k_c_offset 172 INTEGER nxtask 173 INTEGER next 174 INTEGER nprocs 175 INTEGER count 176 INTEGER dimc 177 INTEGER l_c_sort 178 INTEGER k_c_sort 179 INTEGER p3b 180 INTEGER p4b 181 INTEGER h1b 182 INTEGER h2b 183 INTEGER p3b_1 184 INTEGER p4b_1 185 INTEGER h1b_1 186 INTEGER h2b_1 187 INTEGER h1b_2 188 INTEGER h2b_2 189 INTEGER p3b_2 190 INTEGER p4b_2 191 INTEGER dim_common 192 INTEGER dima_sort 193 INTEGER dima 194 INTEGER dimb_sort 195 INTEGER dimb 196 INTEGER l_a_sort 197 INTEGER k_a_sort 198 INTEGER l_a 199 INTEGER k_a 200 INTEGER l_b_sort 201 INTEGER k_b_sort 202 INTEGER l_b 203 INTEGER k_b 204 INTEGER nsuperp(2) 205 INTEGER isuperp 206 INTEGER nsubh(2) 207 INTEGER isubh 208 INTEGER l_c 209 INTEGER k_c 210 DOUBLE PRECISION FACTORIAL 211 EXTERNAL nxtask 212 EXTERNAL FACTORIAL 213 nprocs = GA_NNODES() 214 count = 0 215 next = nxtask(nprocs,1) 216 IF (next.eq.count) THEN 217 IF (0 .eq. ieor(irrep_x,irrep_v)) THEN 218 dimc = 1 219 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 220 & ERRQUIT('nr0_2',0,MA_ERR) 221 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 222 DO p3b = noab+1,noab+nvab 223 DO p4b = p3b,noab+nvab 224 DO h1b = 1,noab 225 DO h2b = h1b,noab 226 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 227 &1b-1)+int_mb(k_spin+h2b-1)) THEN 228 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 229 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN 230 CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h2b,p3b_1,p4b_1,h1b_1,h2b_1) 231 CALL TCE_RESTRICTED_4(h1b,h2b,p3b,p4b,h1b_2,h2b_2,p3b_2,p4b_2) 232 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m 233 &b(k_range+h1b-1) * int_mb(k_range+h2b-1) 234 dima_sort = 1 235 dima = dim_common * dima_sort 236 dimb_sort = 1 237 dimb = dim_common * dimb_sort 238 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 239 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 240 & ERRQUIT('nr0_2',1,MA_ERR) 241 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 242 &nr0_2',2,MA_ERR) 243 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 244 & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 245 &1 - noab - 1))))) 246 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 247 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 248 &,4,3,2,1,1.0d0) 249 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_2',3,MA_ERR) 250 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 251 & ERRQUIT('nr0_2',4,MA_ERR) 252 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 253 &nr0_2',5,MA_ERR) 254 if(.not.intorb) then 255 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 256 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 257 &+nvab) * (h1b_2 - 1))))) 258 else 259 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 260 &(p4b_2 261 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 262 &+nvab) * (h1b_2 - 1)))),p4b_2,p3b_2,h2b_2,h1b_2) 263 end if 264 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 265 &,int_mb(k_range+h2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 266 &,2,1,4,3,1.0d0) 267 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_2',6,MA_ERR) 268 nsuperp(1) = 1 269 nsuperp(2) = 1 270 isuperp = 1 271 IF (p3b .eq. p4b) THEN 272 nsuperp(isuperp) = nsuperp(isuperp) + 1 273 ELSE 274 isuperp = isuperp + 1 275 END IF 276 nsubh(1) = 1 277 nsubh(2) = 1 278 isubh = 1 279 IF (h1b .eq. h2b) THEN 280 nsubh(isubh) = nsubh(isubh) + 1 281 ELSE 282 isubh = isubh + 1 283 END IF 284 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,4.0d0/FACTORIAL( 285 &nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsubh(1))/FACTORIAL(ns 286 &ubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k_b_sort),dim_common,1. 287 &0d0,dbl_mb(k_c_sort),dima_sort) 288 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_2',7,MA_ERR) 289 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_2',8,MA_ERR) 290 END IF 291 END IF 292 END IF 293 END DO 294 END DO 295 END DO 296 END DO 297 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 298 &nr0_2',9,MA_ERR) 299 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0/4.0d0) 300 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 301 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_2',10,MA_ERR) 302 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_2',11,MA_ERR) 303 END IF 304 next = nxtask(nprocs,1) 305 END IF 306 count = count + 1 307 next = nxtask(-nprocs,1) 308 call GA_SYNC() 309 RETURN 310 END 311 SUBROUTINE nr0_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 312C $Id$ 313C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 314C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 315C i0 ( )_vxt + = 1 * Sum ( h2 p1 ) * t ( p1 h2 )_t * i1 ( h2 p1 )_vx 316 IMPLICIT NONE 317#include "global.fh" 318#include "mafdecls.fh" 319#include "sym.fh" 320#include "errquit.fh" 321#include "tce.fh" 322 INTEGER d_a 323 INTEGER k_a_offset 324 INTEGER d_b 325 INTEGER k_b_offset 326 INTEGER d_c 327 INTEGER k_c_offset 328 INTEGER nxtask 329 INTEGER next 330 INTEGER nprocs 331 INTEGER count 332 INTEGER dimc 333 INTEGER l_c_sort 334 INTEGER k_c_sort 335 INTEGER p1b 336 INTEGER h2b 337 INTEGER p1b_1 338 INTEGER h2b_1 339 INTEGER h2b_2 340 INTEGER p1b_2 341 INTEGER dim_common 342 INTEGER dima_sort 343 INTEGER dima 344 INTEGER dimb_sort 345 INTEGER dimb 346 INTEGER l_a_sort 347 INTEGER k_a_sort 348 INTEGER l_a 349 INTEGER k_a 350 INTEGER l_b_sort 351 INTEGER k_b_sort 352 INTEGER l_b 353 INTEGER k_b 354 INTEGER l_c 355 INTEGER k_c 356 EXTERNAL nxtask 357 nprocs = GA_NNODES() 358 count = 0 359 next = nxtask(nprocs,1) 360 IF (next.eq.count) THEN 361 IF (0 .eq. ieor(irrep_v,ieor(irrep_x,irrep_t))) THEN 362 dimc = 1 363 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 364 & ERRQUIT('nr0_3',0,MA_ERR) 365 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 366 DO p1b = noab+1,noab+nvab 367 DO h2b = 1,noab 368 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) THEN 369 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)) .eq. irrep_t) TH 370 &EN 371 CALL TCE_RESTRICTED_2(p1b,h2b,p1b_1,h2b_1) 372 CALL TCE_RESTRICTED_2(h2b,p1b,h2b_2,p1b_2) 373 dim_common = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1) 374 dima_sort = 1 375 dima = dim_common * dima_sort 376 dimb_sort = 1 377 dimb = dim_common * dimb_sort 378 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 379 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 380 & ERRQUIT('nr0_3',1,MA_ERR) 381 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 382 &nr0_3',2,MA_ERR) 383 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 384 & - 1 + noab * (p1b_1 - noab - 1))) 385 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 386 &,int_mb(k_range+h2b-1),2,1,1.0d0) 387 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_3',3,MA_ERR) 388 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 389 & ERRQUIT('nr0_3',4,MA_ERR) 390 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 391 &nr0_3',5,MA_ERR) 392 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 393 & - noab - 1 + nvab * (h2b_2 - 1))) 394 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 395 &,int_mb(k_range+p1b-1),1,2,1.0d0) 396 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_3',6,MA_ERR) 397 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 398 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 399 &t),dima_sort) 400 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_3',7,MA_ERR) 401 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_3',8,MA_ERR) 402 END IF 403 END IF 404 END IF 405 END DO 406 END DO 407 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 408 &nr0_3',9,MA_ERR) 409 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 410 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 411 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_3',10,MA_ERR) 412 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_3',11,MA_ERR) 413 END IF 414 next = nxtask(nprocs,1) 415 END IF 416 count = count + 1 417 next = nxtask(-nprocs,1) 418 call GA_SYNC() 419 RETURN 420 END 421 SUBROUTINE nr0_3_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 422C $Id$ 423C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 424C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 425C i1 ( h2 p1 )_vx + = 1 * Sum ( h3 p4 ) * x ( p4 h3 )_x * v ( h2 h3 p1 p4 )_v 426 IMPLICIT NONE 427#include "global.fh" 428#include "mafdecls.fh" 429#include "sym.fh" 430#include "errquit.fh" 431#include "tce.fh" 432 INTEGER d_a 433 INTEGER k_a_offset 434 INTEGER d_b 435 INTEGER k_b_offset 436 INTEGER d_c 437 INTEGER k_c_offset 438 INTEGER nxtask 439 INTEGER next 440 INTEGER nprocs 441 INTEGER count 442 INTEGER h2b 443 INTEGER p1b 444 INTEGER dimc 445 INTEGER l_c_sort 446 INTEGER k_c_sort 447 INTEGER p4b 448 INTEGER h3b 449 INTEGER p4b_1 450 INTEGER h3b_1 451 INTEGER h2b_2 452 INTEGER h3b_2 453 INTEGER p1b_2 454 INTEGER p4b_2 455 INTEGER dim_common 456 INTEGER dima_sort 457 INTEGER dima 458 INTEGER dimb_sort 459 INTEGER dimb 460 INTEGER l_a_sort 461 INTEGER k_a_sort 462 INTEGER l_a 463 INTEGER k_a 464 INTEGER l_b_sort 465 INTEGER k_b_sort 466 INTEGER l_b 467 INTEGER k_b 468 INTEGER l_c 469 INTEGER k_c 470 EXTERNAL nxtask 471 nprocs = GA_NNODES() 472 count = 0 473 next = nxtask(nprocs,1) 474 DO h2b = 1,noab 475 DO p1b = noab+1,noab+nvab 476 IF (next.eq.count) THEN 477 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1 478 &).ne.4)) THEN 479 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 480 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 481 &v,irrep_x)) THEN 482 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 483 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 484 & ERRQUIT('nr0_3_1',0,MA_ERR) 485 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 486 DO p4b = noab+1,noab+nvab 487 DO h3b = 1,noab 488 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h3b-1)) THEN 489 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH 490 &EN 491 CALL TCE_RESTRICTED_2(p4b,h3b,p4b_1,h3b_1) 492 CALL TCE_RESTRICTED_4(h2b,h3b,p1b,p4b,h2b_2,h3b_2,p1b_2,p4b_2) 493 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h3b-1) 494 dima_sort = 1 495 dima = dim_common * dima_sort 496 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 497 dimb = dim_common * dimb_sort 498 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 499 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 500 & ERRQUIT('nr0_3_1',1,MA_ERR) 501 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 502 &nr0_3_1',2,MA_ERR) 503 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 504 & - 1 + noab * (p4b_1 - noab - 1))) 505 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 506 &,int_mb(k_range+h3b-1),2,1,1.0d0) 507 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_3_1',3,MA_ERR) 508 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 509 & ERRQUIT('nr0_3_1',4,MA_ERR) 510 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 511 &nr0_3_1',5,MA_ERR) 512 IF ((h3b .lt. h2b) .and. (p4b .lt. p1b)) THEN 513 if(.not.intorb) then 514 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 515 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 516 &+nvab) * (h3b_2 - 1))))) 517 else 518 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 519 &(p1b_2 520 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 521 &+nvab) * (h3b_2 - 1)))),p1b_2,p4b_2,h2b_2,h3b_2) 522 end if 523 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 524 &,int_mb(k_range+h2b-1),int_mb(k_range+p4b-1),int_mb(k_range+p1b-1) 525 &,4,2,1,3,1.0d0) 526 END IF 527 IF ((h3b .lt. h2b) .and. (p1b .le. p4b)) THEN 528 if(.not.intorb) then 529 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 530 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 531 &+nvab) * (h3b_2 - 1))))) 532 else 533 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 534 &(p4b_2 535 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 536 &+nvab) * (h3b_2 - 1)))),p4b_2,p1b_2,h2b_2,h3b_2) 537 end if 538 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 539 &,int_mb(k_range+h2b-1),int_mb(k_range+p1b-1),int_mb(k_range+p4b-1) 540 &,3,2,1,4,-1.0d0) 541 END IF 542 IF ((h2b .le. h3b) .and. (p4b .lt. p1b)) THEN 543 if(.not.intorb) then 544 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 545 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab 546 &+nvab) * (h2b_2 - 1))))) 547 else 548 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 549 &(p1b_2 550 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab 551 &+nvab) * (h2b_2 - 1)))),p1b_2,p4b_2,h3b_2,h2b_2) 552 end if 553 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 554 &,int_mb(k_range+h3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p1b-1) 555 &,4,1,2,3,-1.0d0) 556 END IF 557 IF ((h2b .le. h3b) .and. (p1b .le. p4b)) THEN 558 if(.not.intorb) then 559 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 560 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab 561 &+nvab) * (h2b_2 - 1))))) 562 else 563 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 564 &(p4b_2 565 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab 566 &+nvab) * (h2b_2 - 1)))),p4b_2,p1b_2,h3b_2,h2b_2) 567 end if 568 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 569 &,int_mb(k_range+h3b-1),int_mb(k_range+p1b-1),int_mb(k_range+p4b-1) 570 &,3,1,2,4,1.0d0) 571 END IF 572 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_3_1',6,MA_ERR) 573 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 574 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 575 &t),dima_sort) 576 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_3_1',7,MA_ERR) 577 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_3_1',8,MA_ERR) 578 END IF 579 END IF 580 END IF 581 END DO 582 END DO 583 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 584 &nr0_3_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('nr0_3_1',10,MA_ERR) 590 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_3_1',11,MA_ERR) 591 END IF 592 END IF 593 END IF 594 next = nxtask(nprocs,1) 595 END IF 596 count = count + 1 597 END DO 598 END DO 599 next = nxtask(-nprocs,1) 600 call GA_SYNC() 601 RETURN 602 END 603 SUBROUTINE OFFSET_nr0_3_1(l_a_offset,k_a_offset,size) 604C $Id$ 605C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 606C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 607C i1 ( h2 p1 )_vx 608 IMPLICIT NONE 609#include "global.fh" 610#include "mafdecls.fh" 611#include "sym.fh" 612#include "errquit.fh" 613#include "tce.fh" 614 INTEGER l_a_offset 615 INTEGER k_a_offset 616 INTEGER size 617 INTEGER length 618 INTEGER addr 619 INTEGER h2b 620 INTEGER p1b 621 length = 0 622 DO h2b = 1,noab 623 DO p1b = noab+1,noab+nvab 624 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 625 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 626 &v,irrep_x)) THEN 627 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1 628 &).ne.4)) THEN 629 length = length + 1 630 END IF 631 END IF 632 END IF 633 END DO 634 END DO 635 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 636 &set)) CALL ERRQUIT('nr0_3_1',0,MA_ERR) 637 int_mb(k_a_offset) = length 638 addr = 0 639 size = 0 640 DO h2b = 1,noab 641 DO p1b = noab+1,noab+nvab 642 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 643 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 644 &v,irrep_x)) THEN 645 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1 646 &).ne.4)) THEN 647 addr = addr + 1 648 int_mb(k_a_offset+addr) = p1b - noab - 1 + nvab * (h2b - 1) 649 int_mb(k_a_offset+length+addr) = size 650 size = size + int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 651 END IF 652 END IF 653 END IF 654 END DO 655 END DO 656 RETURN 657 END 658c 659c 660c 661c 662c 663c 664c 665c 666c 667 SUBROUTINE nr0_act(d_f1,d_i0,d_t1,d_v2,d_x1,d_x2,k_f1_offset, 668 &k_i0_offset,k_t1_offset,k_v2_offset,k_x1_offset,k_x2_offset) 669C $Id$ 670C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 671C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 672C i0 ( )_xf + = 1 * Sum ( p2 h1 ) * x ( p2 h1 )_x * f ( h1 p2 )_f 673C i0 ( )_xv + = 1/4 * Sum ( p3 p4 h1 h2 ) * x ( p3 p4 h1 h2 )_x * v ( h1 h2 p3 p4 )_v 674C i0 ( )_vxt + = 1 * Sum ( h2 p1 ) * t ( p1 h2 )_t * i1 ( h2 p1 )_vx 675C i1 ( h2 p1 )_vx + = 1 * Sum ( h3 p4 ) * x ( p4 h3 )_x * v ( h2 h3 p1 p4 )_v 676 IMPLICIT NONE 677#include "global.fh" 678#include "mafdecls.fh" 679#include "util.fh" 680#include "errquit.fh" 681#include "tce.fh" 682 INTEGER d_i0 683 INTEGER k_i0_offset 684 INTEGER d_x1 685 INTEGER k_x1_offset 686 INTEGER d_f1 687 INTEGER k_f1_offset 688 INTEGER d_x2 689 INTEGER k_x2_offset 690 INTEGER d_v2 691 INTEGER k_v2_offset 692 INTEGER d_t1 693 INTEGER k_t1_offset 694 INTEGER d_i1 695 INTEGER k_i1_offset 696 INTEGER l_i1_offset 697 INTEGER size_i1 698 CHARACTER*255 filename 699 CALL nr0_act_1(d_x1,k_x1_offset,d_f1,k_f1_offset,d_i0,k_i0_offset) 700 CALL nr0_act_2(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i0,k_i0_offset) 701 CALL OFFSET_nr0_act_3_1(l_i1_offset,k_i1_offset,size_i1) 702 CALL TCE_FILENAME('nr0_3_1_i1',filename) 703 CALL CREATEFILE(filename,d_i1,size_i1) 704 CALL nr0_act_3_1(d_x1,k_x1_offset,d_v2,k_v2_offset, 705 & d_i1,k_i1_offset) 706 CALL RECONCILEFILE(d_i1,size_i1) 707 CALL nr0_act_3(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset) 708 CALL DELETEFILE(d_i1) 709 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('nr0',-1,MA_ERR) 710 RETURN 711 END 712 SUBROUTINE nr0_act_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 713C $Id$ 714C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 715C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 716C i0 ( )_xf + = 1 * Sum ( p2 h1 ) * x ( p2 h1 )_x * f ( h1 p2 )_f 717 IMPLICIT NONE 718#include "global.fh" 719#include "mafdecls.fh" 720#include "sym.fh" 721#include "errquit.fh" 722#include "tce.fh" 723 INTEGER d_a 724 INTEGER k_a_offset 725 INTEGER d_b 726 INTEGER k_b_offset 727 INTEGER d_c 728 INTEGER k_c_offset 729 INTEGER nxtask 730 INTEGER next 731 INTEGER nprocs 732 INTEGER count 733 INTEGER dimc 734 INTEGER l_c_sort 735 INTEGER k_c_sort 736 INTEGER p2b 737 INTEGER h1b 738 INTEGER p2b_1 739 INTEGER h1b_1 740 INTEGER h1b_2 741 INTEGER p2b_2 742 INTEGER dim_common 743 INTEGER dima_sort 744 INTEGER dima 745 INTEGER dimb_sort 746 INTEGER dimb 747 INTEGER l_a_sort 748 INTEGER k_a_sort 749 INTEGER l_a 750 INTEGER k_a 751 INTEGER l_b_sort 752 INTEGER k_b_sort 753 INTEGER l_b 754 INTEGER k_b 755 INTEGER l_c 756 INTEGER k_c 757 EXTERNAL nxtask 758 nprocs = GA_NNODES() 759 count = 0 760 next = nxtask(nprocs,1) 761 IF (next.eq.count) THEN 762 IF (0 .eq. ieor(irrep_x,irrep_f)) THEN 763 dimc = 1 764 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 765 & ERRQUIT('nr0_1',0,MA_ERR) 766 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 767 DO p2b = noab+1,noab+nvab 768 DO h1b = 1,noab 769 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 770 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH 771 &EN 772 CALL TCE_RESTRICTED_2(p2b,h1b,p2b_1,h1b_1) 773 CALL TCE_RESTRICTED_2(h1b,p2b,h1b_2,p2b_2) 774 dim_common = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 775 dima_sort = 1 776 dima = dim_common * dima_sort 777 dimb_sort = 1 778 dimb = dim_common * dimb_sort 779 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 780 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 781 & ERRQUIT('nr0_1',1,MA_ERR) 782 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 783 &nr0_1',2,MA_ERR) 784 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 785 & - 1 + noab * (p2b_1 - noab - 1))) 786 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 787 &,int_mb(k_range+h1b-1),2,1,1.0d0) 788 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_1',3,MA_ERR) 789 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 790 & ERRQUIT('nr0_1',4,MA_ERR) 791 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 792 &nr0_1',5,MA_ERR) 793 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 794 & - 1 + (noab+nvab) * (h1b_2 - 1))) 795 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 796 &,int_mb(k_range+p2b-1),1,2,1.0d0) 797 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_1',6,MA_ERR) 798 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 799 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 800 &t),dima_sort) 801 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_1',7,MA_ERR) 802 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_1',8,MA_ERR) 803 END IF 804 END IF 805 END IF 806 END DO 807 END DO 808 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 809 &nr0_1',9,MA_ERR) 810 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 811 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 812 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_1',10,MA_ERR) 813 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_1',11,MA_ERR) 814 END IF 815 next = nxtask(nprocs,1) 816 END IF 817 count = count + 1 818 next = nxtask(-nprocs,1) 819 call GA_SYNC() 820 RETURN 821 END 822 SUBROUTINE nr0_act_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_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 ( )_xv + = 1/4 * Sum ( p3 p4 h1 h2 ) * x ( p3 p4 h1 h2 )_x * v ( h1 h2 p3 p4 )_v 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 p3b 847 INTEGER p4b 848 INTEGER h1b 849 INTEGER h2b 850 INTEGER p3b_1 851 INTEGER p4b_1 852 INTEGER h1b_1 853 INTEGER h2b_1 854 INTEGER h1b_2 855 INTEGER h2b_2 856 INTEGER p3b_2 857 INTEGER p4b_2 858 INTEGER dim_common 859 INTEGER dima_sort 860 INTEGER dima 861 INTEGER dimb_sort 862 INTEGER dimb 863 INTEGER l_a_sort 864 INTEGER k_a_sort 865 INTEGER l_a 866 INTEGER k_a 867 INTEGER l_b_sort 868 INTEGER k_b_sort 869 INTEGER l_b 870 INTEGER k_b 871 INTEGER nsuperp(2) 872 INTEGER isuperp 873 INTEGER nsubh(2) 874 INTEGER isubh 875 INTEGER l_c 876 INTEGER k_c 877 LOGICAL is_active_1,is_active_2,is_active_3,is_active_4 878 LOGICAL one_of_two_act 879 DOUBLE PRECISION FACTORIAL 880 EXTERNAL nxtask 881 EXTERNAL FACTORIAL 882 nprocs = GA_NNODES() 883 count = 0 884 next = nxtask(nprocs,1) 885 IF (next.eq.count) THEN 886 IF (0 .eq. ieor(irrep_x,irrep_v)) THEN 887 dimc = 1 888 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 889 & ERRQUIT('nr0_2',0,MA_ERR) 890 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 891 DO p3b = noab+1,noab+nvab 892 DO p4b = p3b,noab+nvab 893 DO h1b = 1,noab 894 DO h2b = h1b,noab 895 IF(is_active_4(p3b,p4b,h1b,h2b)) THEN 896 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h 897 &1b-1)+int_mb(k_spin+h2b-1)) THEN 898 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb( 899 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN 900 CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h2b,p3b_1,p4b_1,h1b_1,h2b_1) 901 CALL TCE_RESTRICTED_4(h1b,h2b,p3b,p4b,h1b_2,h2b_2,p3b_2,p4b_2) 902 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m 903 &b(k_range+h1b-1) * int_mb(k_range+h2b-1) 904 dima_sort = 1 905 dima = dim_common * dima_sort 906 dimb_sort = 1 907 dimb = dim_common * dimb_sort 908 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 909 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 910 & ERRQUIT('nr0_2',1,MA_ERR) 911 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 912 &nr0_2',2,MA_ERR) 913 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 914 & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_ 915 &1 - noab - 1))))) 916 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 917 &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 918 &,4,3,2,1,1.0d0) 919 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_2',3,MA_ERR) 920 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 921 & ERRQUIT('nr0_2',4,MA_ERR) 922 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 923 &nr0_2',5,MA_ERR) 924 if(.not.intorb) then 925 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 926 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 927 &+nvab) * (h1b_2 - 1))))) 928 else 929 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 930 &(p4b_2 931 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 932 &+nvab) * (h1b_2 - 1)))),p4b_2,p3b_2,h2b_2,h1b_2) 933 end if 934 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 935 &,int_mb(k_range+h2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 936 &,2,1,4,3,1.0d0) 937 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_2',6,MA_ERR) 938 nsuperp(1) = 1 939 nsuperp(2) = 1 940 isuperp = 1 941 IF (p3b .eq. p4b) THEN 942 nsuperp(isuperp) = nsuperp(isuperp) + 1 943 ELSE 944 isuperp = isuperp + 1 945 END IF 946 nsubh(1) = 1 947 nsubh(2) = 1 948 isubh = 1 949 IF (h1b .eq. h2b) THEN 950 nsubh(isubh) = nsubh(isubh) + 1 951 ELSE 952 isubh = isubh + 1 953 END IF 954 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,4.0d0/FACTORIAL( 955 &nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsubh(1))/FACTORIAL(ns 956 &ubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k_b_sort),dim_common,1. 957 &0d0,dbl_mb(k_c_sort),dima_sort) 958 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_2',7,MA_ERR) 959 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_2',8,MA_ERR) 960 END IF 961 END IF 962 END IF 963 END IF 964 END DO 965 END DO 966 END DO 967 END DO 968 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 969 &nr0_2',9,MA_ERR) 970 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0/4.0d0) 971 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 972 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_2',10,MA_ERR) 973 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_2',11,MA_ERR) 974 END IF 975 next = nxtask(nprocs,1) 976 END IF 977 count = count + 1 978 next = nxtask(-nprocs,1) 979 call GA_SYNC() 980 RETURN 981 END 982 SUBROUTINE nr0_act_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 983C $Id$ 984C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 985C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 986C i0 ( )_vxt + = 1 * Sum ( h2 p1 ) * t ( p1 h2 )_t * i1 ( h2 p1 )_vx 987 IMPLICIT NONE 988#include "global.fh" 989#include "mafdecls.fh" 990#include "sym.fh" 991#include "errquit.fh" 992#include "tce.fh" 993 INTEGER d_a 994 INTEGER k_a_offset 995 INTEGER d_b 996 INTEGER k_b_offset 997 INTEGER d_c 998 INTEGER k_c_offset 999 INTEGER nxtask 1000 INTEGER next 1001 INTEGER nprocs 1002 INTEGER count 1003 INTEGER dimc 1004 INTEGER l_c_sort 1005 INTEGER k_c_sort 1006 INTEGER p1b 1007 INTEGER h2b 1008 INTEGER p1b_1 1009 INTEGER h2b_1 1010 INTEGER h2b_2 1011 INTEGER p1b_2 1012 INTEGER dim_common 1013 INTEGER dima_sort 1014 INTEGER dima 1015 INTEGER dimb_sort 1016 INTEGER dimb 1017 INTEGER l_a_sort 1018 INTEGER k_a_sort 1019 INTEGER l_a 1020 INTEGER k_a 1021 INTEGER l_b_sort 1022 INTEGER k_b_sort 1023 INTEGER l_b 1024 INTEGER k_b 1025 INTEGER l_c 1026 INTEGER k_c 1027 EXTERNAL nxtask 1028 nprocs = GA_NNODES() 1029 count = 0 1030 next = nxtask(nprocs,1) 1031 IF (next.eq.count) THEN 1032 IF (0 .eq. ieor(irrep_v,ieor(irrep_x,irrep_t))) THEN 1033 dimc = 1 1034 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1035 & ERRQUIT('nr0_3',0,MA_ERR) 1036 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1037 DO p1b = noab+1,noab+nvab 1038 DO h2b = 1,noab 1039 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) THEN 1040 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)) .eq. irrep_t) TH 1041 &EN 1042 CALL TCE_RESTRICTED_2(p1b,h2b,p1b_1,h2b_1) 1043 CALL TCE_RESTRICTED_2(h2b,p1b,h2b_2,p1b_2) 1044 dim_common = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1) 1045 dima_sort = 1 1046 dima = dim_common * dima_sort 1047 dimb_sort = 1 1048 dimb = dim_common * dimb_sort 1049 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1050 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1051 & ERRQUIT('nr0_3',1,MA_ERR) 1052 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1053 &nr0_3',2,MA_ERR) 1054 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 1055 & - 1 + noab * (p1b_1 - noab - 1))) 1056 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 1057 &,int_mb(k_range+h2b-1),2,1,1.0d0) 1058 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_3',3,MA_ERR) 1059 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1060 & ERRQUIT('nr0_3',4,MA_ERR) 1061 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1062 &nr0_3',5,MA_ERR) 1063 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 1064 & - noab - 1 + nvab * (h2b_2 - 1))) 1065 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1066 &,int_mb(k_range+p1b-1),1,2,1.0d0) 1067 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_3',6,MA_ERR) 1068 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1069 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1070 &t),dima_sort) 1071 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_3',7,MA_ERR) 1072 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_3',8,MA_ERR) 1073 END IF 1074 END IF 1075 END IF 1076 END DO 1077 END DO 1078 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1079 &nr0_3',9,MA_ERR) 1080 CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0) 1081 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0) 1082 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_3',10,MA_ERR) 1083 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_3',11,MA_ERR) 1084 END IF 1085 next = nxtask(nprocs,1) 1086 END IF 1087 count = count + 1 1088 next = nxtask(-nprocs,1) 1089 call GA_SYNC() 1090 RETURN 1091 END 1092 SUBROUTINE nr0_act_3_1(d_a,k_a_offset,d_b,k_b_offset, 1093 & d_c,k_c_offset) 1094C $Id$ 1095C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1096C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1097C i1 ( h2 p1 )_vx + = 1 * Sum ( h3 p4 ) * x ( p4 h3 )_x * v ( h2 h3 p1 p4 )_v 1098 IMPLICIT NONE 1099#include "global.fh" 1100#include "mafdecls.fh" 1101#include "sym.fh" 1102#include "errquit.fh" 1103#include "tce.fh" 1104 INTEGER d_a 1105 INTEGER k_a_offset 1106 INTEGER d_b 1107 INTEGER k_b_offset 1108 INTEGER d_c 1109 INTEGER k_c_offset 1110 INTEGER nxtask 1111 INTEGER next 1112 INTEGER nprocs 1113 INTEGER count 1114 INTEGER h2b 1115 INTEGER p1b 1116 INTEGER dimc 1117 INTEGER l_c_sort 1118 INTEGER k_c_sort 1119 INTEGER p4b 1120 INTEGER h3b 1121 INTEGER p4b_1 1122 INTEGER h3b_1 1123 INTEGER h2b_2 1124 INTEGER h3b_2 1125 INTEGER p1b_2 1126 INTEGER p4b_2 1127 INTEGER dim_common 1128 INTEGER dima_sort 1129 INTEGER dima 1130 INTEGER dimb_sort 1131 INTEGER dimb 1132 INTEGER l_a_sort 1133 INTEGER k_a_sort 1134 INTEGER l_a 1135 INTEGER k_a 1136 INTEGER l_b_sort 1137 INTEGER k_b_sort 1138 INTEGER l_b 1139 INTEGER k_b 1140 INTEGER l_c 1141 INTEGER k_c 1142 EXTERNAL nxtask 1143 nprocs = GA_NNODES() 1144 count = 0 1145 next = nxtask(nprocs,1) 1146 DO h2b = 1,noab 1147 DO p1b = noab+1,noab+nvab 1148 IF (next.eq.count) THEN 1149 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1 1150 &).ne.4)) THEN 1151 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 1152 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 1153 &v,irrep_x)) THEN 1154 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 1155 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1156 & ERRQUIT('nr0_3_1',0,MA_ERR) 1157 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1158 DO p4b = noab+1,noab+nvab 1159 DO h3b = 1,noab 1160 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h3b-1)) THEN 1161 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH 1162 &EN 1163 CALL TCE_RESTRICTED_2(p4b,h3b,p4b_1,h3b_1) 1164 CALL TCE_RESTRICTED_4(h2b,h3b,p1b,p4b,h2b_2,h3b_2,p1b_2,p4b_2) 1165 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h3b-1) 1166 dima_sort = 1 1167 dima = dim_common * dima_sort 1168 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 1169 dimb = dim_common * dimb_sort 1170 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1171 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1172 & ERRQUIT('nr0_3_1',1,MA_ERR) 1173 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1174 &nr0_3_1',2,MA_ERR) 1175 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 1176 & - 1 + noab * (p4b_1 - noab - 1))) 1177 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 1178 &,int_mb(k_range+h3b-1),2,1,1.0d0) 1179 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_3_1',3,MA_ERR) 1180 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1181 & ERRQUIT('nr0_3_1',4,MA_ERR) 1182 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1183 &nr0_3_1',5,MA_ERR) 1184 IF ((h3b .lt. h2b) .and. (p4b .lt. p1b)) THEN 1185 if(.not.intorb) then 1186 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 1187 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 1188 &+nvab) * (h3b_2 - 1))))) 1189 else 1190 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1191 &(p1b_2 1192 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 1193 &+nvab) * (h3b_2 - 1)))),p1b_2,p4b_2,h2b_2,h3b_2) 1194 end if 1195 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 1196 &,int_mb(k_range+h2b-1),int_mb(k_range+p4b-1),int_mb(k_range+p1b-1) 1197 &,4,2,1,3,1.0d0) 1198 END IF 1199 IF ((h3b .lt. h2b) .and. (p1b .le. p4b)) THEN 1200 if(.not.intorb) then 1201 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 1202 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 1203 &+nvab) * (h3b_2 - 1))))) 1204 else 1205 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1206 &(p4b_2 1207 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab 1208 &+nvab) * (h3b_2 - 1)))),p4b_2,p1b_2,h2b_2,h3b_2) 1209 end if 1210 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 1211 &,int_mb(k_range+h2b-1),int_mb(k_range+p1b-1),int_mb(k_range+p4b-1) 1212 &,3,2,1,4,-1.0d0) 1213 END IF 1214 IF ((h2b .le. h3b) .and. (p4b .lt. p1b)) THEN 1215 if(.not.intorb) then 1216 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 1217 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab 1218 &+nvab) * (h2b_2 - 1))))) 1219 else 1220 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1221 &(p1b_2 1222 & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab 1223 &+nvab) * (h2b_2 - 1)))),p1b_2,p4b_2,h3b_2,h2b_2) 1224 end if 1225 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1226 &,int_mb(k_range+h3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p1b-1) 1227 &,4,1,2,3,-1.0d0) 1228 END IF 1229 IF ((h2b .le. h3b) .and. (p1b .le. p4b)) THEN 1230 if(.not.intorb) then 1231 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 1232 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab 1233 &+nvab) * (h2b_2 - 1))))) 1234 else 1235 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 1236 &(p4b_2 1237 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab 1238 &+nvab) * (h2b_2 - 1)))),p4b_2,p1b_2,h3b_2,h2b_2) 1239 end if 1240 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1241 &,int_mb(k_range+h3b-1),int_mb(k_range+p1b-1),int_mb(k_range+p4b-1) 1242 &,3,1,2,4,1.0d0) 1243 END IF 1244 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_3_1',6,MA_ERR) 1245 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1246 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1247 &t),dima_sort) 1248 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_3_1',7,MA_ERR) 1249 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_3_1',8,MA_ERR) 1250 END IF 1251 END IF 1252 END IF 1253 END DO 1254 END DO 1255 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1256 &nr0_3_1',9,MA_ERR) 1257 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 1258 &,int_mb(k_range+h2b-1),2,1,1.0d0) 1259 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b - 1260 & noab - 1 + nvab * (h2b - 1))) 1261 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_3_1',10,MA_ERR) 1262 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_3_1',11,MA_ERR) 1263 END IF 1264 END IF 1265 END IF 1266 next = nxtask(nprocs,1) 1267 END IF 1268 count = count + 1 1269 END DO 1270 END DO 1271 next = nxtask(-nprocs,1) 1272 call GA_SYNC() 1273 RETURN 1274 END 1275 SUBROUTINE OFFSET_nr0_act_3_1(l_a_offset,k_a_offset,size) 1276C $Id$ 1277C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1278C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1279C i1 ( h2 p1 )_vx 1280 IMPLICIT NONE 1281#include "global.fh" 1282#include "mafdecls.fh" 1283#include "sym.fh" 1284#include "errquit.fh" 1285#include "tce.fh" 1286 INTEGER l_a_offset 1287 INTEGER k_a_offset 1288 INTEGER size 1289 INTEGER length 1290 INTEGER addr 1291 INTEGER h2b 1292 INTEGER p1b 1293 length = 0 1294 DO h2b = 1,noab 1295 DO p1b = noab+1,noab+nvab 1296 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 1297 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 1298 &v,irrep_x)) THEN 1299 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1 1300 &).ne.4)) THEN 1301 length = length + 1 1302 END IF 1303 END IF 1304 END IF 1305 END DO 1306 END DO 1307 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1308 &set)) CALL ERRQUIT('nr0_3_1',0,MA_ERR) 1309 int_mb(k_a_offset) = length 1310 addr = 0 1311 size = 0 1312 DO h2b = 1,noab 1313 DO p1b = noab+1,noab+nvab 1314 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN 1315 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 1316 &v,irrep_x)) THEN 1317 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1 1318 &).ne.4)) THEN 1319 addr = addr + 1 1320 int_mb(k_a_offset+addr) = p1b - noab - 1 + nvab * (h2b - 1) 1321 int_mb(k_a_offset+length+addr) = size 1322 size = size + int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1) 1323 END IF 1324 END IF 1325 END IF 1326 END DO 1327 END DO 1328 RETURN 1329 END 1330 1331