1 SUBROUTINE ccsdt_t3a_2_1(d_a,k_a_offset,d_c,k_c_offset) 2C $Id$ 3C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5C i1 ( p4 p5 h1 p12 )_v + = 1 * v ( p4 p5 h1 p12 )_v 6 IMPLICIT NONE 7#include "global.fh" 8#include "mafdecls.fh" 9#include "sym.fh" 10#include "errquit.fh" 11#include "tce.fh" 12 INTEGER d_a 13 INTEGER k_a_offset 14 INTEGER d_c 15 INTEGER k_c_offset 16 INTEGER NXTASK 17 INTEGER next 18 INTEGER nprocs 19 INTEGER count 20 INTEGER p4b 21 INTEGER p5b 22 INTEGER h1b 23 INTEGER p12b 24 INTEGER dimc 25 INTEGER p4b_1 26 INTEGER p5b_1 27 INTEGER h1b_1 28 INTEGER p12b_1 29 INTEGER dim_common 30 INTEGER dima_sort 31 INTEGER dima 32 INTEGER l_a_sort 33 INTEGER k_a_sort 34 INTEGER l_a 35 INTEGER k_a 36 INTEGER l_c 37 INTEGER k_c 38 LOGICAL ACOLO_2P_1H 39 EXTERNAL NXTASK 40 nprocs = GA_NNODES() 41 count = 0 42 next = NXTASK(nprocs,1) 43 DO p4b = noab+1,noab+nvab 44 DO p5b = p4b,noab+nvab 45 DO h1b = 1,noab 46 DO p12b = noab+1,noab+nvab 47 IF (next.eq.count) THEN 48 IF(acolo_2p_1h(p4b,p5b,h1b)) THEN 49 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 50 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p12b-1).ne.8)) THEN 51 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 52 &1b-1)+int_mb(k_spin+p12b-1)) THEN 53 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 54 &k_sym+h1b-1),int_mb(k_sym+p12b-1)))) .eq. irrep_v) THEN 55 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 56 &nge+h1b-1) * int_mb(k_range+p12b-1) 57 CALL TCE_RESTRICTED_4(p4b,p5b,h1b,p12b,p4b_1,p5b_1,h1b_1,p12b_1) 58 dim_common = 1 59 dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb 60 &(k_range+h1b-1) * int_mb(k_range+p12b-1) 61 dima = dim_common * dima_sort 62 IF (dima .gt. 0) THEN 63 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 64 & ERRQUIT('ccsdt_t3_2_1',0,MA_ERR) 65 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 66 &ccsdt_t3_2_1',1,MA_ERR) 67 IF ((h1b .le. p12b)) THEN 68 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p12b_ 69 &1 - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p5b_1 - 1 + (noa 70 &b+nvab) * (p4b_1 - 1))))) 71 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 72 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p12b-1 73 &),4,3,2,1,1.0d0) 74 END IF 75 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_t3_2_1',2,MA_ERR) 76 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 77 &ccsdt_t3_2_1',3,MA_ERR) 78 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p12b-1 79 &),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p4b-1 80 &),4,3,2,1,1.0d0) 81 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p12b 82 &- noab - 1 + nvab * (h1b - 1 + noab * (p5b - noab - 1 + nvab * (p4 83 &b - noab - 1))))) 84 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_t3_2_1',4,MA_ERR) 85 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_t3_2_1',5,MA_ 86 &ERR) 87 END IF 88 END IF 89 END IF 90 END IF 91 END IF !active 92 next = NXTASK(nprocs,1) 93 END IF 94 count = count + 1 95 END DO 96 END DO 97 END DO 98 END DO 99 next = NXTASK(-nprocs,1) 100 call GA_SYNC() 101 RETURN 102 END 103