1      SUBROUTINE ccsdt_y_tr2_23_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_
2     &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     i1 ( h3 h4 p11 h8 h10 p1 )_yttr + = 1 * tr ( p11 h10 )_tr * i2 ( h3 h4 h8 p1 )_yt
7      IMPLICIT NONE
8#include "global.fh"
9#include "mafdecls.fh"
10#include "sym.fh"
11#include "errquit.fh"
12#include "tce.fh"
13      INTEGER d_a
14      INTEGER k_a_offset
15      INTEGER d_b
16      INTEGER k_b_offset
17      INTEGER d_c
18      INTEGER k_c_offset
19      INTEGER nxtask
20      INTEGER next
21      INTEGER nprocs
22      INTEGER count
23      INTEGER h3b
24      INTEGER h4b
25      INTEGER p11b
26      INTEGER p1b
27      INTEGER h10b
28      INTEGER h8b
29      INTEGER dimc
30      INTEGER l_c_sort
31      INTEGER k_c_sort
32      INTEGER p11b_1
33      INTEGER h10b_1
34      INTEGER h3b_2
35      INTEGER h4b_2
36      INTEGER p1b_2
37      INTEGER h8b_2
38      INTEGER dim_common
39      INTEGER dima_sort
40      INTEGER dima
41      INTEGER dimb_sort
42      INTEGER dimb
43      INTEGER l_a_sort
44      INTEGER k_a_sort
45      INTEGER l_a
46      INTEGER k_a
47      INTEGER l_b_sort
48      INTEGER k_b_sort
49      INTEGER l_b
50      INTEGER k_b
51      INTEGER l_c
52      INTEGER k_c
53      EXTERNAL nxtask
54      nprocs = GA_NNODES()
55      count = 0
56      next = nxtask(nprocs,1)
57      DO h3b = 1,noab
58      DO h4b = h3b,noab
59      DO p11b = noab+1,noab+nvab
60      DO p1b = noab+1,noab+nvab
61      DO h10b = 1,noab
62      DO h8b = 1,noab
63      IF (next.eq.count) THEN
64      IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1
65     &)+int_mb(k_spin+p11b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+h8b-1)+
66     &int_mb(k_spin+h10b-1).ne.12)) THEN
67      IF (int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)+int_mb(k_spin+p11b-1
68     &) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+h8b-1)+int_mb(k_spin+h10
69     &b-1)) THEN
70      IF (ieor(int_mb(k_sym+h3b-1),ieor(int_mb(k_sym+h4b-1),ieor(int_mb(
71     &k_sym+p11b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+h8b-1),in
72     &t_mb(k_sym+h10b-1)))))) .eq. ieor(irrep_y,ieor(irrep_t,irrep_tr)))
73     & THEN
74      dimc = int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) * int_mb(k_ra
75     &nge+p11b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+h8b-1) * int_
76     &mb(k_range+h10b-1)
77      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
78     & ERRQUIT('ccsdt_y_tr2_23_2',0,MA_ERR)
79      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
80      IF (int_mb(k_spin+p11b-1) .eq. int_mb(k_spin+h10b-1)) THEN
81      IF (ieor(int_mb(k_sym+p11b-1),int_mb(k_sym+h10b-1)) .eq. irrep_tr)
82     & THEN
83      CALL TCE_RESTRICTED_2(p11b,h10b,p11b_1,h10b_1)
84      CALL TCE_RESTRICTED_4(h3b,h4b,p1b,h8b,h3b_2,h4b_2,p1b_2,h8b_2)
85      dim_common = 1
86      dima_sort = int_mb(k_range+p11b-1) * int_mb(k_range+h10b-1)
87      dima = dim_common * dima_sort
88      dimb_sort = int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) * int_mb
89     &(k_range+p1b-1) * int_mb(k_range+h8b-1)
90      dimb = dim_common * dimb_sort
91      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
92      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
93     & ERRQUIT('ccsdt_y_tr2_23_2',1,MA_ERR)
94      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
95     &ccsdt_y_tr2_23_2',2,MA_ERR)
96      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_
97     &1 - 1 + noab * (p11b_1 - noab - 1)))
98      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p11b-1
99     &),int_mb(k_range+h10b-1),2,1,1.0d0)
100      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_y_tr2_23_2',3,MA_E
101     &RR)
102      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
103     & ERRQUIT('ccsdt_y_tr2_23_2',4,MA_ERR)
104      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
105     &ccsdt_y_tr2_23_2',5,MA_ERR)
106      IF ((h8b .le. p1b)) THEN
107      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2
108     & - noab - 1 + nvab * (h8b_2 - 1 + noab * (h4b_2 - 1 + noab * (h3b_
109     &2 - 1)))))
110      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
111     &,int_mb(k_range+h4b-1),int_mb(k_range+h8b-1),int_mb(k_range+p1b-1)
112     &,3,4,2,1,1.0d0)
113      END IF
114      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_y_tr2_23_2',6,MA_E
115     &RR)
116      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
117     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
118     &t),dima_sort)
119      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_y_tr2_23_2',7
120     &,MA_ERR)
121      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_y_tr2_23_2',8
122     &,MA_ERR)
123      END IF
124      END IF
125      END IF
126      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
127     &ccsdt_y_tr2_23_2',9,MA_ERR)
128      IF ((h8b .le. h10b)) THEN
129      CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1)
130     &,int_mb(k_range+p1b-1),int_mb(k_range+h4b-1),int_mb(k_range+h3b-1)
131     &,int_mb(k_range+h10b-1),int_mb(k_range+p11b-1),4,3,6,2,1,5,1.0d0/2
132     &.0d0)
133      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h10b
134     &- 1 + noab * (h8b - 1 + noab * (p1b - noab - 1 + nvab * (p11b - no
135     &ab - 1 + nvab * (h4b - 1 + noab * (h3b - 1)))))))
136      END IF
137      IF ((h10b .le. h8b)) THEN
138      CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1)
139     &,int_mb(k_range+p1b-1),int_mb(k_range+h4b-1),int_mb(k_range+h3b-1)
140     &,int_mb(k_range+h10b-1),int_mb(k_range+p11b-1),4,3,6,2,5,1,-1.0d0/
141     &2.0d0)
142      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h8b -
143     & 1 + noab * (h10b - 1 + noab * (p1b - noab - 1 + nvab * (p11b - no
144     &ab - 1 + nvab * (h4b - 1 + noab * (h3b - 1)))))))
145      END IF
146      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_y_tr2_23_2',10,MA_
147     &ERR)
148      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_y_tr2_23_2',1
149     &1,MA_ERR)
150      END IF
151      END IF
152      END IF
153      next = nxtask(nprocs,1)
154      END IF
155      count = count + 1
156      END DO
157      END DO
158      END DO
159      END DO
160      END DO
161      END DO
162      next = nxtask(-nprocs,1)
163      call GA_SYNC()
164      RETURN
165      END
166