1      SUBROUTINE ccsdtq_lr_alpha_15_32_1_2(d_a,k_a_offset,d_b,k_b_offset
2     &,d_c,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     i3 ( h2 h15 )_yt + = -1/12 * Sum ( h9 h10 h11 p5 p6 p7 p8 ) * t ( p5 p6 p7 p8 h9 h10 h11 h15 )_t * y ( h2 h9 h10 h11 p5 p6 p7 p8 )_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 h15b
25      INTEGER dimc
26      INTEGER l_c_sort
27      INTEGER k_c_sort
28      INTEGER p5b
29      INTEGER p6b
30      INTEGER p7b
31      INTEGER p8b
32      INTEGER h9b
33      INTEGER h10b
34      INTEGER h11b
35      INTEGER p5b_1
36      INTEGER p6b_1
37      INTEGER p7b_1
38      INTEGER p8b_1
39      INTEGER h15b_1
40      INTEGER h9b_1
41      INTEGER h10b_1
42      INTEGER h11b_1
43      INTEGER h2b_2
44      INTEGER h9b_2
45      INTEGER h10b_2
46      INTEGER h11b_2
47      INTEGER p5b_2
48      INTEGER p6b_2
49      INTEGER p7b_2
50      INTEGER p8b_2
51      INTEGER dim_common
52      INTEGER dima_sort
53      INTEGER dima
54      INTEGER dimb_sort
55      INTEGER dimb
56      INTEGER l_a_sort
57      INTEGER k_a_sort
58      INTEGER l_a
59      INTEGER k_a
60      INTEGER l_b_sort
61      INTEGER k_b_sort
62      INTEGER l_b
63      INTEGER k_b
64      INTEGER nsuperp(4)
65      INTEGER isuperp
66      INTEGER nsubh(3)
67      INTEGER isubh
68      INTEGER l_c
69      INTEGER k_c
70      DOUBLE PRECISION FACTORIAL
71      EXTERNAL nxtask
72      EXTERNAL FACTORIAL
73      nprocs = GA_NNODES()
74      count = 0
75      next = nxtask(nprocs,1)
76      DO h2b = 1,noab
77      DO h15b = 1,noab
78      IF (next.eq.count) THEN
79      IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h15b-
80     &1).ne.4)) THEN
81      IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h15b-1)) THEN
82      IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h15b-1)) .eq. ieor(irrep
83     &_y,irrep_t)) THEN
84      dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h15b-1)
85      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
86     & ERRQUIT('ccsdtq_lr_alpha_15_32_1_2',0,MA_ERR)
87      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
88      DO p5b = noab+1,noab+nvab
89      DO p6b = p5b,noab+nvab
90      DO p7b = p6b,noab+nvab
91      DO p8b = p7b,noab+nvab
92      DO h9b = 1,noab
93      DO h10b = h9b,noab
94      DO h11b = h10b,noab
95      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1)
96     &+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h15b-1)+int_mb(k_spin+h9b
97     &-1)+int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1)) THEN
98      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb(
99     &k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h15b-1),ie
100     &or(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+h11b
101     &-1)))))))) .eq. irrep_t) THEN
102      CALL TCE_RESTRICTED_8(p5b,p6b,p7b,p8b,h15b,h9b,h10b,h11b,p5b_1,p6b
103     &_1,p7b_1,p8b_1,h15b_1,h9b_1,h10b_1,h11b_1)
104      CALL TCE_RESTRICTED_8(h2b,h9b,h10b,h11b,p5b,p6b,p7b,p8b,h2b_2,h9b_
105     &2,h10b_2,h11b_2,p5b_2,p6b_2,p7b_2,p8b_2)
106      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_m
107     &b(k_range+p7b-1) * int_mb(k_range+p8b-1) * int_mb(k_range+h9b-1) *
108     & int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1)
109      dima_sort = int_mb(k_range+h15b-1)
110      dima = dim_common * dima_sort
111      dimb_sort = int_mb(k_range+h2b-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('ccsdtq_lr_alpha_15_32_1_2',1,MA_ERR)
116      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
117     &ccsdtq_lr_alpha_15_32_1_2',2,MA_ERR)
118      IF ((h11b .le. h15b)) THEN
119      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h15b_
120     &1 - 1 + noab * (h11b_1 - 1 + noab * (h10b_1 - 1 + noab * (h9b_1 -
121     &1 + noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * (
122     &p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
123      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
124     &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1)
125     &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+h11b-
126     &1),int_mb(k_range+h15b-1),8,7,6,5,4,3,2,1,1.0d0)
127      END IF
128      IF ((h10b .le. h15b) .and. (h15b .lt. h11b)) THEN
129      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h11b_
130     &1 - 1 + noab * (h15b_1 - 1 + noab * (h10b_1 - 1 + noab * (h9b_1 -
131     &1 + noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * (
132     &p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
133      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
134     &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1)
135     &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+h15b-
136     &1),int_mb(k_range+h11b-1),7,8,6,5,4,3,2,1,-1.0d0)
137      END IF
138      IF ((h9b .le. h15b) .and. (h15b .lt. h10b)) THEN
139      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h11b_
140     &1 - 1 + noab * (h10b_1 - 1 + noab * (h15b_1 - 1 + noab * (h9b_1 -
141     &1 + noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * (
142     &p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
143      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
144     &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1)
145     &,int_mb(k_range+h9b-1),int_mb(k_range+h15b-1),int_mb(k_range+h10b-
146     &1),int_mb(k_range+h11b-1),6,8,7,5,4,3,2,1,1.0d0)
147      END IF
148      IF ((h15b .lt. h9b)) THEN
149      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h11b_
150     &1 - 1 + noab * (h10b_1 - 1 + noab * (h9b_1 - 1 + noab * (h15b_1 -
151     &1 + noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * (
152     &p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1)))))))))
153      CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
154     &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1)
155     &,int_mb(k_range+h15b-1),int_mb(k_range+h9b-1),int_mb(k_range+h10b-
156     &1),int_mb(k_range+h11b-1),5,8,7,6,4,3,2,1,-1.0d0)
157      END IF
158      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_lr_alpha_15_32_1_
159     &2',3,MA_ERR)
160      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
161     & ERRQUIT('ccsdtq_lr_alpha_15_32_1_2',4,MA_ERR)
162      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
163     &ccsdtq_lr_alpha_15_32_1_2',5,MA_ERR)
164      IF ((h11b .lt. h2b)) THEN
165      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
166     & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b_2 - noab - 1
167     &+ nvab * (p5b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab * (h11b_2 -
168     &1 + noab * (h10b_2 - 1 + noab * (h9b_2 - 1)))))))))
169      CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
170     &,int_mb(k_range+h10b-1),int_mb(k_range+h11b-1),int_mb(k_range+h2b-
171     &1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b-
172     &1),int_mb(k_range+p8b-1),4,3,2,1,8,7,6,5,-1.0d0)
173      END IF
174      IF ((h10b .lt. h2b) .and. (h2b .le. h11b)) THEN
175      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
176     & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b_2 - noab - 1
177     &+ nvab * (p5b_2 - noab - 1 + nvab * (h11b_2 - 1 + noab * (h2b_2 -
178     &1 + noab * (h10b_2 - 1 + noab * (h9b_2 - 1)))))))))
179      CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
180     &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+h11b-
181     &1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b-
182     &1),int_mb(k_range+p8b-1),3,4,2,1,8,7,6,5,1.0d0)
183      END IF
184      IF ((h9b .lt. h2b) .and. (h2b .le. h10b)) THEN
185      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
186     & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b_2 - noab - 1
187     &+ nvab * (p5b_2 - noab - 1 + nvab * (h11b_2 - 1 + noab * (h10b_2 -
188     & 1 + noab * (h2b_2 - 1 + noab * (h9b_2 - 1)))))))))
189      CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
190     &,int_mb(k_range+h2b-1),int_mb(k_range+h10b-1),int_mb(k_range+h11b-
191     &1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b-
192     &1),int_mb(k_range+p8b-1),2,4,3,1,8,7,6,5,-1.0d0)
193      END IF
194      IF ((h2b .le. h9b)) THEN
195      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
196     & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b_2 - noab - 1
197     &+ nvab * (p5b_2 - noab - 1 + nvab * (h11b_2 - 1 + noab * (h10b_2 -
198     & 1 + noab * (h9b_2 - 1 + noab * (h2b_2 - 1)))))))))
199      CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
200     &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+h11b-
201     &1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b-
202     &1),int_mb(k_range+p8b-1),1,4,3,2,8,7,6,5,1.0d0)
203      END IF
204      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_lr_alpha_15_32_1_
205     &2',6,MA_ERR)
206      nsuperp(1) = 1
207      nsuperp(2) = 1
208      nsuperp(3) = 1
209      nsuperp(4) = 1
210      isuperp = 1
211      IF (p5b .eq. p6b) THEN
212      nsuperp(isuperp) = nsuperp(isuperp) + 1
213      ELSE
214      isuperp = isuperp + 1
215      END IF
216      IF (p6b .eq. p7b) THEN
217      nsuperp(isuperp) = nsuperp(isuperp) + 1
218      ELSE
219      isuperp = isuperp + 1
220      END IF
221      IF (p7b .eq. p8b) THEN
222      nsuperp(isuperp) = nsuperp(isuperp) + 1
223      ELSE
224      isuperp = isuperp + 1
225      END IF
226      nsubh(1) = 1
227      nsubh(2) = 1
228      nsubh(3) = 1
229      isubh = 1
230      IF (h9b .eq. h10b) THEN
231      nsubh(isubh) = nsubh(isubh) + 1
232      ELSE
233      isubh = isubh + 1
234      END IF
235      IF (h10b .eq. h11b) THEN
236      nsubh(isubh) = nsubh(isubh) + 1
237      ELSE
238      isubh = isubh + 1
239      END IF
240      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,144.0d0/FACTORIA
241     &L(nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsuperp(3))/FACTORIA
242     &L(nsuperp(4))/FACTORIAL(nsubh(1))/FACTORIAL(nsubh(2))/FACTORIAL(ns
243     &ubh(3)),dbl_mb(k_a_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.
244     &0d0,dbl_mb(k_c_sort),dima_sort)
245      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_
246     &32_1_2',7,MA_ERR)
247      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_
248     &32_1_2',8,MA_ERR)
249      END IF
250      END IF
251      END IF
252      END DO
253      END DO
254      END DO
255      END DO
256      END DO
257      END DO
258      END DO
259      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
260     &ccsdtq_lr_alpha_15_32_1_2',9,MA_ERR)
261      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
262     &,int_mb(k_range+h15b-1),1,2,-1.0d0/12.0d0)
263      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h15b
264     &- 1 + noab * (h2b - 1)))
265      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_lr_alpha_15_32_1_
266     &2',10,MA_ERR)
267      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_
268     &32_1_2',11,MA_ERR)
269      END IF
270      END IF
271      END IF
272      next = nxtask(nprocs,1)
273      END IF
274      count = count + 1
275      END DO
276      END DO
277      next = nxtask(-nprocs,1)
278      call GA_SYNC()
279      RETURN
280      END
281