1      SUBROUTINE q3rexpt2_act(a_i0,d_i1_2,d_t1,d_t2,
2     &d_x1,d_x2,k_i1_offset_2,
3     &k_t1_offset,k_t2_offset,k_x1_offset,k_x2_offset,l_i1_offset_2,t_h1
4     &b,t_h2b,t_h3b,t_p4b,t_p5b,t_p6b,toggle)
5C     $Id$
6C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
7C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
8C     i0 ( p4 p5 p6 h1 h2 h3 )_xt + = 1 * P( 9 ) * t ( p4 p5 h1 h2 )_t * x ( p6 h3 )_x
9C     i0 ( p4 p5 p6 h1 h2 h3 )_xtt + = -2 * P( 9 ) * t ( p4 h1 )_t * i1 ( p5 p6 h2 h3 )_xt
10C         i1 ( p4 p5 h1 h2 )_xt + = -1/4 * P( 4 ) * t ( p4 h1 )_t * x ( p5 h2 )_x
11C         i1 ( p4 p5 h1 h2 )_x + = -1/2 * x ( p4 p5 h1 h2 )_x
12      IMPLICIT NONE
13#include "global.fh"
14#include "mafdecls.fh"
15#include "util.fh"
16#include "errquit.fh"
17#include "tce.fh"
18      INTEGER t_p4b
19      INTEGER t_p5b
20      INTEGER t_p6b
21      INTEGER t_h1b
22      INTEGER t_h2b
23      INTEGER t_h3b
24      INTEGER toggle
25      INTEGER d_t2
26      INTEGER k_t2_offset
27      INTEGER d_x1
28      INTEGER k_x1_offset
29      INTEGER d_t1
30      INTEGER k_t1_offset
31      INTEGER d_i1_2
32      INTEGER k_i1_offset_2
33      INTEGER l_i1_offset_2
34      INTEGER size_i1_2
35      INTEGER d_x2
36      INTEGER k_x2_offset
37      DOUBLE PRECISION a_i0(*)
38      CHARACTER*255 filename
39      IF (toggle .eq. 3) THEN
40      CALL DELETEFILE(d_i1_2)
41      IF (.not.MA_POP_STACK(l_i1_offset_2))
42     &CALL ERRQUIT('q3rexpt2_act',-1,M
43     &A_ERR)
44      END IF
45      IF (toggle .eq. 2) CALL q3rexpt2_act_1(d_t2,k_t2_offset,d_x1,
46     &k_x1_offset,a_i0,t_p4b,t_p5b,t_p6b,t_h1b,t_h2b,t_h3b)
47      IF (toggle .eq. 1) CALL OFFSET_q3rexpt2_act_2_1(l_i1_offset_2,
48     &k_i1_offset_2,size_i1_2)
49      IF (toggle .eq. 1) CALL TCE_FILENAME('q3rexpt2_act_2_1_i1',
50     &  filename)
51      IF (toggle .eq. 1) CALL CREATEFILE(filename,d_i1_2,size_i1_2)
52      IF (toggle .eq. 1) CALL q3rexpt2_act_2_1(d_t1,k_t1_offset,d_x1,
53     &k_x1_offset,d_i1_2,k_i1_offset_2)
54      IF (toggle .eq. 1) CALL q3rexpt2_act_2_2(d_x2,k_x2_offset,d_i1_2,
55     &k_i1_offset_2)
56      IF (toggle .eq. 1) CALL RECONCILEFILE(d_i1_2,size_i1_2)
57      IF (toggle .eq. 2) CALL q3rexpt2_act_2(d_t1,k_t1_offset,d_i1_2,
58     &k_i1_offset_2,a_i0,t_p4b,t_p5b,t_p6b,t_h1b,t_h2b,t_h3b)
59      RETURN
60      END
61      SUBROUTINE q3rexpt2_act_1(d_a,k_a_offset,d_b,k_b_offset,a_c,t_p4b,
62     &t_p5b,t_p6b,t_h1b,t_h2b,t_h3b)
63C     $Id$
64C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
65C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
66C     i0 ( p4 p5 p6 h1 h2 h3 )_xt + = 1 * P( 9 ) * t ( p4 p5 h1 h2 )_t * x ( p6 h3 )_x
67      IMPLICIT NONE
68#include "global.fh"
69#include "mafdecls.fh"
70#include "sym.fh"
71#include "errquit.fh"
72#include "tce.fh"
73      INTEGER d_a
74      INTEGER k_a_offset
75      INTEGER d_b
76      INTEGER k_b_offset
77      INTEGER t_p4b
78      INTEGER t_p5b
79      INTEGER t_p6b
80      INTEGER t_h1b
81      INTEGER t_h2b
82      INTEGER t_h3b
83      INTEGER p4b
84      INTEGER p5b
85      INTEGER p6b
86      INTEGER h1b
87      INTEGER h2b
88      INTEGER h3b
89      INTEGER dimc
90      INTEGER l_c_sort
91      INTEGER k_c_sort
92      INTEGER p4b_1
93      INTEGER p5b_1
94      INTEGER h1b_1
95      INTEGER h2b_1
96      INTEGER p6b_2
97      INTEGER h3b_2
98      INTEGER dim_common
99      INTEGER dima_sort
100      INTEGER dima
101      INTEGER dimb_sort
102      INTEGER dimb
103      INTEGER l_a_sort
104      INTEGER k_a_sort
105      INTEGER l_a
106      INTEGER k_a
107      INTEGER l_b_sort
108      INTEGER k_b_sort
109      INTEGER l_b
110      INTEGER k_b
111c -- peta-exa --
112      INTEGER a3(9,6)
113      INTEGER ia6,ja6
114c --------------
115      LOGICAL is_active_1,is_active_2,is_active_3,is_active_4
116      DOUBLE PRECISION a_c(*)
117      LOGICAL skipped
118c
119cc      DO p4b = noab+1,noab+nvab
120cc      DO p5b = p4b,noab+nvab
121cc      DO p6b = noab+1,noab+nvab
122cc      DO h1b = 1,noab
123cc      DO h2b = h1b,noab
124cc      DO h3b = 1,noab
125c
126        a3(1,1)=t_p4b
127        a3(1,2)=t_p5b
128        a3(1,3)=t_p6b
129        a3(1,4)=t_h1b
130        a3(1,5)=t_h2b
131        a3(1,6)=t_h3b
132c
133        a3(2,1)=t_p4b
134        a3(2,2)=t_p5b
135        a3(2,3)=t_p6b
136        a3(2,4)=t_h2b
137        a3(2,5)=t_h3b
138        a3(2,6)=t_h1b
139c
140        a3(3,1)=t_p4b
141        a3(3,2)=t_p5b
142        a3(3,3)=t_p6b
143        a3(3,4)=t_h1b
144        a3(3,5)=t_h3b
145        a3(3,6)=t_h2b
146c
147        a3(4,1)=t_p5b
148        a3(4,2)=t_p6b
149        a3(4,3)=t_p4b
150        a3(4,4)=t_h1b
151        a3(4,5)=t_h2b
152        a3(4,6)=t_h3b
153c
154        a3(5,1)=t_p5b
155        a3(5,2)=t_p6b
156        a3(5,3)=t_p4b
157        a3(5,4)=t_h2b
158        a3(5,5)=t_h3b
159        a3(5,6)=t_h1b
160c
161        a3(6,1)=t_p5b
162        a3(6,2)=t_p6b
163        a3(6,3)=t_p4b
164        a3(6,4)=t_h1b
165        a3(6,5)=t_h3b
166        a3(6,6)=t_h2b
167c
168        a3(7,1)=t_p4b
169        a3(7,2)=t_p6b
170        a3(7,3)=t_p5b
171        a3(7,4)=t_h1b
172        a3(7,5)=t_h2b
173        a3(7,6)=t_h3b
174c
175        a3(8,1)=t_p4b
176        a3(8,2)=t_p6b
177        a3(8,3)=t_p5b
178        a3(8,4)=t_h2b
179        a3(8,5)=t_h3b
180        a3(8,6)=t_h1b
181c
182        a3(9,1)=t_p4b
183        a3(9,2)=t_p6b
184        a3(9,3)=t_p5b
185        a3(9,4)=t_h1b
186        a3(9,5)=t_h3b
187        a3(9,6)=t_h2b
188c
189        do ia6=1,8
190         if(a3(ia6,1).ne.0) then
191         do ja6=ia6+1,9
192          if((a3(ia6,1).eq.a3(ja6,1)).and.(a3(ia6,2).eq.a3(ja6,2))
193     &     .and.(a3(ia6,3).eq.a3(ja6,3)).and.(a3(ia6,4).eq.a3(ja6,4))
194     &     .and.(a3(ia6,5).eq.a3(ja6,5)).and.(a3(ia6,6).eq.a3(ja6,6)))
195     &     then
196           a3(ja6,1)=0
197           a3(ja6,2)=0
198           a3(ja6,3)=0
199           a3(ja6,4)=0
200           a3(ja6,5)=0
201           a3(ja6,6)=0
202          end if
203         enddo
204         end if
205        enddo
206c
207      do ia6=1,9
208      p4b=a3(ia6,1)
209      p5b=a3(ia6,2)
210      p6b=a3(ia6,3)
211      h1b=a3(ia6,4)
212      h2b=a3(ia6,5)
213      h3b=a3(ia6,6)
214      if((p4b.le.p5b).and.(h1b.le.h2b).and.(p4b.ne.0)) then
215      skipped = .false.
216      IF(is_active_4(h1b,h2b,p4b,p5b)) THEN
217      IF (.not.skipped) THEN
218      IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1
219     &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i
220     &nt_mb(k_spin+h3b-1).ne.12)) THEN
221      IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)
222     & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-
223     &1)) THEN
224      IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
225     &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int
226     &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_x,irrep_t)) THEN
227      dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra
228     &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m
229     &b(k_range+h3b-1)
230ccx      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
231ccx     & ERRQUIT('q3rexpt2_1',0,MA_ERR)
232ccx      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
233      IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
234     &1b-1)+int_mb(k_spin+h2b-1)) THEN
235      IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
236     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
237      CALL TCE_RESTRICTED_4(p4b,p5b,h1b,h2b,p4b_1,p5b_1,h1b_1,h2b_1)
238      CALL TCE_RESTRICTED_2(p6b,h3b,p6b_2,h3b_2)
239      dim_common = 1
240      dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb
241     &(k_range+h1b-1) * int_mb(k_range+h2b-1)
242      dima = dim_common * dima_sort
243      dimb_sort = int_mb(k_range+p6b-1) * int_mb(k_range+h3b-1)
244      dimb = dim_common * dimb_sort
245      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
246      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
247     & ERRQUIT('q3rexpt2_1',1,MA_ERR)
248      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
249     &q3rexpt2_1',2,MA_ERR)
250      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
251     & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_
252     &1 - noab - 1)))))
253      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
254     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
255     &,4,3,2,1,1.0d0)
256      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('q3rexpt2_1',3,MA_ERR)
257      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
258     & ERRQUIT('q3rexpt2_1',4,MA_ERR)
259      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
260     &q3rexpt2_1',5,MA_ERR)
261      CALL GET_HASH_BLOCK_MA(dbl_mb(d_b),dbl_mb(k_b),dimb,
262     & int_mb(k_b_offset),(h3b_2
263     & - 1 + noab * (p6b_2 - noab - 1)))
264      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p6b-1)
265     &,int_mb(k_range+h3b-1),2,1,1.0d0)
266      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('q3rexpt2_1',6,MA_ERR)
267ccx      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
268ccx     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
269ccx     &t),dima_sort)
270ccx      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('q3rexpt2_1',7,MA_ER
271ccx     &R)
272ccx      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('q3rexpt2_1',8,MA_ER
273ccx     &R)
274ccx      END IF
275ccx      END IF
276ccx      END IF
277      IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b)
278     & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h
279     &3b)) THEN
280ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
281ccx     &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_
282ccx     &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,2,4,3,1,1.0d0)
283      call sd_E_1(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
284     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
285     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
286     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort))
287      END IF
288      IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b)
289     & .and. (t_h1b .eq. h3b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h
290     &2b)) THEN
291ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
292ccx     &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_
293ccx     &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,2,1,4,3,1.0d0)
294      call sd_E_2(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
295     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
296     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
297     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort))
298      END IF
299      IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b)
300     & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h
301     &2b)) THEN
302ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
303ccx     &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_
304ccx     &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,2,4,1,3,-1.0d0)
305      call sd_E_3(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
306     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
307     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
308     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort))
309      END IF
310      IF ((t_p4b .eq. p6b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p5b)
311     & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h
312     &3b)) THEN
313ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
314ccx     &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_
315ccx     &mb(k_range+p5b-1),int_mb(k_range+p4b-1),2,6,5,4,3,1,1.0d0)
316      call sd_E_4(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
317     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
318     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
319     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort))
320      END IF
321      IF ((t_p4b .eq. p6b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p5b)
322     & .and. (t_h1b .eq. h3b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h
323     &2b)) THEN
324ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
325ccx     &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_
326ccx     &mb(k_range+p5b-1),int_mb(k_range+p4b-1),2,6,5,1,4,3,1.0d0)
327      call sd_E_5(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
328     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
329     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
330     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort))
331      END IF
332      IF ((t_p4b .eq. p6b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p5b)
333     & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h
334     &2b)) THEN
335ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
336ccx     &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_
337ccx     &mb(k_range+p5b-1),int_mb(k_range+p4b-1),2,6,5,4,1,3,-1.0d0)
338      call sd_E_6(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
339     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
340     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
341     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort))
342      END IF
343      IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p5b)
344     & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h
345     &3b)) THEN
346ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
347ccx     &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_
348ccx     &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,2,5,4,3,1,-1.0d0)
349      call sd_E_7(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
350     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
351     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
352     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort))
353      END IF
354      IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p5b)
355     & .and. (t_h1b .eq. h3b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h
356     &2b)) THEN
357ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
358ccx     &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_
359ccx     &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,2,5,1,4,3,-1.0d0)
360      call sd_E_8(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
361     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
362     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
363     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort))
364      END IF
365      IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p5b)
366     & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h
367     &2b)) THEN
368ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
369ccx     &mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_
370ccx     &mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,2,5,4,1,3,1.0d0)
371      call sd_E_9(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
372     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
373     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
374     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort))
375      END IF
376ccx      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('q3rexpt2_1',9,MA_ER
377ccx     &R)
378c
379      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_t_singles_1',7
380     &,MA_ERR)
381      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_t_singles_1',8
382     &,MA_ERR)
383c
384      END IF
385      END IF
386      END IF
387c
388      END IF
389      END IF
390      END IF
391      END IF
392      END IF
393c
394      END IF
395      END DO
396      RETURN
397      END
398      SUBROUTINE q3rexpt2_act_2(d_a,k_a_offset,d_b,k_b_offset,a_c,t_p4b,
399     &t_p5b,t_p6b,t_h1b,t_h2b,t_h3b)
400C     $Id$
401C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
402C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
403C     i0 ( p4 p5 p6 h1 h2 h3 )_xtt + = -2 * P( 9 ) * t ( p4 h1 )_t * i1 ( p5 p6 h2 h3 )_xt
404      IMPLICIT NONE
405#include "global.fh"
406#include "mafdecls.fh"
407#include "sym.fh"
408#include "errquit.fh"
409#include "tce.fh"
410      INTEGER d_a
411      INTEGER k_a_offset
412      INTEGER d_b
413      INTEGER k_b_offset
414      INTEGER t_p4b
415      INTEGER t_p5b
416      INTEGER t_p6b
417      INTEGER t_h1b
418      INTEGER t_h2b
419      INTEGER t_h3b
420      INTEGER p4b
421      INTEGER p5b
422      INTEGER p6b
423      INTEGER h1b
424      INTEGER h2b
425      INTEGER h3b
426      INTEGER dimc
427      INTEGER l_c_sort
428      INTEGER k_c_sort
429      INTEGER p4b_1
430      INTEGER h1b_1
431      INTEGER p5b_2
432      INTEGER p6b_2
433      INTEGER h2b_2
434      INTEGER h3b_2
435      INTEGER dim_common
436      INTEGER dima_sort
437      INTEGER dima
438      INTEGER dimb_sort
439      INTEGER dimb
440      INTEGER l_a_sort
441      INTEGER k_a_sort
442      INTEGER l_a
443      INTEGER k_a
444      INTEGER l_b_sort
445      INTEGER k_b_sort
446      INTEGER l_b
447      INTEGER k_b
448c -- peta-exa --
449      INTEGER a3(9,6)
450      INTEGER ia6,ja6
451c --------------
452      LOGICAL one_of_two_act
453      DOUBLE PRECISION a_c(*)
454      LOGICAL skipped
455c
456cc      DO p4b = noab+1,noab+nvab
457cc      DO p5b = noab+1,noab+nvab
458cc      DO p6b = p5b,noab+nvab
459cc      DO h1b = 1,noab
460cc      DO h2b = 1,noab
461cc      DO h3b = h2b,noab
462c
463        a3(1,1)=t_p4b
464        a3(1,2)=t_p5b
465        a3(1,3)=t_p6b
466        a3(1,4)=t_h1b
467        a3(1,5)=t_h2b
468        a3(1,6)=t_h3b
469c
470        a3(2,1)=t_p4b
471        a3(2,2)=t_p5b
472        a3(2,3)=t_p6b
473        a3(2,4)=t_h2b
474        a3(2,5)=t_h1b
475        a3(2,6)=t_h3b
476c
477        a3(3,1)=t_p4b
478        a3(3,2)=t_p5b
479        a3(3,3)=t_p6b
480        a3(3,4)=t_h3b
481        a3(3,5)=t_h1b
482        a3(3,6)=t_h2b
483c
484        a3(4,1)=t_p5b
485        a3(4,2)=t_p4b
486        a3(4,3)=t_p6b
487        a3(4,4)=t_h1b
488        a3(4,5)=t_h2b
489        a3(4,6)=t_h3b
490c
491        a3(5,1)=t_p5b
492        a3(5,2)=t_p4b
493        a3(5,3)=t_p6b
494        a3(5,4)=t_h2b
495        a3(5,5)=t_h1b
496        a3(5,6)=t_h3b
497c
498        a3(6,1)=t_p5b
499        a3(6,2)=t_p4b
500        a3(6,3)=t_p6b
501        a3(6,4)=t_h3b
502        a3(6,5)=t_h1b
503        a3(6,6)=t_h2b
504c
505        a3(7,1)=t_p6b
506        a3(7,2)=t_p4b
507        a3(7,3)=t_p5b
508        a3(7,4)=t_h1b
509        a3(7,5)=t_h2b
510        a3(7,6)=t_h3b
511c
512        a3(8,1)=t_p6b
513        a3(8,2)=t_p4b
514        a3(8,3)=t_p5b
515        a3(8,4)=t_h2b
516        a3(8,5)=t_h1b
517        a3(8,6)=t_h3b
518c
519        a3(9,1)=t_p6b
520        a3(9,2)=t_p4b
521        a3(9,3)=t_p5b
522        a3(9,4)=t_h3b
523        a3(9,5)=t_h1b
524        a3(9,6)=t_h2b
525c
526        do ia6=1,8
527         if(a3(ia6,1).ne.0) then
528         do ja6=ia6+1,9
529          if((a3(ia6,1).eq.a3(ja6,1)).and.(a3(ia6,2).eq.a3(ja6,2))
530     &     .and.(a3(ia6,3).eq.a3(ja6,3)).and.(a3(ia6,4).eq.a3(ja6,4))
531     &     .and.(a3(ia6,5).eq.a3(ja6,5)).and.(a3(ia6,6).eq.a3(ja6,6)))
532     &     then
533           a3(ja6,1)=0
534           a3(ja6,2)=0
535           a3(ja6,3)=0
536           a3(ja6,4)=0
537           a3(ja6,5)=0
538           a3(ja6,6)=0
539          end if
540         enddo
541         end if
542        enddo
543c
544      do ia6=1,9
545      p4b=a3(ia6,1)
546      p5b=a3(ia6,2)
547      p6b=a3(ia6,3)
548      h1b=a3(ia6,4)
549      h2b=a3(ia6,5)
550      h3b=a3(ia6,6)
551      if((p5b.le.p6b).and.(h2b.le.h3b).and.(p4b.ne.0)) then
552      skipped = .false.
553      IF(one_of_two_act(p5b,p6b).and.one_of_two_act(h2b,h3b)) THEN
554      IF (.not.skipped) THEN
555      IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1
556     &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i
557     &nt_mb(k_spin+h3b-1).ne.12)) THEN
558      IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)
559     & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b-
560     &1)) THEN
561      IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
562     &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int
563     &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_x,ieor(irrep_t,irrep_t))) TH
564     &EN
565      dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra
566     &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m
567     &b(k_range+h3b-1)
568ccx      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
569ccx     & ERRQUIT('q3rexpt2_2',0,MA_ERR)
570ccx      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
571      IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h1b-1)) THEN
572      IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
573     &EN
574      CALL TCE_RESTRICTED_2(p4b,h1b,p4b_1,h1b_1)
575      CALL TCE_RESTRICTED_4(p5b,p6b,h2b,h3b,p5b_2,p6b_2,h2b_2,h3b_2)
576      dim_common = 1
577      dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1)
578      dima = dim_common * dima_sort
579      dimb_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_mb
580     &(k_range+h2b-1) * int_mb(k_range+h3b-1)
581      dimb = dim_common * dimb_sort
582      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
583      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
584     & ERRQUIT('q3rexpt2_2',1,MA_ERR)
585      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
586     &q3rexpt2_2',2,MA_ERR)
587      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
588     & int_mb(k_a_offset),(h1b_1
589     & - 1 + noab * (p4b_1 - noab - 1)))
590      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
591     &,int_mb(k_range+h1b-1),2,1,1.0d0)
592      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('q3rexpt2_2',3,MA_ERR)
593      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
594     & ERRQUIT('q3rexpt2_2',4,MA_ERR)
595ccx      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
596ccx     &q3rexpt2_2',5,MA_ERR)
597      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b_sort),dimb,int_mb(k_b_offset),
598     &(h3b_2
599     & - 1 + noab * (h2b_2 - 1 + noab * (p6b_2 - noab - 1 + nvab * (p5b_
600     &2 - noab - 1)))))
601ccx      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1)
602ccx     &,int_mb(k_range+p6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1)
603ccx     &,4,3,2,1,1.0d0)
604ccx      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('q3rexpt2_2',6,MA_ERR)
605ccx      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
606ccx     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
607ccx     &t),dima_sort)
608ccx      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('q3rexpt2_2',7,MA_ER
609ccx     &R)
610ccx      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('q3rexpt2_2',8,MA_ER
611ccx     &R)
612ccx      END IF
613ccx      END IF
614ccx      END IF
615      IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b)
616     & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h
617     &3b)) THEN
618ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
619ccx     &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_
620ccx     &mb(k_range+h1b-1),int_mb(k_range+p4b-1),6,4,3,5,2,1,-2.0d0/1.0d0)
621      call sd_E2_1(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
622     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
623     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
624     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),-2.0d0/1.0d0)
625      END IF
626      IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b)
627     & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h
628     &3b)) THEN
629ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
630ccx     &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_
631ccx     &mb(k_range+h1b-1),int_mb(k_range+p4b-1),6,4,3,2,5,1,2.0d0/1.0d0)
632      call sd_E2_2(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
633     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
634     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
635     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),2.0d0/1.0d0)
636      END IF
637      IF ((t_p4b .eq. p4b) .and. (t_p5b .eq. p5b) .and. (t_p6b .eq. p6b)
638     & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h
639     &1b)) THEN
640ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
641ccx     &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_
642ccx     &mb(k_range+h1b-1),int_mb(k_range+p4b-1),6,4,3,2,1,5,-2.0d0/1.0d0)
643      call sd_E2_3(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
644     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
645     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
646     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),-2.0d0/1.0d0)
647      END IF
648      IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p6b)
649     & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h
650     &3b)) THEN
651ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
652ccx     &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_
653ccx     &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,6,3,5,2,1,2.0d0/1.0d0)
654      call sd_E2_4(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
655     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
656     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
657     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),2.0d0/1.0d0)
658      END IF
659      IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p6b)
660     & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h
661     &3b)) THEN
662ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
663ccx     &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_
664ccx     &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,6,3,2,5,1,-2.0d0/1.0d0)
665      call sd_E2_5(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
666     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
667     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
668     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),-2.0d0/1.0d0)
669      END IF
670      IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p4b) .and. (t_p6b .eq. p6b)
671     & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h
672     &1b)) THEN
673ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
674ccx     &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_
675ccx     &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,6,3,2,1,5,2.0d0/1.0d0)
676      call sd_E2_6(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
677     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
678     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
679     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),2.0d0/1.0d0)
680      END IF
681      IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p4b)
682     & .and. (t_h1b .eq. h1b) .and. (t_h2b .eq. h2b) .and. (t_h3b .eq. h
683     &3b)) THEN
684ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
685ccx     &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_
686ccx     &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,3,6,5,2,1,-2.0d0/1.0d0)
687      call sd_E2_7(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
688     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
689     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
690     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),-2.0d0/1.0d0)
691      END IF
692      IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p4b)
693     & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h1b) .and. (t_h3b .eq. h
694     &3b)) THEN
695ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
696ccx     &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_
697ccx     &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,3,6,2,5,1,2.0d0/1.0d0)
698      call sd_E2_8(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
699     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
700     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
701     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),2.0d0/1.0d0)
702      END IF
703      IF ((t_p4b .eq. p5b) .and. (t_p5b .eq. p6b) .and. (t_p6b .eq. p4b)
704     & .and. (t_h1b .eq. h2b) .and. (t_h2b .eq. h3b) .and. (t_h3b .eq. h
705     &1b)) THEN
706ccx      CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+h3b-1),int_
707ccx     &mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1),int_
708ccx     &mb(k_range+h1b-1),int_mb(k_range+p4b-1),4,3,6,2,1,5,-2.0d0/1.0d0)
709      call sd_E2_9(int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),
710     1               int_mb(k_range+h1b-1),int_mb(k_range+p6b-1),
711     2               int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),
712     4               a_c,dbl_mb(k_a_sort),dbl_mb(k_b_sort),-2.0d0/1.0d0)
713      END IF
714ccx      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('q3rexpt2_2',9,MA_ER
715ccx     &R)
716c
717      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_t_singles_1',7
718     &,MA_ERR)
719      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_t_singles_1',8
720     &,MA_ERR)
721c
722      END IF
723      END IF
724      END IF
725c
726      END IF
727      END IF
728      END IF
729      END IF
730      END IF
731c
732      END IF
733      END DO
734      RETURN
735      END
736      SUBROUTINE q3rexpt2_act_2_1(d_a,k_a_offset,d_b,k_b_offset,
737     &d_c,k_c_offset)
738C     $Id$
739C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
740C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
741C     i1 ( p4 p5 h1 h2 )_xt + = -1/4 * P( 4 ) * t ( p4 h1 )_t * x ( p5 h2 )_x
742      IMPLICIT NONE
743#include "global.fh"
744#include "mafdecls.fh"
745#include "sym.fh"
746#include "errquit.fh"
747#include "tce.fh"
748      INTEGER d_a
749      INTEGER k_a_offset
750      INTEGER d_b
751      INTEGER k_b_offset
752      INTEGER d_c
753      INTEGER k_c_offset
754      INTEGER nxtask
755      INTEGER next
756      INTEGER nprocs
757      INTEGER count
758      INTEGER p4b
759      INTEGER p5b
760      INTEGER h1b
761      INTEGER h2b
762      INTEGER dimc
763      INTEGER l_c_sort
764      INTEGER k_c_sort
765      INTEGER p4b_1
766      INTEGER h1b_1
767      INTEGER p5b_2
768      INTEGER h2b_2
769      INTEGER dim_common
770      INTEGER dima_sort
771      INTEGER dima
772      INTEGER dimb_sort
773      INTEGER dimb
774      INTEGER l_a_sort
775      INTEGER k_a_sort
776      INTEGER l_a
777      INTEGER k_a
778      INTEGER l_b_sort
779      INTEGER k_b_sort
780      INTEGER l_b
781      INTEGER k_b
782      INTEGER l_c
783      INTEGER k_c
784      LOGICAL one_of_two_act
785      EXTERNAL nxtask
786      nprocs = GA_NNODES()
787      count = 0
788      next = nxtask(nprocs,1)
789      DO p4b = noab+1,noab+nvab
790      DO p5b = noab+1,noab+nvab
791      DO h1b = 1,noab
792      DO h2b = 1,noab
793      IF (next.eq.count) THEN
794      IF(one_of_two_act(h1b,h2b).and.one_of_two_act(p4b,p5b)) THEN
795      IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1
796     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
797      IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
798     &1b-1)+int_mb(k_spin+h2b-1)) THEN
799      IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
800     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_t)) TH
801     &EN
802      dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra
803     &nge+h1b-1) * int_mb(k_range+h2b-1)
804      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
805     & ERRQUIT('q3rexpt2_act_2_1',0,MA_ERR)
806      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
807      IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h1b-1)) THEN
808      IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
809     &EN
810      CALL TCE_RESTRICTED_2(p4b,h1b,p4b_1,h1b_1)
811      CALL TCE_RESTRICTED_2(p5b,h2b,p5b_2,h2b_2)
812      dim_common = 1
813      dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1)
814      dima = dim_common * dima_sort
815      dimb_sort = int_mb(k_range+p5b-1) * int_mb(k_range+h2b-1)
816      dimb = dim_common * dimb_sort
817      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
818      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
819     & ERRQUIT('q3rexpt2_act_2_1',1,MA_ERR)
820      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
821     &q3rexpt2_act_2_1',2,MA_ERR)
822      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
823     & int_mb(k_a_offset),(h1b_1
824     & - 1 + noab * (p4b_1 - noab - 1)))
825      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
826     &,int_mb(k_range+h1b-1),2,1,1.0d0)
827      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('q3rexpt2_act_2_1',3,
828     &MA_ERR)
829      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
830     & ERRQUIT('q3rexpt2_act_2_1',4,MA_ERR)
831      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
832     &q3rexpt2_act_2_1',5,MA_ERR)
833      CALL GET_HASH_BLOCK_MA(dbl_mb(d_b),dbl_mb(k_b),dimb,
834     & int_mb(k_b_offset),(h2b_2
835     & - 1 + noab * (p5b_2 - noab - 1)))
836      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p5b-1)
837     &,int_mb(k_range+h2b-1),2,1,1.0d0)
838      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('q3rexpt2_act_2_1',6,
839     &MA_ERR)
840      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
841     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
842     &t),dima_sort)
843      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('q3rexpt2_act_2_1',
844     &7,MA_ERR)
845      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('q3rexpt2_act_2_1',8
846     &,MA_ERR)
847      END IF
848      END IF
849      END IF
850      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
851     &q3rexpt2_act_2_1',9,MA_ERR)
852      IF ((p4b .le. p5b) .and. (h1b .le. h2b)) THEN
853      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
854     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1)
855     &,4,2,3,1,-1.0d0/4.0d0)
856      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
857     & 1 + noab * (h1b - 1 + noab * (p5b - noab - 1 + nvab * (p4b - noab
858     & - 1)))))
859      END IF
860      IF ((p4b .le. p5b) .and. (h2b .le. h1b)) THEN
861      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
862     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1)
863     &,4,2,1,3,1.0d0/4.0d0)
864      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
865     & 1 + noab * (h2b - 1 + noab * (p5b - noab - 1 + nvab * (p4b - noab
866     & - 1)))))
867      END IF
868      IF ((p5b .le. p4b) .and. (h1b .le. h2b)) THEN
869      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
870     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1)
871     &,2,4,3,1,1.0d0/4.0d0)
872      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
873     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p5b - noab
874     & - 1)))))
875      END IF
876      IF ((p5b .le. p4b) .and. (h2b .le. h1b)) THEN
877      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
878     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1)
879     &,2,4,1,3,-1.0d0/4.0d0)
880      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
881     & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p5b - noab
882     & - 1)))))
883      END IF
884      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('q3rexpt2_act_2_1',10,
885     &MA_ERR)
886      IF (.not.MA_POP_STACK(l_c_sort))
887     & CALL ERRQUIT('q3rexpt2_act_2_1',11,MA_ERR)
888      END IF
889      END IF
890      END IF
891      END IF
892      next = nxtask(nprocs,1)
893      END IF
894      count = count + 1
895      END DO
896      END DO
897      END DO
898      END DO
899      next = nxtask(-nprocs,1)
900      call GA_SYNC()
901      RETURN
902      END
903      SUBROUTINE OFFSET_q3rexpt2_act_2_1(l_a_offset,k_a_offset,size)
904C     $Id$
905C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
906C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
907C     i1 ( p4 p5 h1 h2 )_xt
908      IMPLICIT NONE
909#include "global.fh"
910#include "mafdecls.fh"
911#include "sym.fh"
912#include "errquit.fh"
913#include "tce.fh"
914      INTEGER l_a_offset
915      INTEGER k_a_offset
916      INTEGER size
917      INTEGER length
918      INTEGER addr
919      INTEGER p4b
920      INTEGER p5b
921      INTEGER h1b
922      INTEGER h2b
923      LOGICAL one_of_two_act
924      length = 0
925      DO p4b = noab+1,noab+nvab
926      DO p5b = p4b,noab+nvab
927      DO h1b = 1,noab
928      DO h2b = h1b,noab
929      IF(one_of_two_act(p4b,p5b).and.one_of_two_act(h1b,h2b)) THEN
930      IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
931     &1b-1)+int_mb(k_spin+h2b-1)) THEN
932      IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
933     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_t)) TH
934     &EN
935      IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1
936     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
937      length = length + 1
938      END IF
939      END IF
940      END IF
941      END IF
942      END DO
943      END DO
944      END DO
945      END DO
946      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
947     &set)) CALL ERRQUIT('q3rexpt2_act_2_1',0,MA_ERR)
948      int_mb(k_a_offset) = length
949      addr = 0
950      size = 0
951      DO p4b = noab+1,noab+nvab
952      DO p5b = p4b,noab+nvab
953      DO h1b = 1,noab
954      DO h2b = h1b,noab
955      IF(one_of_two_act(p4b,p5b).and.one_of_two_act(h1b,h2b)) THEN
956      IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
957     &1b-1)+int_mb(k_spin+h2b-1)) THEN
958      IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
959     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_t)) TH
960     &EN
961      IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1
962     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
963      addr = addr + 1
964      int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (p5b
965     &- noab - 1 + nvab * (p4b - noab - 1)))
966      int_mb(k_a_offset+length+addr) = size
967      size = size + int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_
968     &mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
969      END IF
970      END IF
971      END IF
972      END IF
973      END DO
974      END DO
975      END DO
976      END DO
977      RETURN
978      END
979      SUBROUTINE q3rexpt2_act_2_2(d_a,k_a_offset,d_c,k_c_offset)
980C     $Id$
981C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
982C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
983C     i1 ( p4 p5 h1 h2 )_x + = -1/2 * x ( p4 p5 h1 h2 )_x
984      IMPLICIT NONE
985#include "global.fh"
986#include "mafdecls.fh"
987#include "sym.fh"
988#include "errquit.fh"
989#include "tce.fh"
990      INTEGER d_a
991      INTEGER k_a_offset
992      INTEGER d_c
993      INTEGER k_c_offset
994      INTEGER nxtask
995      INTEGER next
996      INTEGER nprocs
997      INTEGER count
998      INTEGER p4b
999      INTEGER p5b
1000      INTEGER h1b
1001      INTEGER h2b
1002      INTEGER dimc
1003      INTEGER p4b_1
1004      INTEGER p5b_1
1005      INTEGER h1b_1
1006      INTEGER h2b_1
1007      INTEGER dim_common
1008      INTEGER dima_sort
1009      INTEGER dima
1010      INTEGER l_a_sort
1011      INTEGER k_a_sort
1012      INTEGER l_a
1013      INTEGER k_a
1014      INTEGER l_c
1015      INTEGER k_c
1016      LOGICAL is_active_1,is_active_2,is_active_3,is_active_4
1017      EXTERNAL nxtask
1018      nprocs = GA_NNODES()
1019      count = 0
1020      next = nxtask(nprocs,1)
1021      DO p4b = noab+1,noab+nvab
1022      DO p5b = p4b,noab+nvab
1023      DO h1b = 1,noab
1024      DO h2b = h1b,noab
1025      IF (next.eq.count) THEN
1026      IF(is_active_4(p4b,p5b,h1b,h2b)) THEN !!stronger than 2*one_of_two_act
1027      IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1
1028     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
1029      IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
1030     &1b-1)+int_mb(k_spin+h2b-1)) THEN
1031      IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
1032     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN
1033      dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra
1034     &nge+h1b-1) * int_mb(k_range+h2b-1)
1035      CALL TCE_RESTRICTED_4(p4b,p5b,h1b,h2b,p4b_1,p5b_1,h1b_1,h2b_1)
1036      dim_common = 1
1037      dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb
1038     &(k_range+h1b-1) * int_mb(k_range+h2b-1)
1039      dima = dim_common * dima_sort
1040      IF (dima .gt. 0) THEN
1041      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1042     & ERRQUIT('q3rexpt2_act_2_2',0,MA_ERR)
1043      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1044     &q3rexpt2_act_2_2',1,MA_ERR)
1045      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
1046     & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_
1047     &1 - noab - 1)))))
1048      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
1049     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
1050     &,4,3,2,1,1.0d0)
1051      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('q3rexpt2_act_2_2',2,
1052     &MA_ERR)
1053      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1054     &q3rexpt2_act_2_2',3,MA_ERR)
1055      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
1056     &,int_mb(k_range+h1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p4b-1)
1057     &,4,3,2,1,-1.0d0/2.0d0)
1058      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
1059     & 1 + noab * (h1b - 1 + noab * (p5b - noab - 1 + nvab * (p4b - noab
1060     & - 1)))))
1061      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('q3rexpt2_act_2_2',4,
1062     &MA_ERR)
1063      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('q3rexpt2_act_2_2',
1064     &5,MA_ERR)
1065      END IF
1066      END IF
1067      END IF
1068      END IF
1069      END IF
1070      next = nxtask(nprocs,1)
1071      END IF
1072      count = count + 1
1073      END DO
1074      END DO
1075      END DO
1076      END DO
1077      next = nxtask(-nprocs,1)
1078      call GA_SYNC()
1079      RETURN
1080      END
1081