1      SUBROUTINE eomccsdtq_y2_23_4(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 ( p5 p15 p17 h13 h16 p1 )_vt + = -1/6 * Sum ( h11 h12 p8 ) * t ( p5 p8 p15 p17 h11 h12 h13 h16 )_t * v ( h11 h12 p1 p8 )_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 p5b
24      INTEGER p15b
25      INTEGER p17b
26      INTEGER p1b
27      INTEGER h13b
28      INTEGER h16b
29      INTEGER dimc
30      INTEGER l_c_sort
31      INTEGER k_c_sort
32      INTEGER p8b
33      INTEGER h11b
34      INTEGER h12b
35      INTEGER p5b_1
36      INTEGER p15b_1
37      INTEGER p17b_1
38      INTEGER p8b_1
39      INTEGER h13b_1
40      INTEGER h16b_1
41      INTEGER h11b_1
42      INTEGER h12b_1
43      INTEGER h11b_2
44      INTEGER h12b_2
45      INTEGER p1b_2
46      INTEGER p8b_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 nsubh(2)
61      INTEGER isubh
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 p5b = noab+1,noab+nvab
71      DO p15b = p5b,noab+nvab
72      DO p17b = p15b,noab+nvab
73      DO p1b = noab+1,noab+nvab
74      DO h13b = 1,noab
75      DO h16b = h13b,noab
76      IF (next.eq.count) THEN
77      IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+p15b-
78     &1)+int_mb(k_spin+p17b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+h13b-1
79     &)+int_mb(k_spin+h16b-1).ne.12)) THEN
80      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p15b-1)+int_mb(k_spin+p17b-
81     &1) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+h13b-1)+int_mb(k_spin+h
82     &16b-1)) THEN
83      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p15b-1),ieor(int_mb
84     &(k_sym+p17b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+h13b-1),
85     &int_mb(k_sym+h16b-1)))))) .eq. ieor(irrep_v,irrep_t)) THEN
86      dimc = int_mb(k_range+p5b-1) * int_mb(k_range+p15b-1) * int_mb(k_r
87     &ange+p17b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+h13b-1) * in
88     &t_mb(k_range+h16b-1)
89      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
90     & ERRQUIT('eomccsdtq_y2_23_4',0,MA_ERR)
91      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
92      DO p8b = noab+1,noab+nvab
93      DO h11b = 1,noab
94      DO h12b = h11b,noab
95      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p15b-1)+int_mb(k_spin+p17b-
96     &1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h13b-1)+int_mb(k_spin+h
97     &16b-1)+int_mb(k_spin+h11b-1)+int_mb(k_spin+h12b-1)) THEN
98      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p15b-1),ieor(int_mb
99     &(k_sym+p17b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h13b-1),
100     &ieor(int_mb(k_sym+h16b-1),ieor(int_mb(k_sym+h11b-1),int_mb(k_sym+h
101     &12b-1)))))))) .eq. irrep_t) THEN
102      CALL TCE_RESTRICTED_8(p5b,p15b,p17b,p8b,h13b,h16b,h11b,h12b,p5b_1,
103     &p15b_1,p17b_1,p8b_1,h13b_1,h16b_1,h11b_1,h12b_1)
104      CALL TCE_RESTRICTED_4(h11b,h12b,p1b,p8b,h11b_2,h12b_2,p1b_2,p8b_2)
105      dim_common = int_mb(k_range+p8b-1) * int_mb(k_range+h11b-1) * int_
106     &mb(k_range+h12b-1)
107      dima_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p15b-1) * int_m
108     &b(k_range+p17b-1) * int_mb(k_range+h13b-1) * int_mb(k_range+h16b-1
109     &)
110      dima = dim_common * dima_sort
111      dimb_sort = int_mb(k_range+p1b-1)
112      dimb = dim_common * dimb_sort
113      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
114      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
115     & ERRQUIT('eomccsdtq_y2_23_4',1,MA_ERR)
116      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
117     &eomccsdtq_y2_23_4',2,MA_ERR)
118      IF ((p8b .lt. p5b) .and. (h12b .le. h13b)) THEN
119      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
120     &1 - 1 + noab * (h13b_1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 -
121     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
122     &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
123      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
124     &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
125     &1),int_mb(k_range+h11b-1),int_mb(k_range+h12b-1),int_mb(k_range+h1
126     &3b-1),int_mb(k_range+h16b-1),8,7,4,3,2,6,5,1,-1.0d0)
127      END IF
128      IF ((p8b .lt. p5b) .and. (h11b .le. h13b) .and. (h13b .lt. h12b) .
129     &and. (h12b .le. h16b)) THEN
130      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
131     &1 - 1 + noab * (h12b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 -
132     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
133     &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
134      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
135     &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
136     &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1
137     &2b-1),int_mb(k_range+h16b-1),8,6,4,3,2,7,5,1,1.0d0)
138      END IF
139      IF ((p8b .lt. p5b) .and. (h11b .le. h13b) .and. (h16b .lt. h12b))
140     &THEN
141      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
142     &1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 -
143     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
144     &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
145      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
146     &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
147     &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1
148     &6b-1),int_mb(k_range+h12b-1),7,6,4,3,2,8,5,1,-1.0d0)
149      END IF
150      IF ((p8b .lt. p5b) .and. (h13b .lt. h11b) .and. (h12b .le. h16b))
151     &THEN
152      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
153     &1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 -
154     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
155     &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
156      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
157     &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
158     &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1
159     &2b-1),int_mb(k_range+h16b-1),8,5,4,3,2,7,6,1,-1.0d0)
160      END IF
161      IF ((p8b .lt. p5b) .and. (h13b .lt. h11b) .and. (h11b .le. h16b) .
162     &and. (h16b .lt. h12b)) THEN
163      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
164     &1 - 1 + noab * (h16b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 -
165     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
166     &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
167      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
168     &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
169     &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1
170     &6b-1),int_mb(k_range+h12b-1),7,5,4,3,2,8,6,1,1.0d0)
171      END IF
172      IF ((p8b .lt. p5b) .and. (h16b .lt. h11b)) THEN
173      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
174     &1 - 1 + noab * (h11b_1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 -
175     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
176     &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1)))))))))
177      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
178     &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
179     &1),int_mb(k_range+h13b-1),int_mb(k_range+h16b-1),int_mb(k_range+h1
180     &1b-1),int_mb(k_range+h12b-1),6,5,4,3,2,8,7,1,-1.0d0)
181      END IF
182      IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h12b .le. h13b)) T
183     &HEN
184      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
185     &1 - 1 + noab * (h13b_1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 -
186     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
187     &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
188      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
189     &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
190     &1),int_mb(k_range+h11b-1),int_mb(k_range+h12b-1),int_mb(k_range+h1
191     &3b-1),int_mb(k_range+h16b-1),8,7,4,3,1,6,5,2,1.0d0)
192      END IF
193      IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h11b .le. h13b) .a
194     &nd. (h13b .lt. h12b) .and. (h12b .le. h16b)) THEN
195      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
196     &1 - 1 + noab * (h12b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 -
197     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
198     &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
199      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
200     &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
201     &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1
202     &2b-1),int_mb(k_range+h16b-1),8,6,4,3,1,7,5,2,-1.0d0)
203      END IF
204      IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h11b .le. h13b) .a
205     &nd. (h16b .lt. h12b)) THEN
206      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
207     &1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 -
208     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
209     &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
210      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
211     &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
212     &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1
213     &6b-1),int_mb(k_range+h12b-1),7,6,4,3,1,8,5,2,1.0d0)
214      END IF
215      IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h13b .lt. h11b) .a
216     &nd. (h12b .le. h16b)) THEN
217      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
218     &1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 -
219     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
220     &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
221      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
222     &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
223     &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1
224     &2b-1),int_mb(k_range+h16b-1),8,5,4,3,1,7,6,2,1.0d0)
225      END IF
226      IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h13b .lt. h11b) .a
227     &nd. (h11b .le. h16b) .and. (h16b .lt. h12b)) THEN
228      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
229     &1 - 1 + noab * (h16b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 -
230     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
231     &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
232      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
233     &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
234     &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1
235     &6b-1),int_mb(k_range+h12b-1),7,5,4,3,1,8,6,2,-1.0d0)
236      END IF
237      IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h16b .lt. h11b)) T
238     &HEN
239      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
240     &1 - 1 + noab * (h11b_1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 -
241     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab
242     &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
243      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
244     &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b-
245     &1),int_mb(k_range+h13b-1),int_mb(k_range+h16b-1),int_mb(k_range+h1
246     &1b-1),int_mb(k_range+h12b-1),6,5,4,3,1,8,7,2,1.0d0)
247      END IF
248      IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h12b .le. h13b))
249     &THEN
250      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
251     &1 - 1 + noab * (h13b_1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 -
252     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab *
253     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
254      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
255     &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b-
256     &1),int_mb(k_range+h11b-1),int_mb(k_range+h12b-1),int_mb(k_range+h1
257     &3b-1),int_mb(k_range+h16b-1),8,7,4,2,1,6,5,3,-1.0d0)
258      END IF
259      IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h11b .le. h13b) .
260     &and. (h13b .lt. h12b) .and. (h12b .le. h16b)) THEN
261      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
262     &1 - 1 + noab * (h12b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 -
263     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab *
264     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
265      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
266     &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b-
267     &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1
268     &2b-1),int_mb(k_range+h16b-1),8,6,4,2,1,7,5,3,1.0d0)
269      END IF
270      IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h11b .le. h13b) .
271     &and. (h16b .lt. h12b)) THEN
272      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
273     &1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 -
274     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab *
275     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
276      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
277     &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b-
278     &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1
279     &6b-1),int_mb(k_range+h12b-1),7,6,4,2,1,8,5,3,-1.0d0)
280      END IF
281      IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h13b .lt. h11b) .
282     &and. (h12b .le. h16b)) THEN
283      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
284     &1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 -
285     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab *
286     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
287      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
288     &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b-
289     &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1
290     &2b-1),int_mb(k_range+h16b-1),8,5,4,2,1,7,6,3,-1.0d0)
291      END IF
292      IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h13b .lt. h11b) .
293     &and. (h11b .le. h16b) .and. (h16b .lt. h12b)) THEN
294      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
295     &1 - 1 + noab * (h16b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 -
296     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab *
297     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
298      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
299     &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b-
300     &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1
301     &6b-1),int_mb(k_range+h12b-1),7,5,4,2,1,8,6,3,1.0d0)
302      END IF
303      IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h16b .lt. h11b))
304     &THEN
305      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
306     &1 - 1 + noab * (h11b_1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 -
307     & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab *
308     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
309      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
310     &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b-
311     &1),int_mb(k_range+h13b-1),int_mb(k_range+h16b-1),int_mb(k_range+h1
312     &1b-1),int_mb(k_range+h12b-1),6,5,4,2,1,8,7,3,-1.0d0)
313      END IF
314      IF ((p17b .lt. p8b) .and. (h12b .le. h13b)) THEN
315      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
316     &1 - 1 + noab * (h13b_1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 -
317     & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab *
318     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
319      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
320     &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b-
321     &1),int_mb(k_range+h11b-1),int_mb(k_range+h12b-1),int_mb(k_range+h1
322     &3b-1),int_mb(k_range+h16b-1),8,7,3,2,1,6,5,4,1.0d0)
323      END IF
324      IF ((p17b .lt. p8b) .and. (h11b .le. h13b) .and. (h13b .lt. h12b)
325     &.and. (h12b .le. h16b)) THEN
326      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
327     &1 - 1 + noab * (h12b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 -
328     & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab *
329     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
330      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
331     &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b-
332     &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1
333     &2b-1),int_mb(k_range+h16b-1),8,6,3,2,1,7,5,4,-1.0d0)
334      END IF
335      IF ((p17b .lt. p8b) .and. (h11b .le. h13b) .and. (h16b .lt. h12b))
336     & THEN
337      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
338     &1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 -
339     & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab *
340     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
341      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
342     &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b-
343     &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1
344     &6b-1),int_mb(k_range+h12b-1),7,6,3,2,1,8,5,4,1.0d0)
345      END IF
346      IF ((p17b .lt. p8b) .and. (h13b .lt. h11b) .and. (h12b .le. h16b))
347     & THEN
348      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
349     &1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 -
350     & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab *
351     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
352      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
353     &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b-
354     &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1
355     &2b-1),int_mb(k_range+h16b-1),8,5,3,2,1,7,6,4,1.0d0)
356      END IF
357      IF ((p17b .lt. p8b) .and. (h13b .lt. h11b) .and. (h11b .le. h16b)
358     &.and. (h16b .lt. h12b)) THEN
359      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
360     &1 - 1 + noab * (h16b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 -
361     & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab *
362     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
363      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
364     &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b-
365     &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1
366     &6b-1),int_mb(k_range+h12b-1),7,5,3,2,1,8,6,4,-1.0d0)
367      END IF
368      IF ((p17b .lt. p8b) .and. (h16b .lt. h11b)) THEN
369      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_
370     &1 - 1 + noab * (h11b_1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 -
371     & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab *
372     & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
373      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
374     &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b-
375     &1),int_mb(k_range+h13b-1),int_mb(k_range+h16b-1),int_mb(k_range+h1
376     &1b-1),int_mb(k_range+h12b-1),6,5,3,2,1,8,7,4,1.0d0)
377      END IF
378      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsdtq_y2_23_4',3,MA_
379     &ERR)
380      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
381     & ERRQUIT('eomccsdtq_y2_23_4',4,MA_ERR)
382      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
383     &eomccsdtq_y2_23_4',5,MA_ERR)
384      IF ((p8b .lt. p1b)) THEN
385      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2
386     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h12b_2 - 1 + (noa
387     &b+nvab) * (h11b_2 - 1)))))
388      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h11b-1
389     &),int_mb(k_range+h12b-1),int_mb(k_range+p8b-1),int_mb(k_range+p1b-
390     &1),4,2,1,3,-1.0d0)
391      END IF
392      IF ((p1b .le. p8b)) THEN
393      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
394     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h12b_2 - 1 + (noa
395     &b+nvab) * (h11b_2 - 1)))))
396      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h11b-1
397     &),int_mb(k_range+h12b-1),int_mb(k_range+p1b-1),int_mb(k_range+p8b-
398     &1),3,2,1,4,1.0d0)
399      END IF
400      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsdtq_y2_23_4',6,MA_
401     &ERR)
402      nsubh(1) = 1
403      nsubh(2) = 1
404      isubh = 1
405      IF (h11b .eq. h12b) THEN
406      nsubh(isubh) = nsubh(isubh) + 1
407      ELSE
408      isubh = isubh + 1
409      END IF
410      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
411     &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k
412     &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
413      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsdtq_y2_23_4',
414     &7,MA_ERR)
415      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsdtq_y2_23_4',
416     &8,MA_ERR)
417      END IF
418      END IF
419      END IF
420      END DO
421      END DO
422      END DO
423      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
424     &eomccsdtq_y2_23_4',9,MA_ERR)
425      CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1)
426     &,int_mb(k_range+h16b-1),int_mb(k_range+h13b-1),int_mb(k_range+p17b
427     &-1),int_mb(k_range+p15b-1),int_mb(k_range+p5b-1),6,5,4,1,3,2,-1.0d
428     &0/6.0d0)
429      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h16b
430     &- 1 + noab * (h13b - 1 + noab * (p1b - noab - 1 + nvab * (p17b - n
431     &oab - 1 + nvab * (p15b - noab - 1 + nvab * (p5b - noab - 1)))))))
432      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsdtq_y2_23_4',10,MA
433     &_ERR)
434      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsdtq_y2_23_4',
435     &11,MA_ERR)
436      END IF
437      END IF
438      END IF
439      next = NXTASK(nprocs,1)
440      END IF
441      count = count + 1
442      END DO
443      END DO
444      END DO
445      END DO
446      END DO
447      END DO
448      next = NXTASK(-nprocs,1)
449      call GA_SYNC()
450      RETURN
451      END
452