1      SUBROUTINE ccsdtq_lr_alpha_15_12(d_a,k_a_offset,d_b,k_b_offset,d_c
2     &,k_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 ( p13 p17 h15 h16 )_ytrbtra + = 1/12 * Sum ( h5 h6 p1 p2 p3 ) * tra ( p1 p2 p3 p17 h5 h6 h15 h16 )_tra * i2 ( h5 h6 p13 p1 p2 p3 )_ytrb
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 p17b
24      INTEGER p13b
25      INTEGER h15b
26      INTEGER h16b
27      INTEGER dimc
28      INTEGER l_c_sort
29      INTEGER k_c_sort
30      INTEGER p1b
31      INTEGER p2b
32      INTEGER p3b
33      INTEGER h5b
34      INTEGER h6b
35      INTEGER p17b_1
36      INTEGER p1b_1
37      INTEGER p2b_1
38      INTEGER p3b_1
39      INTEGER h15b_1
40      INTEGER h16b_1
41      INTEGER h5b_1
42      INTEGER h6b_1
43      INTEGER p13b_2
44      INTEGER h5b_2
45      INTEGER h6b_2
46      INTEGER p1b_2
47      INTEGER p2b_2
48      INTEGER p3b_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 p17b = noab+1,noab+nvab
75      DO p13b = noab+1,noab+nvab
76      DO h15b = 1,noab
77      DO h16b = h15b,noab
78      IF (next.eq.count) THEN
79      IF ((.not.restricted).or.(int_mb(k_spin+p13b-1)+int_mb(k_spin+p17b
80     &-1)+int_mb(k_spin+h15b-1)+int_mb(k_spin+h16b-1).ne.8)) THEN
81      IF (int_mb(k_spin+p13b-1)+int_mb(k_spin+p17b-1) .eq. int_mb(k_spin
82     &+h15b-1)+int_mb(k_spin+h16b-1)) THEN
83      IF (ieor(int_mb(k_sym+p13b-1),ieor(int_mb(k_sym+p17b-1),ieor(int_m
84     &b(k_sym+h15b-1),int_mb(k_sym+h16b-1)))) .eq. ieor(irrep_y,ieor(irr
85     &ep_trb,irrep_tra))) THEN
86      dimc = int_mb(k_range+p13b-1) * int_mb(k_range+p17b-1) * int_mb(k_
87     &range+h15b-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_lr_alpha_15_12',0,MA_ERR)
90      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
91      DO p1b = noab+1,noab+nvab
92      DO p2b = p1b,noab+nvab
93      DO p3b = p2b,noab+nvab
94      DO h5b = 1,noab
95      DO h6b = h5b,noab
96      IF (int_mb(k_spin+p17b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1
97     &)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h15b-1)+int_mb(k_spin+h1
98     &6b-1)+int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)) THEN
99      IF (ieor(int_mb(k_sym+p17b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb
100     &(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h15b-1),i
101     &eor(int_mb(k_sym+h16b-1),ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+h6b
102     &-1)))))))) .eq. irrep_tra) THEN
103      CALL TCE_RESTRICTED_8(p17b,p1b,p2b,p3b,h15b,h16b,h5b,h6b,p17b_1,p1
104     &b_1,p2b_1,p3b_1,h15b_1,h16b_1,h5b_1,h6b_1)
105      CALL TCE_RESTRICTED_6(p13b,h5b,h6b,p1b,p2b,p3b,p13b_2,h5b_2,h6b_2,
106     &p1b_2,p2b_2,p3b_2)
107      dim_common = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) * int_m
108     &b(k_range+p3b-1) * int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1)
109      dima_sort = int_mb(k_range+p17b-1) * int_mb(k_range+h15b-1) * int_
110     &mb(k_range+h16b-1)
111      dima = dim_common * dima_sort
112      dimb_sort = int_mb(k_range+p13b-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_lr_alpha_15_12',1,MA_ERR)
117      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
118     &ccsdtq_lr_alpha_15_12',2,MA_ERR)
119      IF ((p3b .le. p17b) .and. (h6b .le. h15b)) THEN
120      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
121     &1 - 1 + noab * (h15b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1
122     & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * (
123     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
124      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
125     &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1
126     &),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h15b-
127     &1),int_mb(k_range+h16b-1),8,7,4,6,5,3,2,1,1.0d0)
128      END IF
129      IF ((p3b .le. p17b) .and. (h5b .le. h15b) .and. (h15b .lt. h6b) .a
130     &nd. (h6b .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 * (h6b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1
133     & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * (
134     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
135      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
136     &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1
137     &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h6b-
138     &1),int_mb(k_range+h16b-1),8,6,4,7,5,3,2,1,-1.0d0)
139      END IF
140      IF ((p3b .le. p17b) .and. (h5b .le. h15b) .and. (h16b .lt. h6b)) T
141     &HEN
142      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
143     & - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1
144     & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * (
145     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
146      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
147     &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1
148     &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h16b
149     &-1),int_mb(k_range+h6b-1),7,6,4,8,5,3,2,1,1.0d0)
150      END IF
151      IF ((p3b .le. p17b) .and. (h15b .lt. h5b) .and. (h6b .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 * (h6b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1
155     & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * (
156     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
157      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
158     &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1
159     &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b-
160     &1),int_mb(k_range+h16b-1),8,5,4,7,6,3,2,1,1.0d0)
161      END IF
162      IF ((p3b .le. p17b) .and. (h15b .lt. h5b) .and. (h5b .le. h16b) .a
163     &nd. (h16b .lt. h6b)) THEN
164      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
165     & - 1 + noab * (h16b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1
166     & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * (
167     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
168      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
169     &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1
170     &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h16b
171     &-1),int_mb(k_range+h6b-1),7,5,4,8,6,3,2,1,-1.0d0)
172      END IF
173      IF ((p3b .le. p17b) .and. (h16b .lt. h5b)) THEN
174      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
175     & - 1 + noab * (h5b_1 - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1
176     & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * (
177     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
178      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
179     &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1
180     &),int_mb(k_range+h15b-1),int_mb(k_range+h16b-1),int_mb(k_range+h5b
181     &-1),int_mb(k_range+h6b-1),6,5,4,8,7,3,2,1,1.0d0)
182      END IF
183      IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h6b .le. h15b)) 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 * (h15b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1
187     & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * (
188     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
189      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
190     &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1
191     &),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h15b-
192     &1),int_mb(k_range+h16b-1),8,7,3,6,5,4,2,1,-1.0d0)
193      END IF
194      IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h5b .le. h15b) .a
195     &nd. (h15b .lt. h6b) .and. (h6b .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 * (h6b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1
198     & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * (
199     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
200      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
201     &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1
202     &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h6b-
203     &1),int_mb(k_range+h16b-1),8,6,3,7,5,4,2,1,1.0d0)
204      END IF
205      IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h5b .le. h15b) .a
206     &nd. (h16b .lt. h6b)) THEN
207      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
208     & - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1
209     & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * (
210     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
211      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
212     &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1
213     &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h16b
214     &-1),int_mb(k_range+h6b-1),7,6,3,8,5,4,2,1,-1.0d0)
215      END IF
216      IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h15b .lt. h5b) .a
217     &nd. (h6b .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 * (h6b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1
220     & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * (
221     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
222      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
223     &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1
224     &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b-
225     &1),int_mb(k_range+h16b-1),8,5,3,7,6,4,2,1,-1.0d0)
226      END IF
227      IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h15b .lt. h5b) .a
228     &nd. (h5b .le. h16b) .and. (h16b .lt. h6b)) THEN
229      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
230     & - 1 + noab * (h16b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1
231     & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * (
232     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
233      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
234     &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1
235     &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h16b
236     &-1),int_mb(k_range+h6b-1),7,5,3,8,6,4,2,1,1.0d0)
237      END IF
238      IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h16b .lt. h5b)) T
239     &HEN
240      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
241     & - 1 + noab * (h5b_1 - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1
242     & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * (
243     &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
244      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
245     &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1
246     &),int_mb(k_range+h15b-1),int_mb(k_range+h16b-1),int_mb(k_range+h5b
247     &-1),int_mb(k_range+h6b-1),6,5,3,8,7,4,2,1,-1.0d0)
248      END IF
249      IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h6b .le. h15b)) 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 * (h15b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1
253     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
254     &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
255      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
256     &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
257     &),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h15b-
258     &1),int_mb(k_range+h16b-1),8,7,2,6,5,4,3,1,1.0d0)
259      END IF
260      IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h5b .le. h15b) .a
261     &nd. (h15b .lt. h6b) .and. (h6b .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 * (h6b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1
264     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
265     &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
266      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
267     &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
268     &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h6b-
269     &1),int_mb(k_range+h16b-1),8,6,2,7,5,4,3,1,-1.0d0)
270      END IF
271      IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h5b .le. h15b) .a
272     &nd. (h16b .lt. h6b)) THEN
273      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
274     & - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1
275     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
276     &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
277      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
278     &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
279     &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h16b
280     &-1),int_mb(k_range+h6b-1),7,6,2,8,5,4,3,1,1.0d0)
281      END IF
282      IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h15b .lt. h5b) .a
283     &nd. (h6b .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 * (h6b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1
286     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
287     &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
288      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
289     &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
290     &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b-
291     &1),int_mb(k_range+h16b-1),8,5,2,7,6,4,3,1,1.0d0)
292      END IF
293      IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h15b .lt. h5b) .a
294     &nd. (h5b .le. h16b) .and. (h16b .lt. h6b)) THEN
295      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
296     & - 1 + noab * (h16b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1
297     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
298     &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
299      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
300     &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
301     &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h16b
302     &-1),int_mb(k_range+h6b-1),7,5,2,8,6,4,3,1,-1.0d0)
303      END IF
304      IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h16b .lt. h5b)) T
305     &HEN
306      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
307     & - 1 + noab * (h5b_1 - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1
308     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
309     &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1)))))))))
310      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
311     &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
312     &),int_mb(k_range+h15b-1),int_mb(k_range+h16b-1),int_mb(k_range+h5b
313     &-1),int_mb(k_range+h6b-1),6,5,2,8,7,4,3,1,1.0d0)
314      END IF
315      IF ((p17b .lt. p1b) .and. (h6b .le. h15b)) THEN
316      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_
317     &1 - 1 + noab * (h15b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1
318     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
319     &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1)))))))))
320      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1
321     &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
322     &),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h15b-
323     &1),int_mb(k_range+h16b-1),8,7,1,6,5,4,3,2,-1.0d0)
324      END IF
325      IF ((p17b .lt. p1b) .and. (h5b .le. h15b) .and. (h15b .lt. h6b) .a
326     &nd. (h6b .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 * (h6b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1
329     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
330     &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1)))))))))
331      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1
332     &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
333     &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h6b-
334     &1),int_mb(k_range+h16b-1),8,6,1,7,5,4,3,2,1.0d0)
335      END IF
336      IF ((p17b .lt. p1b) .and. (h5b .le. h15b) .and. (h16b .lt. h6b)) T
337     &HEN
338      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
339     & - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1
340     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
341     &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1)))))))))
342      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1
343     &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
344     &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h16b
345     &-1),int_mb(k_range+h6b-1),7,6,1,8,5,4,3,2,-1.0d0)
346      END IF
347      IF ((p17b .lt. p1b) .and. (h15b .lt. h5b) .and. (h6b .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 * (h6b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1
351     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
352     &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1)))))))))
353      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1
354     &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
355     &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b-
356     &1),int_mb(k_range+h16b-1),8,5,1,7,6,4,3,2,-1.0d0)
357      END IF
358      IF ((p17b .lt. p1b) .and. (h15b .lt. h5b) .and. (h5b .le. h16b) .a
359     &nd. (h16b .lt. h6b)) THEN
360      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
361     & - 1 + noab * (h16b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1
362     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
363     &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1)))))))))
364      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1
365     &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
366     &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h16b
367     &-1),int_mb(k_range+h6b-1),7,5,1,8,6,4,3,2,1.0d0)
368      END IF
369      IF ((p17b .lt. p1b) .and. (h16b .lt. h5b)) THEN
370      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
371     & - 1 + noab * (h5b_1 - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1
372     & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p
373     &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1)))))))))
374      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1
375     &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1
376     &),int_mb(k_range+h15b-1),int_mb(k_range+h16b-1),int_mb(k_range+h5b
377     &-1),int_mb(k_range+h6b-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_lr_alpha_15_12',3
380     &,MA_ERR)
381      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
382     & ERRQUIT('ccsdtq_lr_alpha_15_12',4,MA_ERR)
383      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
384     &ccsdtq_lr_alpha_15_12',5,MA_ERR)
385      IF ((h6b .le. p13b)) THEN
386      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
387     & - noab - 1 + nvab * (p2b_2 - noab - 1 + nvab * (p1b_2 - noab - 1
388     &+ nvab * (p13b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab * (h5b_2 -
389     &1)))))))
390      CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
391     &,int_mb(k_range+h6b-1),int_mb(k_range+p13b-1),int_mb(k_range+p1b-1
392     &),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),3,2,1,6,5,4,1.0d0)
393      END IF
394      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_lr_alpha_15_12',6
395     &,MA_ERR)
396      nsuperp(1) = 1
397      nsuperp(2) = 1
398      nsuperp(3) = 1
399      isuperp = 1
400      IF (p1b .eq. p2b) THEN
401      nsuperp(isuperp) = nsuperp(isuperp) + 1
402      ELSE
403      isuperp = isuperp + 1
404      END IF
405      IF (p2b .eq. p3b) THEN
406      nsuperp(isuperp) = nsuperp(isuperp) + 1
407      ELSE
408      isuperp = isuperp + 1
409      END IF
410      nsubh(1) = 1
411      nsubh(2) = 1
412      isubh = 1
413      IF (h5b .eq. h6b) THEN
414      nsubh(isubh) = nsubh(isubh) + 1
415      ELSE
416      isubh = isubh + 1
417      END IF
418      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,12.0d0/FACTORIAL
419     &(nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsuperp(3))/FACTORIAL
420     &(nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(
421     &k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
422      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_
423     &12',7,MA_ERR)
424      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_
425     &12',8,MA_ERR)
426      END IF
427      END IF
428      END IF
429      END DO
430      END DO
431      END DO
432      END DO
433      END DO
434      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
435     &ccsdtq_lr_alpha_15_12',9,MA_ERR)
436      IF ((p13b .le. p17b)) THEN
437      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p13b-1
438     &),int_mb(k_range+h16b-1),int_mb(k_range+h15b-1),int_mb(k_range+p17
439     &b-1),1,4,3,2,1.0d0/24.0d0)
440      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h16b
441     &- 1 + noab * (h15b - 1 + noab * (p17b - noab - 1 + nvab * (p13b -
442     &noab - 1)))))
443      END IF
444      IF ((p17b .le. p13b)) THEN
445      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p13b-1
446     &),int_mb(k_range+h16b-1),int_mb(k_range+h15b-1),int_mb(k_range+p17
447     &b-1),4,1,3,2,-1.0d0/24.0d0)
448      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h16b
449     &- 1 + noab * (h15b - 1 + noab * (p13b - noab - 1 + nvab * (p17b -
450     &noab - 1)))))
451      END IF
452      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_lr_alpha_15_12',1
453     &0,MA_ERR)
454      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_
455     &12',11,MA_ERR)
456      END IF
457      END IF
458      END IF
459      next = nxtask(nprocs,1)
460      END IF
461      count = count + 1
462      END DO
463      END DO
464      END DO
465      END DO
466      next = nxtask(-nprocs,1)
467      call GA_SYNC()
468      RETURN
469      END
470