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