1      SUBROUTINE eomccsdtq_x3_10(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
2     &ffset)
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     i0 ( p4 p5 p6 h1 h2 h3 )_xv + = -1/2 * P( 3 ) * Sum ( p9 p8 h7 ) * x ( p4 p5 p8 p9 h1 h2 h3 h7 )_x * v ( h7 p6 p8 p9 )_v
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 p4b
24      INTEGER p5b
25      INTEGER p6b
26      INTEGER h1b
27      INTEGER h2b
28      INTEGER h3b
29      INTEGER dimc
30      INTEGER l_c_sort
31      INTEGER k_c_sort
32      INTEGER p8b
33      INTEGER p9b
34      INTEGER h7b
35      INTEGER p4b_1
36      INTEGER p5b_1
37      INTEGER p8b_1
38      INTEGER p9b_1
39      INTEGER h1b_1
40      INTEGER h2b_1
41      INTEGER h3b_1
42      INTEGER h7b_1
43      INTEGER p6b_2
44      INTEGER h7b_2
45      INTEGER p8b_2
46      INTEGER p9b_2
47      INTEGER dim_common
48      INTEGER dima_sort
49      INTEGER dima
50      INTEGER dimb_sort
51      INTEGER dimb
52      INTEGER l_a_sort
53      INTEGER k_a_sort
54      INTEGER l_a
55      INTEGER k_a
56      INTEGER l_b_sort
57      INTEGER k_b_sort
58      INTEGER l_b
59      INTEGER k_b
60      INTEGER nsuperp(2)
61      INTEGER isuperp
62      INTEGER l_c
63      INTEGER k_c
64      DOUBLE PRECISION FACTORIAL
65      EXTERNAL NXTASK
66      EXTERNAL FACTORIAL
67      nprocs = GA_NNODES()
68      count = 0
69      next = NXTASK(nprocs,1)
70      DO p4b = noab+1,noab+nvab
71      DO p5b = p4b,noab+nvab
72      DO p6b = noab+1,noab+nvab
73      DO h1b = 1,noab
74      DO h2b = h1b,noab
75      DO h3b = h2b,noab
76      IF (next.eq.count) THEN
77      IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1
78     &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i
79     &nt_mb(k_spin+h3b-1).ne.12)) THEN
80      IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)
81     & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-
82     &1)) THEN
83      IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
84     &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int
85     &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_x,irrep_v)) THEN
86      dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra
87     &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m
88     &b(k_range+h3b-1)
89      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
90     & ERRQUIT('eomccsdtq_x3_10',0,MA_ERR)
91      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
92      DO p8b = noab+1,noab+nvab
93      DO p9b = p8b,noab+nvab
94      DO h7b = 1,noab
95      IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p8b-1)
96     &+int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-
97     &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h7b-1)) THEN
98      IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
99     &k_sym+p8b-1),ieor(int_mb(k_sym+p9b-1),ieor(int_mb(k_sym+h1b-1),ieo
100     &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h7b-1)
101     &))))))) .eq. irrep_x) THEN
102      CALL TCE_RESTRICTED_8(p4b,p5b,p8b,p9b,h1b,h2b,h3b,h7b,p4b_1,p5b_1,
103     &p8b_1,p9b_1,h1b_1,h2b_1,h3b_1,h7b_1)
104      CALL TCE_RESTRICTED_4(p6b,h7b,p8b,p9b,p6b_2,h7b_2,p8b_2,p9b_2)
105      dim_common = int_mb(k_range+p8b-1) * int_mb(k_range+p9b-1) * int_m
106     &b(k_range+h7b-1)
107      dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb
108     &(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_mb(k_range+h3b-1)
109      dima = dim_common * dima_sort
110      dimb_sort = int_mb(k_range+p6b-1)
111      dimb = dim_common * dimb_sort
112      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
113      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
114     & ERRQUIT('eomccsdtq_x3_10',1,MA_ERR)
115      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
116     &eomccsdtq_x3_10',2,MA_ERR)
117      IF ((p9b .lt. p4b) .and. (h7b .lt. h1b)) THEN
118      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
119     & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 +
120     & noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p9b
121     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
122      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
123     &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1)
124     &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
125     &,int_mb(k_range+h3b-1),8,7,6,4,3,5,2,1,-1.0d0)
126      END IF
127      IF ((p9b .lt. p4b) .and. (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN
128      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
129     & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 +
130     & noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p9b
131     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
132      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
133     &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1)
134     &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1)
135     &,int_mb(k_range+h3b-1),8,7,5,4,3,6,2,1,1.0d0)
136      END IF
137      IF ((p9b .lt. p4b) .and. (h2b .le. h7b) .and. (h7b .lt. h3b)) THEN
138      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
139     & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
140     & noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p9b
141     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
142      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
143     &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1)
144     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1)
145     &,int_mb(k_range+h3b-1),8,6,5,4,3,7,2,1,-1.0d0)
146      END IF
147      IF ((p9b .lt. p4b) .and. (h3b .le. h7b)) THEN
148      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
149     & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
150     & noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p9b
151     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
152      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
153     &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1)
154     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1)
155     &,int_mb(k_range+h7b-1),7,6,5,4,3,8,2,1,1.0d0)
156      END IF
157      IF ((p8b .lt. p4b) .and. (p4b .le. p9b) .and. (p9b .lt. p5b) .and.
158     & (h7b .lt. h1b)) THEN
159      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
160     & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 +
161     & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p4b
162     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
163      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
164     &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1)
165     &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
166     &,int_mb(k_range+h3b-1),8,7,6,4,2,5,3,1,1.0d0)
167      END IF
168      IF ((p8b .lt. p4b) .and. (p4b .le. p9b) .and. (p9b .lt. p5b) .and.
169     & (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN
170      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
171     & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 +
172     & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p4b
173     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
174      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
175     &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1)
176     &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1)
177     &,int_mb(k_range+h3b-1),8,7,5,4,2,6,3,1,-1.0d0)
178      END IF
179      IF ((p8b .lt. p4b) .and. (p4b .le. p9b) .and. (p9b .lt. p5b) .and.
180     & (h2b .le. h7b) .and. (h7b .lt. h3b)) THEN
181      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
182     & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
183     & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p4b
184     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
185      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
186     &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1)
187     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1)
188     &,int_mb(k_range+h3b-1),8,6,5,4,2,7,3,1,1.0d0)
189      END IF
190      IF ((p8b .lt. p4b) .and. (p4b .le. p9b) .and. (p9b .lt. p5b) .and.
191     & (h3b .le. h7b)) THEN
192      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
193     & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
194     & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p4b
195     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
196      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
197     &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1)
198     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1)
199     &,int_mb(k_range+h7b-1),7,6,5,4,2,8,3,1,-1.0d0)
200      END IF
201      IF ((p8b .lt. p4b) .and. (p5b .le. p9b) .and. (h7b .lt. h1b)) THEN
202      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
203     & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 +
204     & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b
205     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
206      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
207     &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1)
208     &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
209     &,int_mb(k_range+h3b-1),8,7,6,3,2,5,4,1,-1.0d0)
210      END IF
211      IF ((p8b .lt. p4b) .and. (p5b .le. p9b) .and. (h1b .le. h7b) .and.
212     & (h7b .lt. h2b)) THEN
213      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
214     & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 +
215     & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b
216     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
217      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
218     &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1)
219     &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1)
220     &,int_mb(k_range+h3b-1),8,7,5,3,2,6,4,1,1.0d0)
221      END IF
222      IF ((p8b .lt. p4b) .and. (p5b .le. p9b) .and. (h2b .le. h7b) .and.
223     & (h7b .lt. h3b)) THEN
224      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
225     & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
226     & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b
227     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
228      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
229     &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1)
230     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1)
231     &,int_mb(k_range+h3b-1),8,6,5,3,2,7,4,1,-1.0d0)
232      END IF
233      IF ((p8b .lt. p4b) .and. (p5b .le. p9b) .and. (h3b .le. h7b)) THEN
234      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
235     & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
236     & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b
237     &_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
238      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
239     &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1)
240     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1)
241     &,int_mb(k_range+h7b-1),7,6,5,3,2,8,4,1,1.0d0)
242      END IF
243      IF ((p4b .le. p8b) .and. (p9b .lt. p5b) .and. (h7b .lt. h1b)) THEN
244      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
245     & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 +
246     & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p8b
247     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
248      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
249     &,int_mb(k_range+p8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1)
250     &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
251     &,int_mb(k_range+h3b-1),8,7,6,4,1,5,3,2,-1.0d0)
252      END IF
253      IF ((p4b .le. p8b) .and. (p9b .lt. p5b) .and. (h1b .le. h7b) .and.
254     & (h7b .lt. h2b)) THEN
255      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
256     & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 +
257     & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p8b
258     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
259      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
260     &,int_mb(k_range+p8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1)
261     &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1)
262     &,int_mb(k_range+h3b-1),8,7,5,4,1,6,3,2,1.0d0)
263      END IF
264      IF ((p4b .le. p8b) .and. (p9b .lt. p5b) .and. (h2b .le. h7b) .and.
265     & (h7b .lt. h3b)) THEN
266      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
267     & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
268     & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p8b
269     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
270      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
271     &,int_mb(k_range+p8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1)
272     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1)
273     &,int_mb(k_range+h3b-1),8,6,5,4,1,7,3,2,-1.0d0)
274      END IF
275      IF ((p4b .le. p8b) .and. (p9b .lt. p5b) .and. (h3b .le. h7b)) THEN
276      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
277     & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
278     & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p8b
279     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
280      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
281     &,int_mb(k_range+p8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1)
282     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1)
283     &,int_mb(k_range+h7b-1),7,6,5,4,1,8,3,2,1.0d0)
284      END IF
285      IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (p5b .le. p9b) .and.
286     & (h7b .lt. h1b)) THEN
287      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
288     & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 +
289     & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p8b
290     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
291      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
292     &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1)
293     &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
294     &,int_mb(k_range+h3b-1),8,7,6,3,1,5,4,2,1.0d0)
295      END IF
296      IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (p5b .le. p9b) .and.
297     & (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN
298      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
299     & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 +
300     & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p8b
301     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
302      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
303     &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1)
304     &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1)
305     &,int_mb(k_range+h3b-1),8,7,5,3,1,6,4,2,-1.0d0)
306      END IF
307      IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (p5b .le. p9b) .and.
308     & (h2b .le. h7b) .and. (h7b .lt. h3b)) THEN
309      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
310     & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
311     & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p8b
312     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
313      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
314     &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1)
315     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1)
316     &,int_mb(k_range+h3b-1),8,6,5,3,1,7,4,2,1.0d0)
317      END IF
318      IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (p5b .le. p9b) .and.
319     & (h3b .le. h7b)) THEN
320      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
321     & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
322     & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p8b
323     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
324      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
325     &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1)
326     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1)
327     &,int_mb(k_range+h7b-1),7,6,5,3,1,8,4,2,-1.0d0)
328      END IF
329      IF ((p5b .le. p8b) .and. (h7b .lt. h1b)) THEN
330      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
331     & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 +
332     & noab * (p9b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * (p5b
333     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
334      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
335     &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1)
336     &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
337     &,int_mb(k_range+h3b-1),8,7,6,2,1,5,4,3,-1.0d0)
338      END IF
339      IF ((p5b .le. p8b) .and. (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN
340      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
341     & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 +
342     & noab * (p9b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * (p5b
343     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
344      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
345     &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1)
346     &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1)
347     &,int_mb(k_range+h3b-1),8,7,5,2,1,6,4,3,1.0d0)
348      END IF
349      IF ((p5b .le. p8b) .and. (h2b .le. h7b) .and. (h7b .lt. h3b)) THEN
350      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
351     & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
352     & noab * (p9b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * (p5b
353     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
354      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
355     &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1)
356     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1)
357     &,int_mb(k_range+h3b-1),8,6,5,2,1,7,4,3,-1.0d0)
358      END IF
359      IF ((p5b .le. p8b) .and. (h3b .le. h7b)) THEN
360      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
361     & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 +
362     & noab * (p9b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * (p5b
363     &_1 - noab - 1 + nvab * (p4b_1 - noab - 1)))))))))
364      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
365     &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1)
366     &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1)
367     &,int_mb(k_range+h7b-1),7,6,5,2,1,8,4,3,1.0d0)
368      END IF
369      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsdtq_x3_10',3,MA_ER
370     &R)
371      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
372     & ERRQUIT('eomccsdtq_x3_10',4,MA_ERR)
373      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
374     &eomccsdtq_x3_10',5,MA_ERR)
375      IF ((h7b .le. p6b)) THEN
376      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
377     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (p6b_2 - 1 + (noab
378     &+nvab) * (h7b_2 - 1)))))
379      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
380     &,int_mb(k_range+p6b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1)
381     &,2,1,4,3,1.0d0)
382      END IF
383      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsdtq_x3_10',6,MA_ER
384     &R)
385      nsuperp(1) = 1
386      nsuperp(2) = 1
387      isuperp = 1
388      IF (p8b .eq. p9b) THEN
389      nsuperp(isuperp) = nsuperp(isuperp) + 1
390      ELSE
391      isuperp = isuperp + 1
392      END IF
393      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
394     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
395     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
396      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsdtq_x3_10',7,
397     &MA_ERR)
398      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsdtq_x3_10',8,
399     &MA_ERR)
400      END IF
401      END IF
402      END IF
403      END DO
404      END DO
405      END DO
406      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
407     &eomccsdtq_x3_10',9,MA_ERR)
408      IF ((p5b .le. p6b)) THEN
409      CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p6b-1)
410     &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1)
411     &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,1,4,3,2,-1.0d0/2.
412     &0d0)
413      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b -
414     & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 +
415     &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1)))))))
416      END IF
417      IF ((p6b .le. p4b)) THEN
418      CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p6b-1)
419     &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1)
420     &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),1,6,5,4,3,2,-1.0d0/2.
421     &0d0)
422      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b -
423     & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p5b - noab - 1 +
424     &nvab * (p4b - noab - 1 + nvab * (p6b - noab - 1)))))))
425      END IF
426      IF ((p4b .le. p6b) .and. (p6b .le. p5b)) THEN
427      CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p6b-1)
428     &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1)
429     &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,1,5,4,3,2,1.0d0/2.0
430     &d0)
431      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b -
432     & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p5b - noab - 1 +
433     &nvab * (p6b - noab - 1 + nvab * (p4b - noab - 1)))))))
434      END IF
435      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsdtq_x3_10',10,MA_E
436     &RR)
437      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsdtq_x3_10',11
438     &,MA_ERR)
439      END IF
440      END IF
441      END IF
442      next = NXTASK(nprocs,1)
443      END IF
444      count = count + 1
445      END DO
446      END DO
447      END DO
448      END DO
449      END DO
450      END DO
451      next = NXTASK(-nprocs,1)
452      call GA_SYNC()
453      RETURN
454      END
455