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