1      SUBROUTINE ccsdtq_lambda2_26_4_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     i3 ( h3 h7 h8 h11 p1 p5 p9 p10 )_y + = 1 * y ( h3 h7 h8 h11 p1 p5 p9 p10 )_y
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 h3b
21      INTEGER h7b
22      INTEGER h8b
23      INTEGER h11b
24      INTEGER p1b
25      INTEGER p5b
26      INTEGER p9b
27      INTEGER p10b
28      INTEGER dimc
29      INTEGER h3b_1
30      INTEGER h7b_1
31      INTEGER h8b_1
32      INTEGER h11b_1
33      INTEGER p1b_1
34      INTEGER p5b_1
35      INTEGER p9b_1
36      INTEGER p10b_1
37      INTEGER dim_common
38      INTEGER dima_sort
39      INTEGER dima
40      INTEGER l_a_sort
41      INTEGER k_a_sort
42      INTEGER l_a
43      INTEGER k_a
44      INTEGER l_c
45      INTEGER k_c
46      EXTERNAL NXTASK
47      nprocs = GA_NNODES()
48      count = 0
49      next = NXTASK(nprocs,1)
50      DO h3b = 1,noab
51      DO h7b = 1,noab
52      DO h8b = h7b,noab
53      DO h11b = h8b,noab
54      DO p1b = noab+1,noab+nvab
55      DO p5b = noab+1,noab+nvab
56      DO p9b = p5b,noab+nvab
57      DO p10b = p9b,noab+nvab
58      IF (next.eq.count) THEN
59      IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h7b-1
60     &)+int_mb(k_spin+h8b-1)+int_mb(k_spin+h11b-1)+int_mb(k_spin+p1b-1)+
61     &int_mb(k_spin+p5b-1)+int_mb(k_spin+p9b-1)+int_mb(k_spin+p10b-1).ne
62     &.16)) THEN
63      IF (int_mb(k_spin+h3b-1)+int_mb(k_spin+h7b-1)+int_mb(k_spin+h8b-1)
64     &+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p5b
65     &-1)+int_mb(k_spin+p9b-1)+int_mb(k_spin+p10b-1)) THEN
66      IF (ieor(int_mb(k_sym+h3b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb(
67     &k_sym+h8b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb(k_sym+p1b-1),ie
68     &or(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p9b-1),int_mb(k_sym+p10b-
69     &1)))))))) .eq. irrep_y) THEN
70      dimc = int_mb(k_range+h3b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra
71     &nge+h8b-1) * int_mb(k_range+h11b-1) * int_mb(k_range+p1b-1) * int_
72     &mb(k_range+p5b-1) * int_mb(k_range+p9b-1) * int_mb(k_range+p10b-1)
73      CALL TCE_RESTRICTED_8(h3b,h7b,h8b,h11b,p1b,p5b,p9b,p10b,h3b_1,h7b_
74     &1,h8b_1,h11b_1,p1b_1,p5b_1,p9b_1,p10b_1)
75      dim_common = 1
76      dima_sort = int_mb(k_range+h3b-1) * int_mb(k_range+h7b-1) * int_mb
77     &(k_range+h8b-1) * int_mb(k_range+h11b-1) * int_mb(k_range+p1b-1) *
78     & int_mb(k_range+p5b-1) * int_mb(k_range+p9b-1) * int_mb(k_range+p1
79     &0b-1)
80      dima = dim_common * dima_sort
81      IF (dima .gt. 0) THEN
82      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
83     & ERRQUIT('ccsdtq_lambda2_26_4_2_1',0,MA_ERR)
84      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
85     &ccsdtq_lambda2_26_4_2_1',1,MA_ERR)
86      IF ((h11b .lt. h3b) .and. (p10b .lt. p1b)) THEN
87      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1
88     & - noab - 1 + nvab * (p10b_1 - noab - 1 + nvab * (p9b_1 - noab - 1
89     & + nvab * (p5b_1 - noab - 1 + nvab * (h3b_1 - 1 + noab * (h11b_1 -
90     & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1)))))))))
91      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
92     &,int_mb(k_range+h8b-1),int_mb(k_range+h11b-1),int_mb(k_range+h3b-1
93     &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p10b-
94     &1),int_mb(k_range+p1b-1),7,6,5,8,3,2,1,4,1.0d0)
95      END IF
96      IF ((h11b .lt. h3b) .and. (p9b .lt. p1b) .and. (p1b .le. p10b)) TH
97     &EN
98      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
99     &1 - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (p9b_1 - noab - 1
100     & + nvab * (p5b_1 - noab - 1 + nvab * (h3b_1 - 1 + noab * (h11b_1 -
101     & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1)))))))))
102      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
103     &,int_mb(k_range+h8b-1),int_mb(k_range+h11b-1),int_mb(k_range+h3b-1
104     &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1
105     &),int_mb(k_range+p10b-1),8,6,5,7,3,2,1,4,-1.0d0)
106      END IF
107      IF ((h11b .lt. h3b) .and. (p5b .lt. p1b) .and. (p1b .le. p9b)) THE
108     &N
109      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
110     &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p1b_1 - noab - 1
111     & + nvab * (p5b_1 - noab - 1 + nvab * (h3b_1 - 1 + noab * (h11b_1 -
112     & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1)))))))))
113      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
114     &,int_mb(k_range+h8b-1),int_mb(k_range+h11b-1),int_mb(k_range+h3b-1
115     &),int_mb(k_range+p5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1
116     &),int_mb(k_range+p10b-1),8,7,5,6,3,2,1,4,1.0d0)
117      END IF
118      IF ((h11b .lt. h3b) .and. (p1b .le. p5b)) THEN
119      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
120     &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1
121     & + nvab * (p1b_1 - noab - 1 + nvab * (h3b_1 - 1 + noab * (h11b_1 -
122     & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1)))))))))
123      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
124     &,int_mb(k_range+h8b-1),int_mb(k_range+h11b-1),int_mb(k_range+h3b-1
125     &),int_mb(k_range+p1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1
126     &),int_mb(k_range+p10b-1),8,7,6,5,3,2,1,4,-1.0d0)
127      END IF
128      IF ((h8b .lt. h3b) .and. (h3b .le. h11b) .and. (p10b .lt. p1b)) TH
129     &EN
130      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1
131     & - noab - 1 + nvab * (p10b_1 - noab - 1 + nvab * (p9b_1 - noab - 1
132     & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h3b_1 -
133     & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1)))))))))
134      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
135     &,int_mb(k_range+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+h11b-1
136     &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p10b-
137     &1),int_mb(k_range+p1b-1),7,6,5,8,4,2,1,3,-1.0d0)
138      END IF
139      IF ((h8b .lt. h3b) .and. (h3b .le. h11b) .and. (p9b .lt. p1b) .and
140     &. (p1b .le. p10b)) THEN
141      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
142     &1 - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (p9b_1 - noab - 1
143     & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h3b_1 -
144     & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1)))))))))
145      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
146     &,int_mb(k_range+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+h11b-1
147     &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1
148     &),int_mb(k_range+p10b-1),8,6,5,7,4,2,1,3,1.0d0)
149      END IF
150      IF ((h8b .lt. h3b) .and. (h3b .le. h11b) .and. (p5b .lt. p1b) .and
151     &. (p1b .le. p9b)) THEN
152      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
153     &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p1b_1 - noab - 1
154     & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h3b_1 -
155     & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1)))))))))
156      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
157     &,int_mb(k_range+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+h11b-1
158     &),int_mb(k_range+p5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1
159     &),int_mb(k_range+p10b-1),8,7,5,6,4,2,1,3,-1.0d0)
160      END IF
161      IF ((h8b .lt. h3b) .and. (h3b .le. h11b) .and. (p1b .le. p5b)) THE
162     &N
163      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
164     &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1
165     & + nvab * (p1b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h3b_1 -
166     & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1)))))))))
167      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
168     &,int_mb(k_range+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+h11b-1
169     &),int_mb(k_range+p1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1
170     &),int_mb(k_range+p10b-1),8,7,6,5,4,2,1,3,1.0d0)
171      END IF
172      IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p10b .lt. p1b)) THE
173     &N
174      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1
175     & - noab - 1 + nvab * (p10b_1 - noab - 1 + nvab * (p9b_1 - noab - 1
176     & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 -
177     & 1 + noab * (h3b_1 - 1 + noab * (h7b_1 - 1)))))))))
178      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
179     &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1
180     &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p10b-
181     &1),int_mb(k_range+p1b-1),7,6,5,8,4,3,1,2,1.0d0)
182      END IF
183      IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p9b .lt. p1b) .and.
184     & (p1b .le. p10b)) THEN
185      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
186     &1 - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (p9b_1 - noab - 1
187     & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 -
188     & 1 + noab * (h3b_1 - 1 + noab * (h7b_1 - 1)))))))))
189      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
190     &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1
191     &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1
192     &),int_mb(k_range+p10b-1),8,6,5,7,4,3,1,2,-1.0d0)
193      END IF
194      IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p5b .lt. p1b) .and.
195     & (p1b .le. p9b)) THEN
196      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
197     &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p1b_1 - noab - 1
198     & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 -
199     & 1 + noab * (h3b_1 - 1 + noab * (h7b_1 - 1)))))))))
200      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
201     &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1
202     &),int_mb(k_range+p5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1
203     &),int_mb(k_range+p10b-1),8,7,5,6,4,3,1,2,1.0d0)
204      END IF
205      IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p1b .le. p5b)) THEN
206      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
207     &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1
208     & + nvab * (p1b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 -
209     & 1 + noab * (h3b_1 - 1 + noab * (h7b_1 - 1)))))))))
210      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
211     &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1
212     &),int_mb(k_range+p1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1
213     &),int_mb(k_range+p10b-1),8,7,6,5,4,3,1,2,-1.0d0)
214      END IF
215      IF ((h3b .le. h7b) .and. (p10b .lt. p1b)) THEN
216      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1
217     & - noab - 1 + nvab * (p10b_1 - noab - 1 + nvab * (p9b_1 - noab - 1
218     & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 -
219     & 1 + noab * (h7b_1 - 1 + noab * (h3b_1 - 1)))))))))
220      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1)
221     &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1
222     &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p10b-
223     &1),int_mb(k_range+p1b-1),7,6,5,8,4,3,2,1,-1.0d0)
224      END IF
225      IF ((h3b .le. h7b) .and. (p9b .lt. p1b) .and. (p1b .le. p10b)) THE
226     &N
227      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
228     &1 - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (p9b_1 - noab - 1
229     & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 -
230     & 1 + noab * (h7b_1 - 1 + noab * (h3b_1 - 1)))))))))
231      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1)
232     &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1
233     &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1
234     &),int_mb(k_range+p10b-1),8,6,5,7,4,3,2,1,1.0d0)
235      END IF
236      IF ((h3b .le. h7b) .and. (p5b .lt. p1b) .and. (p1b .le. p9b)) THEN
237      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
238     &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p1b_1 - noab - 1
239     & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 -
240     & 1 + noab * (h7b_1 - 1 + noab * (h3b_1 - 1)))))))))
241      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1)
242     &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1
243     &),int_mb(k_range+p5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1
244     &),int_mb(k_range+p10b-1),8,7,5,6,4,3,2,1,-1.0d0)
245      END IF
246      IF ((h3b .le. h7b) .and. (p1b .le. p5b)) THEN
247      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_
248     &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1
249     & + nvab * (p1b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 -
250     & 1 + noab * (h7b_1 - 1 + noab * (h3b_1 - 1)))))))))
251      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1)
252     &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1
253     &),int_mb(k_range+p1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1
254     &),int_mb(k_range+p10b-1),8,7,6,5,4,3,2,1,1.0d0)
255      END IF
256      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_lambda2_26_4_2_1'
257     &,2,MA_ERR)
258      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
259     &ccsdtq_lambda2_26_4_2_1',3,MA_ERR)
260      CALL TCE_SORT_8(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p10b-1
261     &),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1),int_mb(k_range+p1b-1
262     &),int_mb(k_range+h11b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-
263     &1),int_mb(k_range+h3b-1),8,7,6,5,4,3,2,1,1.0d0)
264      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p10b
265     &- noab - 1 + nvab * (p9b - noab - 1 + nvab * (p5b - noab - 1 + nva
266     &b * (p1b - noab - 1 + nvab * (h11b - 1 + noab * (h8b - 1 + noab *
267     &(h7b - 1 + noab * (h3b - 1)))))))))
268      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_lambda2_26_4_2_1'
269     &,4,MA_ERR)
270      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_lambda2_26_4
271     &_2_1',5,MA_ERR)
272      END IF
273      END IF
274      END IF
275      END IF
276      next = NXTASK(nprocs,1)
277      END IF
278      count = count + 1
279      END DO
280      END DO
281      END DO
282      END DO
283      END DO
284      END DO
285      END DO
286      END DO
287      next = NXTASK(-nprocs,1)
288      call GA_SYNC()
289      RETURN
290      END
291