1 SUBROUTINE ccsdt_lambda2_12_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 ( p11 p13 h12 p1 )_v + = -1 * v ( p11 p13 h12 p1 )_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 p11b 21 INTEGER p13b 22 INTEGER p1b 23 INTEGER h12b 24 INTEGER dimc 25 INTEGER p11b_1 26 INTEGER p13b_1 27 INTEGER p1b_1 28 INTEGER h12b_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 EXTERNAL NXTASK 39 nprocs = GA_NNODES() 40 count = 0 41 next = NXTASK(nprocs,1) 42 DO p11b = noab+1,noab+nvab 43 DO p13b = p11b,noab+nvab 44 DO p1b = noab+1,noab+nvab 45 DO h12b = 1,noab 46 IF (next.eq.count) THEN 47 IF ((.not.restricted).or.(int_mb(k_spin+p11b-1)+int_mb(k_spin+p13b 48 &-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+h12b-1).ne.8)) THEN 49 IF (int_mb(k_spin+p11b-1)+int_mb(k_spin+p13b-1) .eq. int_mb(k_spin 50 &+p1b-1)+int_mb(k_spin+h12b-1)) THEN 51 IF (ieor(int_mb(k_sym+p11b-1),ieor(int_mb(k_sym+p13b-1),ieor(int_m 52 &b(k_sym+p1b-1),int_mb(k_sym+h12b-1)))) .eq. irrep_v) THEN 53 dimc = int_mb(k_range+p11b-1) * int_mb(k_range+p13b-1) * int_mb(k_ 54 &range+p1b-1) * int_mb(k_range+h12b-1) 55 CALL TCE_RESTRICTED_4(p11b,p13b,p1b,h12b,p11b_1,p13b_1,p1b_1,h12b_ 56 &1) 57 dim_common = 1 58 dima_sort = int_mb(k_range+p11b-1) * int_mb(k_range+p13b-1) * int_ 59 &mb(k_range+p1b-1) * int_mb(k_range+h12b-1) 60 dima = dim_common * dima_sort 61 IF (dima .gt. 0) THEN 62 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 63 & ERRQUIT('ccsdt_lambda2_12_1',0,MA_ERR) 64 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 65 &ccsdt_lambda2_12_1',1,MA_ERR) 66 IF ((h12b .le. p1b)) THEN 67 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1 68 & - 1 + (noab+nvab) * (h12b_1 - 1 + (noab+nvab) * (p13b_1 - 1 + (no 69 &ab+nvab) * (p11b_1 - 1))))) 70 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p11b-1 71 &),int_mb(k_range+p13b-1),int_mb(k_range+h12b-1),int_mb(k_range+p1b 72 &-1),3,4,2,1,1.0d0) 73 END IF 74 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_lambda2_12_1',2,MA 75 &_ERR) 76 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 77 &ccsdt_lambda2_12_1',3,MA_ERR) 78 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h12b-1 79 &),int_mb(k_range+p1b-1),int_mb(k_range+p13b-1),int_mb(k_range+p11b 80 &-1),4,3,2,1,-1.0d0) 81 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h12b 82 &- 1 + noab * (p1b - noab - 1 + nvab * (p13b - noab - 1 + nvab * (p 83 &11b - noab - 1))))) 84 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_lambda2_12_1',4,MA 85 &_ERR) 86 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_lambda2_12_1' 87 &,5,MA_ERR) 88 END IF 89 END IF 90 END IF 91 END IF 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