1      SUBROUTINE cc2_x1(d_f1,d_i0,d_t1,d_t2,d_v2,d_x1,d_x2,k_f1_offset,k
2     &_i0_offset,k_t1_offset,k_t2_offset,k_v2_offset,k_x1_offset,k_x2_of
3     &fset)
4C     $Id$
5C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
6C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
7C     i0 ( p2 h1 )_xf + = -1 * Sum ( h6 ) * x ( p2 h6 )_x * i1 ( h6 h1 )_f
8C         i1 ( h6 h1 )_f + = 1 * f ( h6 h1 )_f
9C         i1 ( h6 h1 )_ft + = 1 * Sum ( p7 ) * t ( p7 h1 )_t * i2 ( h6 p7 )_f
10C             i2 ( h6 p7 )_f + = 1 * f ( h6 p7 )_f
11C             i2 ( h6 p7 )_vt + = 1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 h6 p4 p7 )_v
12C         i1 ( h6 h1 )_vt + = -1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 h6 h1 p3 )_v
13C         i1 ( h6 h1 )_vt + = -1/2 * Sum ( h5 p3 p4 ) * t ( p3 p4 h1 h5 )_t * v ( h5 h6 p3 p4 )_v
14C     i0 ( p2 h1 )_xf + = 1 * Sum ( p6 ) * x ( p6 h1 )_x * i1 ( p2 p6 )_f
15C         i1 ( p2 p6 )_f + = 1 * f ( p2 p6 )_f
16C         i1 ( p2 p6 )_vt + = 1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 p2 p3 p6 )_v
17C     i0 ( p2 h1 )_xv + = -1 * Sum ( p4 h3 ) * x ( p4 h3 )_x * v ( h3 p2 h1 p4 )_v
18C     i0 ( p2 h1 )_xf + = 1 * Sum ( p7 h6 ) * x ( p2 p7 h1 h6 )_x * i1 ( h6 p7 )_f
19C         i1 ( h6 p7 )_f + = 1 * f ( h6 p7 )_f
20C         i1 ( h6 p7 )_vt + = 1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 h6 p3 p7 )_v
21C     i0 ( p2 h1 )_xv + = -1/2 * Sum ( p7 h6 h8 ) * x ( p2 p7 h6 h8 )_x * i1 ( h6 h8 h1 p7 )_v
22C         i1 ( h6 h8 h1 p7 )_v + = 1 * v ( h6 h8 h1 p7 )_v
23C         i1 ( h6 h8 h1 p7 )_vt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * v ( h6 h8 p3 p7 )_v
24C     i0 ( p2 h1 )_xv + = -1/2 * Sum ( p4 p5 h3 ) * x ( p4 p5 h1 h3 )_x * v ( h3 p2 p4 p5 )_v
25C     i0 ( p2 h1 )_fxt + = -1 * Sum ( h8 ) * t ( p2 h8 )_t * i1 ( h8 h1 )_fx
26C         i1 ( h8 h1 )_fx + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * i2 ( h8 p3 )_f
27C             i2 ( h8 p3 )_f + = 1 * f ( h8 p3 )_f
28C             i2 ( h8 p3 )_vt + = -1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 h8 p3 p4 )_v
29C         i1 ( h8 h1 )_vx + = -1 * Sum ( h4 p5 ) * x ( p5 h4 )_x * v ( h4 h8 h1 p5 )_v
30C         i1 ( h8 h1 )_vx + = -1/2 * Sum ( h4 p5 p6 ) * x ( p5 p6 h1 h4 )_x * v ( h4 h8 p5 p6 )_v
31C         i1 ( h8 h1 )_vxt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * i2 ( h8 p3 )_vx
32C             i2 ( h8 p3 )_vx + = -1 * Sum ( h5 p6 ) * x ( p6 h5 )_x * v ( h5 h8 p3 p6 )_v
33C     i0 ( p2 h1 )_vxt + = -1 * Sum ( p3 ) * t ( p3 h1 )_t * i1 ( p2 p3 )_vx
34C         i1 ( p2 p3 )_vx + = 1 * Sum ( h4 p5 ) * x ( p5 h4 )_x * v ( h4 p2 p3 p5 )_v
35C     i0 ( p2 h1 )_vxt + = 1 * Sum ( h4 p3 ) * t ( p2 p3 h1 h4 )_t * i1 ( h4 p3 )_vx
36C         i1 ( h4 p3 )_vx + = 1 * Sum ( h5 p6 ) * x ( p6 h5 )_x * v ( h4 h5 p3 p6 )_v
37C     i0 ( p2 h1 )_vxt + = 1/2 * Sum ( h4 h5 p3 ) * t ( p2 p3 h4 h5 )_t * i1 ( h4 h5 h1 p3 )_vx
38C         i1 ( h4 h5 h1 p3 )_vx + = 1 * Sum ( p6 ) * x ( p6 h1 )_x * v ( h4 h5 p3 p6 )_v
39      IMPLICIT NONE
40#include "global.fh"
41#include "mafdecls.fh"
42#include "util.fh"
43#include "errquit.fh"
44#include "tce.fh"
45      INTEGER d_i0
46      INTEGER k_i0_offset
47      INTEGER d_x1
48      INTEGER k_x1_offset
49      INTEGER d_i1
50      INTEGER k_i1_offset
51      INTEGER d_v2
52      INTEGER k_v2_offset
53      INTEGER d_x2
54      INTEGER k_x2_offset
55      INTEGER d_t1
56      INTEGER k_t1_offset
57      INTEGER d_t2
58      INTEGER k_t2_offset
59      INTEGER l_i1_offset
60      INTEGER d_f1
61      INTEGER k_f1_offset
62      INTEGER size_i1
63      INTEGER d_i2
64      INTEGER k_i2_offset
65      INTEGER l_i2_offset
66      INTEGER size_i2
67      CHARACTER*255 filename
68      CALL OFFSET_cc2_x1_1_1(l_i1_offset,k_i1_offset,size_i1)
69      CALL TCE_FILENAME('cc2_x1_1_1_i1',filename)
70      CALL CREATEFILE(filename,d_i1,size_i1)
71      CALL cc2_x1_1_1(d_f1,k_f1_offset,d_i1,k_i1_offset)
72      CALL OFFSET_cc2_x1_1_2_1(l_i2_offset,k_i2_offset,size_i2)
73      CALL TCE_FILENAME('cc2_x1_1_2_1_i2',filename)
74      CALL CREATEFILE(filename,d_i2,size_i2)
75      CALL cc2_x1_1_2_1(d_f1,k_f1_offset,d_i2,k_i2_offset)
76      CALL cc2_x1_1_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_offs
77     &et)
78      CALL RECONCILEFILE(d_i2,size_i2)
79      CALL cc2_x1_1_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k_i1_offset
80     &)
81      CALL DELETEFILE(d_i2)
82      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
83     &R)
84      CALL cc2_x1_1_3(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset
85     &)
86      CALL cc2_x1_1_4(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1,k_i1_offset
87     &)
88      CALL RECONCILEFILE(d_i1,size_i1)
89      CALL cc2_x1_1(d_x1,k_x1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
90      CALL DELETEFILE(d_i1)
91      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
92     &R)
93      CALL OFFSET_cc2_x1_2_1(l_i1_offset,k_i1_offset,size_i1)
94      CALL TCE_FILENAME('cc2_x1_2_1_i1',filename)
95      CALL CREATEFILE(filename,d_i1,size_i1)
96      CALL cc2_x1_2_1(d_f1,k_f1_offset,d_i1,k_i1_offset)
97      CALL cc2_x1_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset
98     &)
99      CALL RECONCILEFILE(d_i1,size_i1)
100      CALL cc2_x1_2(d_x1,k_x1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
101      CALL DELETEFILE(d_i1)
102      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
103     &R)
104      CALL cc2_x1_3(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i0,k_i0_offset)
105      CALL OFFSET_cc2_x1_4_1(l_i1_offset,k_i1_offset,size_i1)
106      CALL TCE_FILENAME('cc2_x1_4_1_i1',filename)
107      CALL CREATEFILE(filename,d_i1,size_i1)
108      CALL cc2_x1_4_1(d_f1,k_f1_offset,d_i1,k_i1_offset)
109      CALL cc2_x1_4_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset
110     &)
111      CALL RECONCILEFILE(d_i1,size_i1)
112      CALL cc2_x1_4(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
113      CALL DELETEFILE(d_i1)
114      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
115     &R)
116      CALL OFFSET_cc2_x1_5_1(l_i1_offset,k_i1_offset,size_i1)
117      CALL TCE_FILENAME('cc2_x1_5_1_i1',filename)
118      CALL CREATEFILE(filename,d_i1,size_i1)
119      CALL cc2_x1_5_1(d_v2,k_v2_offset,d_i1,k_i1_offset)
120      CALL cc2_x1_5_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset
121     &)
122      CALL RECONCILEFILE(d_i1,size_i1)
123      CALL cc2_x1_5(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
124      CALL DELETEFILE(d_i1)
125      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
126     &R)
127      CALL cc2_x1_6(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i0,k_i0_offset)
128      CALL OFFSET_cc2_x1_7_1(l_i1_offset,k_i1_offset,size_i1)
129      CALL TCE_FILENAME('cc2_x1_7_1_i1',filename)
130      CALL CREATEFILE(filename,d_i1,size_i1)
131      CALL OFFSET_cc2_x1_7_1_1(l_i2_offset,k_i2_offset,size_i2)
132      CALL TCE_FILENAME('cc2_x1_7_1_1_i2',filename)
133      CALL CREATEFILE(filename,d_i2,size_i2)
134      CALL cc2_x1_7_1_1(d_f1,k_f1_offset,d_i2,k_i2_offset)
135      CALL cc2_x1_7_1_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_offs
136     &et)
137      CALL RECONCILEFILE(d_i2,size_i2)
138      CALL cc2_x1_7_1(d_x1,k_x1_offset,d_i2,k_i2_offset,d_i1,k_i1_offset
139     &)
140      CALL DELETEFILE(d_i2)
141      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
142     &R)
143      CALL cc2_x1_7_2(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset
144     &)
145      CALL cc2_x1_7_3(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i1,k_i1_offset
146     &)
147      CALL OFFSET_cc2_x1_7_4_1(l_i2_offset,k_i2_offset,size_i2)
148      CALL TCE_FILENAME('cc2_x1_7_4_1_i2',filename)
149      CALL CREATEFILE(filename,d_i2,size_i2)
150      CALL cc2_x1_7_4_1(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i2,k_i2_offs
151     &et)
152      CALL RECONCILEFILE(d_i2,size_i2)
153      CALL cc2_x1_7_4(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k_i1_offset
154     &)
155      CALL DELETEFILE(d_i2)
156      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
157     &R)
158      CALL RECONCILEFILE(d_i1,size_i1)
159      CALL cc2_x1_7(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
160      CALL DELETEFILE(d_i1)
161      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
162     &R)
163      CALL OFFSET_cc2_x1_8_1(l_i1_offset,k_i1_offset,size_i1)
164      CALL TCE_FILENAME('cc2_x1_8_1_i1',filename)
165      CALL CREATEFILE(filename,d_i1,size_i1)
166      CALL cc2_x1_8_1(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset
167     &)
168      CALL RECONCILEFILE(d_i1,size_i1)
169      CALL cc2_x1_8(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
170      CALL DELETEFILE(d_i1)
171      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
172     &R)
173      CALL OFFSET_cc2_x1_9_1(l_i1_offset,k_i1_offset,size_i1)
174      CALL TCE_FILENAME('cc2_x1_9_1_i1',filename)
175      CALL CREATEFILE(filename,d_i1,size_i1)
176      CALL cc2_x1_9_1(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset
177     &)
178      CALL RECONCILEFILE(d_i1,size_i1)
179      CALL cc2_x1_9(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
180      CALL DELETEFILE(d_i1)
181      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
182     &R)
183      CALL OFFSET_cc2_x1_10_1(l_i1_offset,k_i1_offset,size_i1)
184      CALL TCE_FILENAME('cc2_x1_10_1_i1',filename)
185      CALL CREATEFILE(filename,d_i1,size_i1)
186      CALL cc2_x1_10_1(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i1,k_i1_offse
187     &t)
188      CALL RECONCILEFILE(d_i1,size_i1)
189      CALL cc2_x1_10(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
190      CALL DELETEFILE(d_i1)
191      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cc2_x1',-1,MA_ER
192     &R)
193      RETURN
194      END
195      SUBROUTINE cc2_x1_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
196C     $Id$
197C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
198C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
199C     i0 ( p2 h1 )_xf + = -1 * Sum ( h6 ) * x ( p2 h6 )_x * i1 ( h6 h1 )_f
200      IMPLICIT NONE
201#include "global.fh"
202#include "mafdecls.fh"
203#include "sym.fh"
204#include "errquit.fh"
205#include "tce.fh"
206      INTEGER d_a
207      INTEGER k_a_offset
208      INTEGER d_b
209      INTEGER k_b_offset
210      INTEGER d_c
211      INTEGER k_c_offset
212      INTEGER NXTASK
213      INTEGER next
214      INTEGER nprocs
215      INTEGER count
216      INTEGER p2b
217      INTEGER h1b
218      INTEGER dimc
219      INTEGER l_c_sort
220      INTEGER k_c_sort
221      INTEGER h6b
222      INTEGER p2b_1
223      INTEGER h6b_1
224      INTEGER h6b_2
225      INTEGER h1b_2
226      INTEGER dim_common
227      INTEGER dima_sort
228      INTEGER dima
229      INTEGER dimb_sort
230      INTEGER dimb
231      INTEGER l_a_sort
232      INTEGER k_a_sort
233      INTEGER l_a
234      INTEGER k_a
235      INTEGER l_b_sort
236      INTEGER k_b_sort
237      INTEGER l_b
238      INTEGER k_b
239      INTEGER l_c
240      INTEGER k_c
241      EXTERNAL NXTASK
242      nprocs = GA_NNODES()
243      count = 0
244      next = NXTASK(nprocs,1)
245      DO p2b = noab+1,noab+nvab
246      DO h1b = 1,noab
247      IF (next.eq.count) THEN
248      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
249     &).ne.4)) THEN
250      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
251      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
252     &x,irrep_f)) THEN
253      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
254      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
255     & ERRQUIT('cc2_x1_1',0,MA_ERR)
256      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
257      DO h6b = 1,noab
258      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h6b-1)) THEN
259      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h6b-1)) .eq. irrep_x) TH
260     &EN
261      CALL TCE_RESTRICTED_2(p2b,h6b,p2b_1,h6b_1)
262      CALL TCE_RESTRICTED_2(h6b,h1b,h6b_2,h1b_2)
263      dim_common = int_mb(k_range+h6b-1)
264      dima_sort = int_mb(k_range+p2b-1)
265      dima = dim_common * dima_sort
266      dimb_sort = int_mb(k_range+h1b-1)
267      dimb = dim_common * dimb_sort
268      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
269      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
270     & ERRQUIT('cc2_x1_1',1,MA_ERR)
271      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
272     &cc2_x1_1',2,MA_ERR)
273      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
274     &int_mb(k_a_offset),(h6b_1
275     & - 1 + noab * (p2b_1 - noab - 1)))
276      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
277     &,int_mb(k_range+h6b-1),1,2,1.0d0)
278      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1',3,MA_ERR)
279      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
280     & ERRQUIT('cc2_x1_1',4,MA_ERR)
281      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
282     &cc2_x1_1',5,MA_ERR)
283      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2
284     & - 1 + noab * (h6b_2 - 1)))
285      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
286     &,int_mb(k_range+h1b-1),2,1,1.0d0)
287      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_1',6,MA_ERR)
288      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
289     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
290     &t),dima_sort)
291      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_1',7,MA_ERR)
292      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1',8,MA_ERR)
293      END IF
294      END IF
295      END IF
296      END DO
297      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
298     &cc2_x1_1',9,MA_ERR)
299      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
300     &,int_mb(k_range+p2b-1),2,1,-1.0d0)
301      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
302     & 1 + noab * (p2b - noab - 1)))
303      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1',10,MA_ERR)
304      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_1',11,MA_ERR
305     &)
306      END IF
307      END IF
308      END IF
309      next = NXTASK(nprocs,1)
310      END IF
311      count = count + 1
312      END DO
313      END DO
314      next = NXTASK(-nprocs,1)
315      call GA_SYNC()
316      RETURN
317      END
318      SUBROUTINE cc2_x1_1_1(d_a,k_a_offset,d_c,k_c_offset)
319C     $Id$
320C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
321C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
322C     i1 ( h6 h1 )_f + = 1 * f ( h6 h1 )_f
323      IMPLICIT NONE
324#include "global.fh"
325#include "mafdecls.fh"
326#include "sym.fh"
327#include "errquit.fh"
328#include "tce.fh"
329      INTEGER d_a
330      INTEGER k_a_offset
331      INTEGER d_c
332      INTEGER k_c_offset
333      INTEGER NXTASK
334      INTEGER next
335      INTEGER nprocs
336      INTEGER count
337      INTEGER h6b
338      INTEGER h1b
339      INTEGER dimc
340      INTEGER h6b_1
341      INTEGER h1b_1
342      INTEGER dim_common
343      INTEGER dima_sort
344      INTEGER dima
345      INTEGER l_a_sort
346      INTEGER k_a_sort
347      INTEGER l_a
348      INTEGER k_a
349      INTEGER l_c
350      INTEGER k_c
351      EXTERNAL NXTASK
352      nprocs = GA_NNODES()
353      count = 0
354      next = NXTASK(nprocs,1)
355      DO h6b = 1,noab
356      DO h1b = 1,noab
357      IF (next.eq.count) THEN
358      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1
359     &).ne.4)) THEN
360      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
361      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
362     &EN
363      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1)
364      CALL TCE_RESTRICTED_2(h6b,h1b,h6b_1,h1b_1)
365      dim_common = 1
366      dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1)
367      dima = dim_common * dima_sort
368      IF (dima .gt. 0) THEN
369      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
370     & ERRQUIT('cc2_x1_1_1',0,MA_ERR)
371      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
372     &cc2_x1_1_1',1,MA_ERR)
373      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
374     & - 1 + (noab+nvab) * (h6b_1 - 1)))
375      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1)
376     &,int_mb(k_range+h1b-1),2,1,1.0d0)
377      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_1',2,MA_ERR)
378      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
379     &cc2_x1_1_1',3,MA_ERR)
380      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
381     &,int_mb(k_range+h6b-1),2,1,1.0d0)
382      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
383     & 1 + noab * (h6b - 1)))
384      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_1',4,MA_ERR)
385      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_1',5,MA_ER
386     &R)
387      END IF
388      END IF
389      END IF
390      END IF
391      next = NXTASK(nprocs,1)
392      END IF
393      count = count + 1
394      END DO
395      END DO
396      next = NXTASK(-nprocs,1)
397      call GA_SYNC()
398      RETURN
399      END
400      SUBROUTINE OFFSET_cc2_x1_1_1(l_a_offset,k_a_offset,size)
401C     $Id$
402C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
403C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
404C     i1 ( h6 h1 )_f
405      IMPLICIT NONE
406#include "global.fh"
407#include "mafdecls.fh"
408#include "sym.fh"
409#include "errquit.fh"
410#include "tce.fh"
411      INTEGER l_a_offset
412      INTEGER k_a_offset
413      INTEGER size
414      INTEGER length
415      INTEGER addr
416      INTEGER h6b
417      INTEGER h1b
418      length = 0
419      DO h6b = 1,noab
420      DO h1b = 1,noab
421      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
422      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
423     &EN
424      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1
425     &).ne.4)) THEN
426      length = length + 1
427      END IF
428      END IF
429      END IF
430      END DO
431      END DO
432      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
433     &set)) CALL ERRQUIT('cc2_x1_1_1',0,MA_ERR)
434      int_mb(k_a_offset) = length
435      addr = 0
436      size = 0
437      DO h6b = 1,noab
438      DO h1b = 1,noab
439      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
440      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
441     &EN
442      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1
443     &).ne.4)) THEN
444      addr = addr + 1
445      int_mb(k_a_offset+addr) = h1b - 1 + noab * (h6b - 1)
446      int_mb(k_a_offset+length+addr) = size
447      size = size + int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1)
448      END IF
449      END IF
450      END IF
451      END DO
452      END DO
453      RETURN
454      END
455      SUBROUTINE cc2_x1_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
456     &)
457C     $Id$
458C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
459C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
460C     i1 ( h6 h1 )_ft + = 1 * Sum ( p7 ) * t ( p7 h1 )_t * i2 ( h6 p7 )_f
461      IMPLICIT NONE
462#include "global.fh"
463#include "mafdecls.fh"
464#include "sym.fh"
465#include "errquit.fh"
466#include "tce.fh"
467      INTEGER d_a
468      INTEGER k_a_offset
469      INTEGER d_b
470      INTEGER k_b_offset
471      INTEGER d_c
472      INTEGER k_c_offset
473      INTEGER NXTASK
474      INTEGER next
475      INTEGER nprocs
476      INTEGER count
477      INTEGER h6b
478      INTEGER h1b
479      INTEGER dimc
480      INTEGER l_c_sort
481      INTEGER k_c_sort
482      INTEGER p7b
483      INTEGER p7b_1
484      INTEGER h1b_1
485      INTEGER h6b_2
486      INTEGER p7b_2
487      INTEGER dim_common
488      INTEGER dima_sort
489      INTEGER dima
490      INTEGER dimb_sort
491      INTEGER dimb
492      INTEGER l_a_sort
493      INTEGER k_a_sort
494      INTEGER l_a
495      INTEGER k_a
496      INTEGER l_b_sort
497      INTEGER k_b_sort
498      INTEGER l_b
499      INTEGER k_b
500      INTEGER l_c
501      INTEGER k_c
502      EXTERNAL NXTASK
503      nprocs = GA_NNODES()
504      count = 0
505      next = NXTASK(nprocs,1)
506      DO h6b = 1,noab
507      DO h1b = 1,noab
508      IF (next.eq.count) THEN
509      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1
510     &).ne.4)) THEN
511      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
512      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
513     &f,irrep_t)) THEN
514      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1)
515      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
516     & ERRQUIT('cc2_x1_1_2',0,MA_ERR)
517      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
518      DO p7b = noab+1,noab+nvab
519      IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)) THEN
520      IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
521     &EN
522      CALL TCE_RESTRICTED_2(p7b,h1b,p7b_1,h1b_1)
523      CALL TCE_RESTRICTED_2(h6b,p7b,h6b_2,p7b_2)
524      dim_common = int_mb(k_range+p7b-1)
525      dima_sort = int_mb(k_range+h1b-1)
526      dima = dim_common * dima_sort
527      dimb_sort = int_mb(k_range+h6b-1)
528      dimb = dim_common * dimb_sort
529      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
530      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
531     & ERRQUIT('cc2_x1_1_2',1,MA_ERR)
532      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
533     &cc2_x1_1_2',2,MA_ERR)
534      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
535     &int_mb(k_a_offset),(h1b_1
536     & - 1 + noab * (p7b_1 - noab - 1)))
537      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
538     &,int_mb(k_range+h1b-1),2,1,1.0d0)
539      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_2',3,MA_ERR)
540      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
541     & ERRQUIT('cc2_x1_1_2',4,MA_ERR)
542      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
543     &cc2_x1_1_2',5,MA_ERR)
544      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
545     & - noab - 1 + nvab * (h6b_2 - 1)))
546      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
547     &,int_mb(k_range+p7b-1),1,2,1.0d0)
548      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_1_2',6,MA_ERR)
549      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
550     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
551     &t),dima_sort)
552      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_1_2',7,MA_ER
553     &R)
554      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_2',8,MA_ER
555     &R)
556      END IF
557      END IF
558      END IF
559      END DO
560      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
561     &cc2_x1_1_2',9,MA_ERR)
562      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h6b-1)
563     &,int_mb(k_range+h1b-1),1,2,1.0d0)
564      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
565     & 1 + noab * (h6b - 1)))
566      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_2',10,MA_ERR)
567      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_1_2',11,MA_E
568     &RR)
569      END IF
570      END IF
571      END IF
572      next = NXTASK(nprocs,1)
573      END IF
574      count = count + 1
575      END DO
576      END DO
577      next = NXTASK(-nprocs,1)
578      call GA_SYNC()
579      RETURN
580      END
581      SUBROUTINE cc2_x1_1_2_1(d_a,k_a_offset,d_c,k_c_offset)
582C     $Id$
583C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
584C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
585C     i2 ( h6 p7 )_f + = 1 * f ( h6 p7 )_f
586      IMPLICIT NONE
587#include "global.fh"
588#include "mafdecls.fh"
589#include "sym.fh"
590#include "errquit.fh"
591#include "tce.fh"
592      INTEGER d_a
593      INTEGER k_a_offset
594      INTEGER d_c
595      INTEGER k_c_offset
596      INTEGER NXTASK
597      INTEGER next
598      INTEGER nprocs
599      INTEGER count
600      INTEGER h6b
601      INTEGER p7b
602      INTEGER dimc
603      INTEGER h6b_1
604      INTEGER p7b_1
605      INTEGER dim_common
606      INTEGER dima_sort
607      INTEGER dima
608      INTEGER l_a_sort
609      INTEGER k_a_sort
610      INTEGER l_a
611      INTEGER k_a
612      INTEGER l_c
613      INTEGER k_c
614      EXTERNAL NXTASK
615      nprocs = GA_NNODES()
616      count = 0
617      next = NXTASK(nprocs,1)
618      DO h6b = 1,noab
619      DO p7b = noab+1,noab+nvab
620      IF (next.eq.count) THEN
621      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1
622     &).ne.4)) THEN
623      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN
624      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH
625     &EN
626      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1)
627      CALL TCE_RESTRICTED_2(h6b,p7b,h6b_1,p7b_1)
628      dim_common = 1
629      dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1)
630      dima = dim_common * dima_sort
631      IF (dima .gt. 0) THEN
632      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
633     & ERRQUIT('cc2_x1_1_2_1',0,MA_ERR)
634      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
635     &cc2_x1_1_2_1',1,MA_ERR)
636      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p7b_1
637     & - 1 + (noab+nvab) * (h6b_1 - 1)))
638      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1)
639     &,int_mb(k_range+p7b-1),2,1,1.0d0)
640      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_2_1',2,MA_ERR)
641      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
642     &cc2_x1_1_2_1',3,MA_ERR)
643      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p7b-1)
644     &,int_mb(k_range+h6b-1),2,1,1.0d0)
645      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b -
646     & noab - 1 + nvab * (h6b - 1)))
647      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_2_1',4,MA_ERR)
648      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_2_1',5,MA_
649     &ERR)
650      END IF
651      END IF
652      END IF
653      END IF
654      next = NXTASK(nprocs,1)
655      END IF
656      count = count + 1
657      END DO
658      END DO
659      next = NXTASK(-nprocs,1)
660      call GA_SYNC()
661      RETURN
662      END
663      SUBROUTINE OFFSET_cc2_x1_1_2_1(l_a_offset,k_a_offset,size)
664C     $Id$
665C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
666C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
667C     i2 ( h6 p7 )_f
668      IMPLICIT NONE
669#include "global.fh"
670#include "mafdecls.fh"
671#include "sym.fh"
672#include "errquit.fh"
673#include "tce.fh"
674      INTEGER l_a_offset
675      INTEGER k_a_offset
676      INTEGER size
677      INTEGER length
678      INTEGER addr
679      INTEGER h6b
680      INTEGER p7b
681      length = 0
682      DO h6b = 1,noab
683      DO p7b = noab+1,noab+nvab
684      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN
685      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH
686     &EN
687      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1
688     &).ne.4)) THEN
689      length = length + 1
690      END IF
691      END IF
692      END IF
693      END DO
694      END DO
695      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
696     &set)) CALL ERRQUIT('cc2_x1_1_2_1',0,MA_ERR)
697      int_mb(k_a_offset) = length
698      addr = 0
699      size = 0
700      DO h6b = 1,noab
701      DO p7b = noab+1,noab+nvab
702      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN
703      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH
704     &EN
705      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1
706     &).ne.4)) THEN
707      addr = addr + 1
708      int_mb(k_a_offset+addr) = p7b - noab - 1 + nvab * (h6b - 1)
709      int_mb(k_a_offset+length+addr) = size
710      size = size + int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1)
711      END IF
712      END IF
713      END IF
714      END DO
715      END DO
716      RETURN
717      END
718      SUBROUTINE cc2_x1_1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offs
719     &et)
720C     $Id$
721C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
722C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
723C     i2 ( h6 p7 )_vt + = 1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 h6 p4 p7 )_v
724      IMPLICIT NONE
725#include "global.fh"
726#include "mafdecls.fh"
727#include "sym.fh"
728#include "errquit.fh"
729#include "tce.fh"
730      INTEGER d_a
731      INTEGER k_a_offset
732      INTEGER d_b
733      INTEGER k_b_offset
734      INTEGER d_c
735      INTEGER k_c_offset
736      INTEGER NXTASK
737      INTEGER next
738      INTEGER nprocs
739      INTEGER count
740      INTEGER h6b
741      INTEGER p7b
742      INTEGER dimc
743      INTEGER l_c_sort
744      INTEGER k_c_sort
745      INTEGER p4b
746      INTEGER h5b
747      INTEGER p4b_1
748      INTEGER h5b_1
749      INTEGER h6b_2
750      INTEGER h5b_2
751      INTEGER p7b_2
752      INTEGER p4b_2
753      INTEGER dim_common
754      INTEGER dima_sort
755      INTEGER dima
756      INTEGER dimb_sort
757      INTEGER dimb
758      INTEGER l_a_sort
759      INTEGER k_a_sort
760      INTEGER l_a
761      INTEGER k_a
762      INTEGER l_b_sort
763      INTEGER k_b_sort
764      INTEGER l_b
765      INTEGER k_b
766      INTEGER l_c
767      INTEGER k_c
768      EXTERNAL NXTASK
769      nprocs = GA_NNODES()
770      count = 0
771      next = NXTASK(nprocs,1)
772      DO h6b = 1,noab
773      DO p7b = noab+1,noab+nvab
774      IF (next.eq.count) THEN
775      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1
776     &).ne.4)) THEN
777      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN
778      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. ieor(irrep_
779     &v,irrep_t)) THEN
780      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1)
781      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
782     & ERRQUIT('cc2_x1_1_2_2',0,MA_ERR)
783      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
784      DO p4b = noab+1,noab+nvab
785      DO h5b = 1,noab
786      IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h5b-1)) THEN
787      IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h5b-1)) .eq. irrep_t) TH
788     &EN
789      CALL TCE_RESTRICTED_2(p4b,h5b,p4b_1,h5b_1)
790      CALL TCE_RESTRICTED_4(h6b,h5b,p7b,p4b,h6b_2,h5b_2,p7b_2,p4b_2)
791      dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h5b-1)
792      dima_sort = 1
793      dima = dim_common * dima_sort
794      dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1)
795      dimb = dim_common * dimb_sort
796      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
797      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
798     & ERRQUIT('cc2_x1_1_2_2',1,MA_ERR)
799      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
800     &cc2_x1_1_2_2',2,MA_ERR)
801      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
802     &int_mb(k_a_offset),(h5b_1
803     & - 1 + noab * (p4b_1 - noab - 1)))
804      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
805     &,int_mb(k_range+h5b-1),2,1,1.0d0)
806      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_2_2',3,MA_ERR)
807      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
808     & ERRQUIT('cc2_x1_1_2_2',4,MA_ERR)
809      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
810     &cc2_x1_1_2_2',5,MA_ERR)
811      IF ((h5b .le. h6b) .and. (p4b .le. p7b)) THEN
812      if(.not.intorb) then
813      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
814     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
815     &+nvab) * (h5b_2 - 1)))))
816      else
817      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
818     &(p7b_2
819     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
820     &+nvab) * (h5b_2 - 1)))),p7b_2,p4b_2,h6b_2,h5b_2)
821      end if
822      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
823     &,int_mb(k_range+h6b-1),int_mb(k_range+p4b-1),int_mb(k_range+p7b-1)
824     &,4,2,1,3,1.0d0)
825      END IF
826      IF ((h5b .le. h6b) .and. (p7b .lt. p4b)) THEN
827      if(.not.intorb) then
828      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
829     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
830     &+nvab) * (h5b_2 - 1)))))
831      else
832      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
833     &(p4b_2
834     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
835     &+nvab) * (h5b_2 - 1)))),p4b_2,p7b_2,h6b_2,h5b_2)
836      end if
837      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
838     &,int_mb(k_range+h6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p4b-1)
839     &,3,2,1,4,-1.0d0)
840      END IF
841      IF ((h6b .lt. h5b) .and. (p4b .le. p7b)) THEN
842      if(.not.intorb) then
843      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
844     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
845     &+nvab) * (h6b_2 - 1)))))
846      else
847      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
848     &(p7b_2
849     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
850     &+nvab) * (h6b_2 - 1)))),p7b_2,p4b_2,h5b_2,h6b_2)
851      end if
852      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
853     &,int_mb(k_range+h5b-1),int_mb(k_range+p4b-1),int_mb(k_range+p7b-1)
854     &,4,1,2,3,-1.0d0)
855      END IF
856      IF ((h6b .lt. h5b) .and. (p7b .lt. p4b)) THEN
857      if(.not.intorb) then
858      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
859     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
860     &+nvab) * (h6b_2 - 1)))))
861      else
862      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
863     &(p4b_2
864     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
865     &+nvab) * (h6b_2 - 1)))),p4b_2,p7b_2,h5b_2,h6b_2)
866      end if
867      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
868     &,int_mb(k_range+h5b-1),int_mb(k_range+p7b-1),int_mb(k_range+p4b-1)
869     &,3,1,2,4,1.0d0)
870      END IF
871      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_1_2_2',6,MA_ERR)
872      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
873     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
874     &t),dima_sort)
875      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_1_2_2',7,MA_
876     &ERR)
877      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_2_2',8,MA_
878     &ERR)
879      END IF
880      END IF
881      END IF
882      END DO
883      END DO
884      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
885     &cc2_x1_1_2_2',9,MA_ERR)
886      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p7b-1)
887     &,int_mb(k_range+h6b-1),2,1,1.0d0)
888      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b -
889     & noab - 1 + nvab * (h6b - 1)))
890      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_2_2',10,MA_ERR)
891      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_1_2_2',11,MA
892     &_ERR)
893      END IF
894      END IF
895      END IF
896      next = NXTASK(nprocs,1)
897      END IF
898      count = count + 1
899      END DO
900      END DO
901      next = NXTASK(-nprocs,1)
902      call GA_SYNC()
903      RETURN
904      END
905      SUBROUTINE cc2_x1_1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
906     &)
907C     $Id$
908C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
909C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
910C     i1 ( h6 h1 )_vt + = -1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 h6 h1 p3 )_v
911      IMPLICIT NONE
912#include "global.fh"
913#include "mafdecls.fh"
914#include "sym.fh"
915#include "errquit.fh"
916#include "tce.fh"
917      INTEGER d_a
918      INTEGER k_a_offset
919      INTEGER d_b
920      INTEGER k_b_offset
921      INTEGER d_c
922      INTEGER k_c_offset
923      INTEGER NXTASK
924      INTEGER next
925      INTEGER nprocs
926      INTEGER count
927      INTEGER h6b
928      INTEGER h1b
929      INTEGER dimc
930      INTEGER l_c_sort
931      INTEGER k_c_sort
932      INTEGER p3b
933      INTEGER h4b
934      INTEGER p3b_1
935      INTEGER h4b_1
936      INTEGER h6b_2
937      INTEGER h4b_2
938      INTEGER h1b_2
939      INTEGER p3b_2
940      INTEGER dim_common
941      INTEGER dima_sort
942      INTEGER dima
943      INTEGER dimb_sort
944      INTEGER dimb
945      INTEGER l_a_sort
946      INTEGER k_a_sort
947      INTEGER l_a
948      INTEGER k_a
949      INTEGER l_b_sort
950      INTEGER k_b_sort
951      INTEGER l_b
952      INTEGER k_b
953      INTEGER l_c
954      INTEGER k_c
955      EXTERNAL NXTASK
956      nprocs = GA_NNODES()
957      count = 0
958      next = NXTASK(nprocs,1)
959      DO h6b = 1,noab
960      DO h1b = 1,noab
961      IF (next.eq.count) THEN
962      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1
963     &).ne.4)) THEN
964      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
965      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
966     &v,irrep_t)) THEN
967      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1)
968      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
969     & ERRQUIT('cc2_x1_1_3',0,MA_ERR)
970      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
971      DO p3b = noab+1,noab+nvab
972      DO h4b = 1,noab
973      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN
974      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_t) TH
975     &EN
976      CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1)
977      CALL TCE_RESTRICTED_4(h6b,h4b,h1b,p3b,h6b_2,h4b_2,h1b_2,p3b_2)
978      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1)
979      dima_sort = 1
980      dima = dim_common * dima_sort
981      dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1)
982      dimb = dim_common * dimb_sort
983      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
984      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
985     & ERRQUIT('cc2_x1_1_3',1,MA_ERR)
986      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
987     &cc2_x1_1_3',2,MA_ERR)
988      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
989     &int_mb(k_a_offset),(h4b_1
990     & - 1 + noab * (p3b_1 - noab - 1)))
991      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
992     &,int_mb(k_range+h4b-1),2,1,1.0d0)
993      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_3',3,MA_ERR)
994      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
995     & ERRQUIT('cc2_x1_1_3',4,MA_ERR)
996      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
997     &cc2_x1_1_3',5,MA_ERR)
998      IF ((h4b .le. h6b) .and. (h1b .le. p3b)) THEN
999      if(.not.intorb) then
1000      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
1001     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
1002     &+nvab) * (h4b_2 - 1)))))
1003      else
1004      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1005     &(p3b_2
1006     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
1007     &+nvab) * (h4b_2 - 1)))),p3b_2,h1b_2,h6b_2,h4b_2)
1008      end if
1009      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
1010     &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
1011     &,3,2,1,4,1.0d0)
1012      END IF
1013      IF ((h6b .lt. h4b) .and. (h1b .le. p3b)) THEN
1014      if(.not.intorb) then
1015      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
1016     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
1017     &+nvab) * (h6b_2 - 1)))))
1018      else
1019      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1020     &(p3b_2
1021     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
1022     &+nvab) * (h6b_2 - 1)))),p3b_2,h1b_2,h4b_2,h6b_2)
1023      end if
1024      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
1025     &,int_mb(k_range+h4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
1026     &,3,1,2,4,-1.0d0)
1027      END IF
1028      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_1_3',6,MA_ERR)
1029      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1030     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1031     &t),dima_sort)
1032      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_1_3',7,MA_ER
1033     &R)
1034      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_3',8,MA_ER
1035     &R)
1036      END IF
1037      END IF
1038      END IF
1039      END DO
1040      END DO
1041      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1042     &cc2_x1_1_3',9,MA_ERR)
1043      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
1044     &,int_mb(k_range+h6b-1),2,1,-1.0d0)
1045      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
1046     & 1 + noab * (h6b - 1)))
1047      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_3',10,MA_ERR)
1048      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_1_3',11,MA_E
1049     &RR)
1050      END IF
1051      END IF
1052      END IF
1053      next = NXTASK(nprocs,1)
1054      END IF
1055      count = count + 1
1056      END DO
1057      END DO
1058      next = NXTASK(-nprocs,1)
1059      call GA_SYNC()
1060      RETURN
1061      END
1062      SUBROUTINE cc2_x1_1_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
1063     &)
1064C     $Id$
1065C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1066C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1067C     i1 ( h6 h1 )_vt + = -1/2 * Sum ( h5 p3 p4 ) * t ( p3 p4 h1 h5 )_t * v ( h5 h6 p3 p4 )_v
1068      IMPLICIT NONE
1069#include "global.fh"
1070#include "mafdecls.fh"
1071#include "sym.fh"
1072#include "errquit.fh"
1073#include "tce.fh"
1074      INTEGER d_a
1075      INTEGER k_a_offset
1076      INTEGER d_b
1077      INTEGER k_b_offset
1078      INTEGER d_c
1079      INTEGER k_c_offset
1080      INTEGER NXTASK
1081      INTEGER next
1082      INTEGER nprocs
1083      INTEGER count
1084      INTEGER h6b
1085      INTEGER h1b
1086      INTEGER dimc
1087      INTEGER l_c_sort
1088      INTEGER k_c_sort
1089      INTEGER p3b
1090      INTEGER p4b
1091      INTEGER h5b
1092      INTEGER p3b_1
1093      INTEGER p4b_1
1094      INTEGER h1b_1
1095      INTEGER h5b_1
1096      INTEGER h6b_2
1097      INTEGER h5b_2
1098      INTEGER p3b_2
1099      INTEGER p4b_2
1100      INTEGER dim_common
1101      INTEGER dima_sort
1102      INTEGER dima
1103      INTEGER dimb_sort
1104      INTEGER dimb
1105      INTEGER l_a_sort
1106      INTEGER k_a_sort
1107      INTEGER l_a
1108      INTEGER k_a
1109      INTEGER l_b_sort
1110      INTEGER k_b_sort
1111      INTEGER l_b
1112      INTEGER k_b
1113      INTEGER nsuperp(2)
1114      INTEGER isuperp
1115      INTEGER l_c
1116      INTEGER k_c
1117      DOUBLE PRECISION FACTORIAL
1118      EXTERNAL NXTASK
1119      EXTERNAL FACTORIAL
1120      nprocs = GA_NNODES()
1121      count = 0
1122      next = NXTASK(nprocs,1)
1123      DO h6b = 1,noab
1124      DO h1b = 1,noab
1125      IF (next.eq.count) THEN
1126      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1
1127     &).ne.4)) THEN
1128      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1129      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
1130     &v,irrep_t)) THEN
1131      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h1b-1)
1132      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1133     & ERRQUIT('cc2_x1_1_4',0,MA_ERR)
1134      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1135      DO p3b = noab+1,noab+nvab
1136      DO p4b = p3b,noab+nvab
1137      DO h5b = 1,noab
1138      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
1139     &1b-1)+int_mb(k_spin+h5b-1)) THEN
1140      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
1141     &k_sym+h1b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN
1142      CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h5b,p3b_1,p4b_1,h1b_1,h5b_1)
1143      CALL TCE_RESTRICTED_4(h6b,h5b,p3b,p4b,h6b_2,h5b_2,p3b_2,p4b_2)
1144      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m
1145     &b(k_range+h5b-1)
1146      dima_sort = int_mb(k_range+h1b-1)
1147      dima = dim_common * dima_sort
1148      dimb_sort = int_mb(k_range+h6b-1)
1149      dimb = dim_common * dimb_sort
1150      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1151      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1152     & ERRQUIT('cc2_x1_1_4',1,MA_ERR)
1153      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1154     &cc2_x1_1_4',2,MA_ERR)
1155      IF ((h5b .lt. h1b)) THEN
1156      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
1157     & - 1 + noab * (h5b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
1158     &1 - noab - 1)))))
1159      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
1160     &,int_mb(k_range+p4b-1),int_mb(k_range+h5b-1),int_mb(k_range+h1b-1)
1161     &,4,3,2,1,-1.0d0)
1162      END IF
1163      IF ((h1b .le. h5b)) THEN
1164      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1
1165     & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
1166     &1 - noab - 1)))))
1167      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
1168     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h5b-1)
1169     &,3,4,2,1,1.0d0)
1170      END IF
1171      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_1_4',3,MA_ERR)
1172      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1173     & ERRQUIT('cc2_x1_1_4',4,MA_ERR)
1174      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1175     &cc2_x1_1_4',5,MA_ERR)
1176      IF ((h5b .le. h6b)) THEN
1177      if(.not.intorb) then
1178      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
1179     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
1180     &+nvab) * (h5b_2 - 1)))))
1181      else
1182      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1183     &(p4b_2
1184     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
1185     &+nvab) * (h5b_2 - 1)))),p4b_2,p3b_2,h6b_2,h5b_2)
1186      end if
1187      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
1188     &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1)
1189     &,2,1,4,3,1.0d0)
1190      END IF
1191      IF ((h6b .lt. h5b)) THEN
1192      if(.not.intorb) then
1193      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
1194     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
1195     &+nvab) * (h6b_2 - 1)))))
1196      else
1197      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1198     &(p4b_2
1199     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
1200     &+nvab) * (h6b_2 - 1)))),p4b_2,p3b_2,h5b_2,h6b_2)
1201      end if
1202      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
1203     &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1)
1204     &,1,2,4,3,-1.0d0)
1205      END IF
1206      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_1_4',6,MA_ERR)
1207      nsuperp(1) = 1
1208      nsuperp(2) = 1
1209      isuperp = 1
1210      IF (p3b .eq. p4b) THEN
1211      nsuperp(isuperp) = nsuperp(isuperp) + 1
1212      ELSE
1213      isuperp = isuperp + 1
1214      END IF
1215      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
1216     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
1217     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
1218      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_1_4',7,MA_ER
1219     &R)
1220      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_1_4',8,MA_ER
1221     &R)
1222      END IF
1223      END IF
1224      END IF
1225      END DO
1226      END DO
1227      END DO
1228      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1229     &cc2_x1_1_4',9,MA_ERR)
1230      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h6b-1)
1231     &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0)
1232      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
1233     & 1 + noab * (h6b - 1)))
1234      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_1_4',10,MA_ERR)
1235      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_1_4',11,MA_E
1236     &RR)
1237      END IF
1238      END IF
1239      END IF
1240      next = NXTASK(nprocs,1)
1241      END IF
1242      count = count + 1
1243      END DO
1244      END DO
1245      next = NXTASK(-nprocs,1)
1246      call GA_SYNC()
1247      RETURN
1248      END
1249      SUBROUTINE cc2_x1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
1250C     $Id$
1251C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1252C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1253C     i0 ( p2 h1 )_xf + = 1 * Sum ( p6 ) * x ( p6 h1 )_x * i1 ( p2 p6 )_f
1254      IMPLICIT NONE
1255#include "global.fh"
1256#include "mafdecls.fh"
1257#include "sym.fh"
1258#include "errquit.fh"
1259#include "tce.fh"
1260      INTEGER d_a
1261      INTEGER k_a_offset
1262      INTEGER d_b
1263      INTEGER k_b_offset
1264      INTEGER d_c
1265      INTEGER k_c_offset
1266      INTEGER NXTASK
1267      INTEGER next
1268      INTEGER nprocs
1269      INTEGER count
1270      INTEGER p2b
1271      INTEGER h1b
1272      INTEGER dimc
1273      INTEGER l_c_sort
1274      INTEGER k_c_sort
1275      INTEGER p6b
1276      INTEGER p6b_1
1277      INTEGER h1b_1
1278      INTEGER p2b_2
1279      INTEGER p6b_2
1280      INTEGER dim_common
1281      INTEGER dima_sort
1282      INTEGER dima
1283      INTEGER dimb_sort
1284      INTEGER dimb
1285      INTEGER l_a_sort
1286      INTEGER k_a_sort
1287      INTEGER l_a
1288      INTEGER k_a
1289      INTEGER l_b_sort
1290      INTEGER k_b_sort
1291      INTEGER l_b
1292      INTEGER k_b
1293      INTEGER l_c
1294      INTEGER k_c
1295      EXTERNAL NXTASK
1296      nprocs = GA_NNODES()
1297      count = 0
1298      next = NXTASK(nprocs,1)
1299      DO p2b = noab+1,noab+nvab
1300      DO h1b = 1,noab
1301      IF (next.eq.count) THEN
1302      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
1303     &).ne.4)) THEN
1304      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1305      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
1306     &x,irrep_f)) THEN
1307      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
1308      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1309     & ERRQUIT('cc2_x1_2',0,MA_ERR)
1310      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1311      DO p6b = noab+1,noab+nvab
1312      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1313      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH
1314     &EN
1315      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
1316      CALL TCE_RESTRICTED_2(p2b,p6b,p2b_2,p6b_2)
1317      dim_common = int_mb(k_range+p6b-1)
1318      dima_sort = int_mb(k_range+h1b-1)
1319      dima = dim_common * dima_sort
1320      dimb_sort = int_mb(k_range+p2b-1)
1321      dimb = dim_common * dimb_sort
1322      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1323      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1324     & ERRQUIT('cc2_x1_2',1,MA_ERR)
1325      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1326     &cc2_x1_2',2,MA_ERR)
1327      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
1328     &int_mb(k_a_offset),(h1b_1
1329     & - 1 + noab * (p6b_1 - noab - 1)))
1330      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
1331     &,int_mb(k_range+h1b-1),2,1,1.0d0)
1332      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_2',3,MA_ERR)
1333      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1334     & ERRQUIT('cc2_x1_2',4,MA_ERR)
1335      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1336     &cc2_x1_2',5,MA_ERR)
1337      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
1338     & - noab - 1 + nvab * (p2b_2 - noab - 1)))
1339      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1)
1340     &,int_mb(k_range+p6b-1),1,2,1.0d0)
1341      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_2',6,MA_ERR)
1342      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1343     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1344     &t),dima_sort)
1345      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_2',7,MA_ERR)
1346      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_2',8,MA_ERR)
1347      END IF
1348      END IF
1349      END IF
1350      END DO
1351      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1352     &cc2_x1_2',9,MA_ERR)
1353      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1)
1354     &,int_mb(k_range+h1b-1),1,2,1.0d0)
1355      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
1356     & 1 + noab * (p2b - noab - 1)))
1357      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_2',10,MA_ERR)
1358      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_2',11,MA_ERR
1359     &)
1360      END IF
1361      END IF
1362      END IF
1363      next = NXTASK(nprocs,1)
1364      END IF
1365      count = count + 1
1366      END DO
1367      END DO
1368      next = NXTASK(-nprocs,1)
1369      call GA_SYNC()
1370      RETURN
1371      END
1372      SUBROUTINE cc2_x1_2_1(d_a,k_a_offset,d_c,k_c_offset)
1373C     $Id$
1374C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1375C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1376C     i1 ( p2 p6 )_f + = 1 * f ( p2 p6 )_f
1377      IMPLICIT NONE
1378#include "global.fh"
1379#include "mafdecls.fh"
1380#include "sym.fh"
1381#include "errquit.fh"
1382#include "tce.fh"
1383      INTEGER d_a
1384      INTEGER k_a_offset
1385      INTEGER d_c
1386      INTEGER k_c_offset
1387      INTEGER NXTASK
1388      INTEGER next
1389      INTEGER nprocs
1390      INTEGER count
1391      INTEGER p2b
1392      INTEGER p6b
1393      INTEGER dimc
1394      INTEGER p2b_1
1395      INTEGER p6b_1
1396      INTEGER dim_common
1397      INTEGER dima_sort
1398      INTEGER dima
1399      INTEGER l_a_sort
1400      INTEGER k_a_sort
1401      INTEGER l_a
1402      INTEGER k_a
1403      INTEGER l_c
1404      INTEGER k_c
1405      EXTERNAL NXTASK
1406      nprocs = GA_NNODES()
1407      count = 0
1408      next = NXTASK(nprocs,1)
1409      DO p2b = noab+1,noab+nvab
1410      DO p6b = noab+1,noab+nvab
1411      IF (next.eq.count) THEN
1412      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p6b-1
1413     &).ne.4)) THEN
1414      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p6b-1)) THEN
1415      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p6b-1)) .eq. irrep_f) TH
1416     &EN
1417      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p6b-1)
1418      CALL TCE_RESTRICTED_2(p2b,p6b,p2b_1,p6b_1)
1419      dim_common = 1
1420      dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+p6b-1)
1421      dima = dim_common * dima_sort
1422      IF (dima .gt. 0) THEN
1423      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1424     & ERRQUIT('cc2_x1_2_1',0,MA_ERR)
1425      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1426     &cc2_x1_2_1',1,MA_ERR)
1427      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p6b_1
1428     & - 1 + (noab+nvab) * (p2b_1 - 1)))
1429      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
1430     &,int_mb(k_range+p6b-1),2,1,1.0d0)
1431      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_2_1',2,MA_ERR)
1432      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1433     &cc2_x1_2_1',3,MA_ERR)
1434      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p6b-1)
1435     &,int_mb(k_range+p2b-1),2,1,1.0d0)
1436      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p6b -
1437     & noab - 1 + nvab * (p2b - noab - 1)))
1438      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_2_1',4,MA_ERR)
1439      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_2_1',5,MA_ER
1440     &R)
1441      END IF
1442      END IF
1443      END IF
1444      END IF
1445      next = NXTASK(nprocs,1)
1446      END IF
1447      count = count + 1
1448      END DO
1449      END DO
1450      next = NXTASK(-nprocs,1)
1451      call GA_SYNC()
1452      RETURN
1453      END
1454      SUBROUTINE OFFSET_cc2_x1_2_1(l_a_offset,k_a_offset,size)
1455C     $Id$
1456C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1457C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1458C     i1 ( p2 p6 )_f
1459      IMPLICIT NONE
1460#include "global.fh"
1461#include "mafdecls.fh"
1462#include "sym.fh"
1463#include "errquit.fh"
1464#include "tce.fh"
1465      INTEGER l_a_offset
1466      INTEGER k_a_offset
1467      INTEGER size
1468      INTEGER length
1469      INTEGER addr
1470      INTEGER p2b
1471      INTEGER p6b
1472      length = 0
1473      DO p2b = noab+1,noab+nvab
1474      DO p6b = noab+1,noab+nvab
1475      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p6b-1)) THEN
1476      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p6b-1)) .eq. irrep_f) TH
1477     &EN
1478      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p6b-1
1479     &).ne.4)) THEN
1480      length = length + 1
1481      END IF
1482      END IF
1483      END IF
1484      END DO
1485      END DO
1486      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
1487     &set)) CALL ERRQUIT('cc2_x1_2_1',0,MA_ERR)
1488      int_mb(k_a_offset) = length
1489      addr = 0
1490      size = 0
1491      DO p2b = noab+1,noab+nvab
1492      DO p6b = noab+1,noab+nvab
1493      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p6b-1)) THEN
1494      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p6b-1)) .eq. irrep_f) TH
1495     &EN
1496      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p6b-1
1497     &).ne.4)) THEN
1498      addr = addr + 1
1499      int_mb(k_a_offset+addr) = p6b - noab - 1 + nvab * (p2b - noab - 1)
1500      int_mb(k_a_offset+length+addr) = size
1501      size = size + int_mb(k_range+p2b-1) * int_mb(k_range+p6b-1)
1502      END IF
1503      END IF
1504      END IF
1505      END DO
1506      END DO
1507      RETURN
1508      END
1509      SUBROUTINE cc2_x1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
1510     &)
1511C     $Id$
1512C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1513C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1514C     i1 ( p2 p6 )_vt + = 1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 p2 p3 p6 )_v
1515      IMPLICIT NONE
1516#include "global.fh"
1517#include "mafdecls.fh"
1518#include "sym.fh"
1519#include "errquit.fh"
1520#include "tce.fh"
1521      INTEGER d_a
1522      INTEGER k_a_offset
1523      INTEGER d_b
1524      INTEGER k_b_offset
1525      INTEGER d_c
1526      INTEGER k_c_offset
1527      INTEGER NXTASK
1528      INTEGER next
1529      INTEGER nprocs
1530      INTEGER count
1531      INTEGER p2b
1532      INTEGER p6b
1533      INTEGER dimc
1534      INTEGER l_c_sort
1535      INTEGER k_c_sort
1536      INTEGER p3b
1537      INTEGER h4b
1538      INTEGER p3b_1
1539      INTEGER h4b_1
1540      INTEGER p2b_2
1541      INTEGER h4b_2
1542      INTEGER p6b_2
1543      INTEGER p3b_2
1544      INTEGER dim_common
1545      INTEGER dima_sort
1546      INTEGER dima
1547      INTEGER dimb_sort
1548      INTEGER dimb
1549      INTEGER l_a_sort
1550      INTEGER k_a_sort
1551      INTEGER l_a
1552      INTEGER k_a
1553      INTEGER l_b_sort
1554      INTEGER k_b_sort
1555      INTEGER l_b
1556      INTEGER k_b
1557      INTEGER l_c
1558      INTEGER k_c
1559      EXTERNAL NXTASK
1560      nprocs = GA_NNODES()
1561      count = 0
1562      next = NXTASK(nprocs,1)
1563      DO p2b = noab+1,noab+nvab
1564      DO p6b = noab+1,noab+nvab
1565      IF (next.eq.count) THEN
1566      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p6b-1
1567     &).ne.4)) THEN
1568      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p6b-1)) THEN
1569      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p6b-1)) .eq. ieor(irrep_
1570     &v,irrep_t)) THEN
1571      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p6b-1)
1572      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1573     & ERRQUIT('cc2_x1_2_2',0,MA_ERR)
1574      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1575      DO p3b = noab+1,noab+nvab
1576      DO h4b = 1,noab
1577      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN
1578      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_t) TH
1579     &EN
1580      CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1)
1581      CALL TCE_RESTRICTED_4(p2b,h4b,p6b,p3b,p2b_2,h4b_2,p6b_2,p3b_2)
1582      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1)
1583      dima_sort = 1
1584      dima = dim_common * dima_sort
1585      dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+p6b-1)
1586      dimb = dim_common * dimb_sort
1587      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1588      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1589     & ERRQUIT('cc2_x1_2_2',1,MA_ERR)
1590      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1591     &cc2_x1_2_2',2,MA_ERR)
1592      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
1593     &int_mb(k_a_offset),(h4b_1
1594     & - 1 + noab * (p3b_1 - noab - 1)))
1595      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
1596     &,int_mb(k_range+h4b-1),2,1,1.0d0)
1597      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_2_2',3,MA_ERR)
1598      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1599     & ERRQUIT('cc2_x1_2_2',4,MA_ERR)
1600      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1601     &cc2_x1_2_2',5,MA_ERR)
1602      IF ((h4b .le. p2b) .and. (p3b .le. p6b)) THEN
1603      if(.not.intorb) then
1604      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
1605     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1606     &+nvab) * (h4b_2 - 1)))))
1607      else
1608      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1609     &(p6b_2
1610     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1611     &+nvab) * (h4b_2 - 1)))),p6b_2,p3b_2,p2b_2,h4b_2)
1612      end if
1613      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
1614     &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1)
1615     &,4,2,1,3,1.0d0)
1616      END IF
1617      IF ((h4b .le. p2b) .and. (p6b .lt. p3b)) THEN
1618      if(.not.intorb) then
1619      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
1620     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1621     &+nvab) * (h4b_2 - 1)))))
1622      else
1623      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1624     &(p3b_2
1625     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1626     &+nvab) * (h4b_2 - 1)))),p3b_2,p6b_2,p2b_2,h4b_2)
1627      end if
1628      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
1629     &,int_mb(k_range+p2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1)
1630     &,3,2,1,4,-1.0d0)
1631      END IF
1632      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_2_2',6,MA_ERR)
1633      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1634     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1635     &t),dima_sort)
1636      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_2_2',7,MA_ER
1637     &R)
1638      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_2_2',8,MA_ER
1639     &R)
1640      END IF
1641      END IF
1642      END IF
1643      END DO
1644      END DO
1645      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1646     &cc2_x1_2_2',9,MA_ERR)
1647      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p6b-1)
1648     &,int_mb(k_range+p2b-1),2,1,1.0d0)
1649      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p6b -
1650     & noab - 1 + nvab * (p2b - noab - 1)))
1651      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_2_2',10,MA_ERR)
1652      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_2_2',11,MA_E
1653     &RR)
1654      END IF
1655      END IF
1656      END IF
1657      next = NXTASK(nprocs,1)
1658      END IF
1659      count = count + 1
1660      END DO
1661      END DO
1662      next = NXTASK(-nprocs,1)
1663      call GA_SYNC()
1664      RETURN
1665      END
1666      SUBROUTINE cc2_x1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
1667C     $Id$
1668C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1669C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1670C     i0 ( p2 h1 )_xv + = -1 * Sum ( p4 h3 ) * x ( p4 h3 )_x * v ( h3 p2 h1 p4 )_v
1671      IMPLICIT NONE
1672#include "global.fh"
1673#include "mafdecls.fh"
1674#include "sym.fh"
1675#include "errquit.fh"
1676#include "tce.fh"
1677      INTEGER d_a
1678      INTEGER k_a_offset
1679      INTEGER d_b
1680      INTEGER k_b_offset
1681      INTEGER d_c
1682      INTEGER k_c_offset
1683      INTEGER NXTASK
1684      INTEGER next
1685      INTEGER nprocs
1686      INTEGER count
1687      INTEGER p2b
1688      INTEGER h1b
1689      INTEGER dimc
1690      INTEGER l_c_sort
1691      INTEGER k_c_sort
1692      INTEGER p4b
1693      INTEGER h3b
1694      INTEGER p4b_1
1695      INTEGER h3b_1
1696      INTEGER p2b_2
1697      INTEGER h3b_2
1698      INTEGER h1b_2
1699      INTEGER p4b_2
1700      INTEGER dim_common
1701      INTEGER dima_sort
1702      INTEGER dima
1703      INTEGER dimb_sort
1704      INTEGER dimb
1705      INTEGER l_a_sort
1706      INTEGER k_a_sort
1707      INTEGER l_a
1708      INTEGER k_a
1709      INTEGER l_b_sort
1710      INTEGER k_b_sort
1711      INTEGER l_b
1712      INTEGER k_b
1713      INTEGER l_c
1714      INTEGER k_c
1715      EXTERNAL NXTASK
1716      nprocs = GA_NNODES()
1717      count = 0
1718      next = NXTASK(nprocs,1)
1719      DO p2b = noab+1,noab+nvab
1720      DO h1b = 1,noab
1721      IF (next.eq.count) THEN
1722      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
1723     &).ne.4)) THEN
1724      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1725      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
1726     &x,irrep_v)) THEN
1727      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
1728      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1729     & ERRQUIT('cc2_x1_3',0,MA_ERR)
1730      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1731      DO p4b = noab+1,noab+nvab
1732      DO h3b = 1,noab
1733      IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h3b-1)) THEN
1734      IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH
1735     &EN
1736      CALL TCE_RESTRICTED_2(p4b,h3b,p4b_1,h3b_1)
1737      CALL TCE_RESTRICTED_4(p2b,h3b,h1b,p4b,p2b_2,h3b_2,h1b_2,p4b_2)
1738      dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h3b-1)
1739      dima_sort = 1
1740      dima = dim_common * dima_sort
1741      dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
1742      dimb = dim_common * dimb_sort
1743      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1744      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1745     & ERRQUIT('cc2_x1_3',1,MA_ERR)
1746      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1747     &cc2_x1_3',2,MA_ERR)
1748      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
1749     &int_mb(k_a_offset),(h3b_1
1750     & - 1 + noab * (p4b_1 - noab - 1)))
1751      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
1752     &,int_mb(k_range+h3b-1),2,1,1.0d0)
1753      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_3',3,MA_ERR)
1754      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1755     & ERRQUIT('cc2_x1_3',4,MA_ERR)
1756      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1757     &cc2_x1_3',5,MA_ERR)
1758      IF ((h3b .le. p2b) .and. (h1b .le. p4b)) THEN
1759      if(.not.intorb) then
1760      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
1761     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1762     &+nvab) * (h3b_2 - 1)))))
1763      else
1764      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1765     &(p4b_2
1766     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1767     &+nvab) * (h3b_2 - 1)))),p4b_2,h1b_2,p2b_2,h3b_2)
1768      end if
1769      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
1770     &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1)
1771     &,3,2,1,4,1.0d0)
1772      END IF
1773      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_3',6,MA_ERR)
1774      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1775     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1776     &t),dima_sort)
1777      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_3',7,MA_ERR)
1778      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_3',8,MA_ERR)
1779      END IF
1780      END IF
1781      END IF
1782      END DO
1783      END DO
1784      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1785     &cc2_x1_3',9,MA_ERR)
1786      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
1787     &,int_mb(k_range+p2b-1),2,1,-1.0d0)
1788      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
1789     & 1 + noab * (p2b - noab - 1)))
1790      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_3',10,MA_ERR)
1791      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_3',11,MA_ERR
1792     &)
1793      END IF
1794      END IF
1795      END IF
1796      next = NXTASK(nprocs,1)
1797      END IF
1798      count = count + 1
1799      END DO
1800      END DO
1801      next = NXTASK(-nprocs,1)
1802      call GA_SYNC()
1803      RETURN
1804      END
1805      SUBROUTINE cc2_x1_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
1806C     $Id$
1807C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1808C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1809C     i0 ( p2 h1 )_xf + = 1 * Sum ( p7 h6 ) * x ( p2 p7 h1 h6 )_x * i1 ( h6 p7 )_f
1810      IMPLICIT NONE
1811#include "global.fh"
1812#include "mafdecls.fh"
1813#include "sym.fh"
1814#include "errquit.fh"
1815#include "tce.fh"
1816      INTEGER d_a
1817      INTEGER k_a_offset
1818      INTEGER d_b
1819      INTEGER k_b_offset
1820      INTEGER d_c
1821      INTEGER k_c_offset
1822      INTEGER NXTASK
1823      INTEGER next
1824      INTEGER nprocs
1825      INTEGER count
1826      INTEGER p2b
1827      INTEGER h1b
1828      INTEGER dimc
1829      INTEGER l_c_sort
1830      INTEGER k_c_sort
1831      INTEGER p7b
1832      INTEGER h6b
1833      INTEGER p2b_1
1834      INTEGER p7b_1
1835      INTEGER h1b_1
1836      INTEGER h6b_1
1837      INTEGER h6b_2
1838      INTEGER p7b_2
1839      INTEGER dim_common
1840      INTEGER dima_sort
1841      INTEGER dima
1842      INTEGER dimb_sort
1843      INTEGER dimb
1844      INTEGER l_a_sort
1845      INTEGER k_a_sort
1846      INTEGER l_a
1847      INTEGER k_a
1848      INTEGER l_b_sort
1849      INTEGER k_b_sort
1850      INTEGER l_b
1851      INTEGER k_b
1852      INTEGER l_c
1853      INTEGER k_c
1854      EXTERNAL NXTASK
1855      nprocs = GA_NNODES()
1856      count = 0
1857      next = NXTASK(nprocs,1)
1858      DO p2b = noab+1,noab+nvab
1859      DO h1b = 1,noab
1860      IF (next.eq.count) THEN
1861      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
1862     &).ne.4)) THEN
1863      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1864      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
1865     &x,irrep_f)) THEN
1866      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
1867      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1868     & ERRQUIT('cc2_x1_4',0,MA_ERR)
1869      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1870      DO p7b = noab+1,noab+nvab
1871      DO h6b = 1,noab
1872      IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h
1873     &1b-1)+int_mb(k_spin+h6b-1)) THEN
1874      IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb(
1875     &k_sym+h1b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_x) THEN
1876      CALL TCE_RESTRICTED_4(p2b,p7b,h1b,h6b,p2b_1,p7b_1,h1b_1,h6b_1)
1877      CALL TCE_RESTRICTED_2(h6b,p7b,h6b_2,p7b_2)
1878      dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+h6b-1)
1879      dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
1880      dima = dim_common * dima_sort
1881      dimb_sort = 1
1882      dimb = dim_common * dimb_sort
1883      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1884      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1885     & ERRQUIT('cc2_x1_4',1,MA_ERR)
1886      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1887     &cc2_x1_4',2,MA_ERR)
1888      IF ((p7b .lt. p2b) .and. (h6b .lt. h1b)) THEN
1889      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
1890     & - 1 + noab * (h6b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p7b_
1891     &1 - noab - 1)))))
1892      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
1893     &,int_mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1)
1894     &,4,2,3,1,1.0d0)
1895      END IF
1896      IF ((p7b .lt. p2b) .and. (h1b .le. h6b)) THEN
1897      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
1898     & - 1 + noab * (h1b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p7b_
1899     &1 - noab - 1)))))
1900      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
1901     &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1)
1902     &,3,2,4,1,-1.0d0)
1903      END IF
1904      IF ((p2b .le. p7b) .and. (h6b .lt. h1b)) THEN
1905      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
1906     & - 1 + noab * (h6b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p2b_
1907     &1 - noab - 1)))))
1908      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
1909     &,int_mb(k_range+p7b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1)
1910     &,4,1,3,2,-1.0d0)
1911      END IF
1912      IF ((p2b .le. p7b) .and. (h1b .le. h6b)) THEN
1913      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
1914     & - 1 + noab * (h1b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p2b_
1915     &1 - noab - 1)))))
1916      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
1917     &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1)
1918     &,3,1,4,2,1.0d0)
1919      END IF
1920      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_4',3,MA_ERR)
1921      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1922     & ERRQUIT('cc2_x1_4',4,MA_ERR)
1923      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1924     &cc2_x1_4',5,MA_ERR)
1925      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
1926     & - noab - 1 + nvab * (h6b_2 - 1)))
1927      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
1928     &,int_mb(k_range+p7b-1),1,2,1.0d0)
1929      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_4',6,MA_ERR)
1930      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1931     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1932     &t),dima_sort)
1933      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_4',7,MA_ERR)
1934      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_4',8,MA_ERR)
1935      END IF
1936      END IF
1937      END IF
1938      END DO
1939      END DO
1940      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1941     &cc2_x1_4',9,MA_ERR)
1942      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
1943     &,int_mb(k_range+p2b-1),2,1,1.0d0)
1944      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
1945     & 1 + noab * (p2b - noab - 1)))
1946      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_4',10,MA_ERR)
1947      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_4',11,MA_ERR
1948     &)
1949      END IF
1950      END IF
1951      END IF
1952      next = NXTASK(nprocs,1)
1953      END IF
1954      count = count + 1
1955      END DO
1956      END DO
1957      next = NXTASK(-nprocs,1)
1958      call GA_SYNC()
1959      RETURN
1960      END
1961      SUBROUTINE cc2_x1_4_1(d_a,k_a_offset,d_c,k_c_offset)
1962C     $Id$
1963C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1964C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1965C     i1 ( h6 p7 )_f + = 1 * f ( h6 p7 )_f
1966      IMPLICIT NONE
1967#include "global.fh"
1968#include "mafdecls.fh"
1969#include "sym.fh"
1970#include "errquit.fh"
1971#include "tce.fh"
1972      INTEGER d_a
1973      INTEGER k_a_offset
1974      INTEGER d_c
1975      INTEGER k_c_offset
1976      INTEGER NXTASK
1977      INTEGER next
1978      INTEGER nprocs
1979      INTEGER count
1980      INTEGER h6b
1981      INTEGER p7b
1982      INTEGER dimc
1983      INTEGER h6b_1
1984      INTEGER p7b_1
1985      INTEGER dim_common
1986      INTEGER dima_sort
1987      INTEGER dima
1988      INTEGER l_a_sort
1989      INTEGER k_a_sort
1990      INTEGER l_a
1991      INTEGER k_a
1992      INTEGER l_c
1993      INTEGER k_c
1994      EXTERNAL NXTASK
1995      nprocs = GA_NNODES()
1996      count = 0
1997      next = NXTASK(nprocs,1)
1998      DO h6b = 1,noab
1999      DO p7b = noab+1,noab+nvab
2000      IF (next.eq.count) THEN
2001      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1
2002     &).ne.4)) THEN
2003      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN
2004      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH
2005     &EN
2006      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1)
2007      CALL TCE_RESTRICTED_2(h6b,p7b,h6b_1,p7b_1)
2008      dim_common = 1
2009      dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1)
2010      dima = dim_common * dima_sort
2011      IF (dima .gt. 0) THEN
2012      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2013     & ERRQUIT('cc2_x1_4_1',0,MA_ERR)
2014      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2015     &cc2_x1_4_1',1,MA_ERR)
2016      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p7b_1
2017     & - 1 + (noab+nvab) * (h6b_1 - 1)))
2018      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1)
2019     &,int_mb(k_range+p7b-1),2,1,1.0d0)
2020      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_4_1',2,MA_ERR)
2021      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2022     &cc2_x1_4_1',3,MA_ERR)
2023      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p7b-1)
2024     &,int_mb(k_range+h6b-1),2,1,1.0d0)
2025      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b -
2026     & noab - 1 + nvab * (h6b - 1)))
2027      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_4_1',4,MA_ERR)
2028      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_4_1',5,MA_ER
2029     &R)
2030      END IF
2031      END IF
2032      END IF
2033      END IF
2034      next = NXTASK(nprocs,1)
2035      END IF
2036      count = count + 1
2037      END DO
2038      END DO
2039      next = NXTASK(-nprocs,1)
2040      call GA_SYNC()
2041      RETURN
2042      END
2043      SUBROUTINE OFFSET_cc2_x1_4_1(l_a_offset,k_a_offset,size)
2044C     $Id$
2045C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2046C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2047C     i1 ( h6 p7 )_f
2048      IMPLICIT NONE
2049#include "global.fh"
2050#include "mafdecls.fh"
2051#include "sym.fh"
2052#include "errquit.fh"
2053#include "tce.fh"
2054      INTEGER l_a_offset
2055      INTEGER k_a_offset
2056      INTEGER size
2057      INTEGER length
2058      INTEGER addr
2059      INTEGER h6b
2060      INTEGER p7b
2061      length = 0
2062      DO h6b = 1,noab
2063      DO p7b = noab+1,noab+nvab
2064      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN
2065      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH
2066     &EN
2067      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1
2068     &).ne.4)) THEN
2069      length = length + 1
2070      END IF
2071      END IF
2072      END IF
2073      END DO
2074      END DO
2075      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
2076     &set)) CALL ERRQUIT('cc2_x1_4_1',0,MA_ERR)
2077      int_mb(k_a_offset) = length
2078      addr = 0
2079      size = 0
2080      DO h6b = 1,noab
2081      DO p7b = noab+1,noab+nvab
2082      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN
2083      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH
2084     &EN
2085      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1
2086     &).ne.4)) THEN
2087      addr = addr + 1
2088      int_mb(k_a_offset+addr) = p7b - noab - 1 + nvab * (h6b - 1)
2089      int_mb(k_a_offset+length+addr) = size
2090      size = size + int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1)
2091      END IF
2092      END IF
2093      END IF
2094      END DO
2095      END DO
2096      RETURN
2097      END
2098      SUBROUTINE cc2_x1_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
2099     &)
2100C     $Id$
2101C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2102C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2103C     i1 ( h6 p7 )_vt + = 1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 h6 p3 p7 )_v
2104      IMPLICIT NONE
2105#include "global.fh"
2106#include "mafdecls.fh"
2107#include "sym.fh"
2108#include "errquit.fh"
2109#include "tce.fh"
2110      INTEGER d_a
2111      INTEGER k_a_offset
2112      INTEGER d_b
2113      INTEGER k_b_offset
2114      INTEGER d_c
2115      INTEGER k_c_offset
2116      INTEGER NXTASK
2117      INTEGER next
2118      INTEGER nprocs
2119      INTEGER count
2120      INTEGER h6b
2121      INTEGER p7b
2122      INTEGER dimc
2123      INTEGER l_c_sort
2124      INTEGER k_c_sort
2125      INTEGER p3b
2126      INTEGER h4b
2127      INTEGER p3b_1
2128      INTEGER h4b_1
2129      INTEGER h6b_2
2130      INTEGER h4b_2
2131      INTEGER p7b_2
2132      INTEGER p3b_2
2133      INTEGER dim_common
2134      INTEGER dima_sort
2135      INTEGER dima
2136      INTEGER dimb_sort
2137      INTEGER dimb
2138      INTEGER l_a_sort
2139      INTEGER k_a_sort
2140      INTEGER l_a
2141      INTEGER k_a
2142      INTEGER l_b_sort
2143      INTEGER k_b_sort
2144      INTEGER l_b
2145      INTEGER k_b
2146      INTEGER l_c
2147      INTEGER k_c
2148      EXTERNAL NXTASK
2149      nprocs = GA_NNODES()
2150      count = 0
2151      next = NXTASK(nprocs,1)
2152      DO h6b = 1,noab
2153      DO p7b = noab+1,noab+nvab
2154      IF (next.eq.count) THEN
2155      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p7b-1
2156     &).ne.4)) THEN
2157      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p7b-1)) THEN
2158      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p7b-1)) .eq. ieor(irrep_
2159     &v,irrep_t)) THEN
2160      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1)
2161      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
2162     & ERRQUIT('cc2_x1_4_2',0,MA_ERR)
2163      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
2164      DO p3b = noab+1,noab+nvab
2165      DO h4b = 1,noab
2166      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN
2167      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_t) TH
2168     &EN
2169      CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1)
2170      CALL TCE_RESTRICTED_4(h6b,h4b,p7b,p3b,h6b_2,h4b_2,p7b_2,p3b_2)
2171      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1)
2172      dima_sort = 1
2173      dima = dim_common * dima_sort
2174      dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p7b-1)
2175      dimb = dim_common * dimb_sort
2176      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2177      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2178     & ERRQUIT('cc2_x1_4_2',1,MA_ERR)
2179      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2180     &cc2_x1_4_2',2,MA_ERR)
2181      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
2182     &int_mb(k_a_offset),(h4b_1
2183     & - 1 + noab * (p3b_1 - noab - 1)))
2184      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
2185     &,int_mb(k_range+h4b-1),2,1,1.0d0)
2186      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_4_2',3,MA_ERR)
2187      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
2188     & ERRQUIT('cc2_x1_4_2',4,MA_ERR)
2189      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2190     &cc2_x1_4_2',5,MA_ERR)
2191      IF ((h4b .le. h6b) .and. (p3b .le. p7b)) THEN
2192      if(.not.intorb) then
2193      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
2194     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
2195     &+nvab) * (h4b_2 - 1)))))
2196      else
2197      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2198     &(p7b_2
2199     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
2200     &+nvab) * (h4b_2 - 1)))),p7b_2,p3b_2,h6b_2,h4b_2)
2201      end if
2202      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
2203     &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1)
2204     &,4,2,1,3,1.0d0)
2205      END IF
2206      IF ((h4b .le. h6b) .and. (p7b .lt. p3b)) THEN
2207      if(.not.intorb) then
2208      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
2209     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
2210     &+nvab) * (h4b_2 - 1)))))
2211      else
2212      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2213     &(p3b_2
2214     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
2215     &+nvab) * (h4b_2 - 1)))),p3b_2,p7b_2,h6b_2,h4b_2)
2216      end if
2217      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
2218     &,int_mb(k_range+h6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p3b-1)
2219     &,3,2,1,4,-1.0d0)
2220      END IF
2221      IF ((h6b .lt. h4b) .and. (p3b .le. p7b)) THEN
2222      if(.not.intorb) then
2223      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
2224     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
2225     &+nvab) * (h6b_2 - 1)))))
2226      else
2227      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2228     &(p7b_2
2229     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
2230     &+nvab) * (h6b_2 - 1)))),p7b_2,p3b_2,h4b_2,h6b_2)
2231      end if
2232      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
2233     &,int_mb(k_range+h4b-1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1)
2234     &,4,1,2,3,-1.0d0)
2235      END IF
2236      IF ((h6b .lt. h4b) .and. (p7b .lt. p3b)) THEN
2237      if(.not.intorb) then
2238      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
2239     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
2240     &+nvab) * (h6b_2 - 1)))))
2241      else
2242      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2243     &(p3b_2
2244     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
2245     &+nvab) * (h6b_2 - 1)))),p3b_2,p7b_2,h4b_2,h6b_2)
2246      end if
2247      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
2248     &,int_mb(k_range+h4b-1),int_mb(k_range+p7b-1),int_mb(k_range+p3b-1)
2249     &,3,1,2,4,1.0d0)
2250      END IF
2251      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_4_2',6,MA_ERR)
2252      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
2253     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
2254     &t),dima_sort)
2255      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_4_2',7,MA_ER
2256     &R)
2257      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_4_2',8,MA_ER
2258     &R)
2259      END IF
2260      END IF
2261      END IF
2262      END DO
2263      END DO
2264      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2265     &cc2_x1_4_2',9,MA_ERR)
2266      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p7b-1)
2267     &,int_mb(k_range+h6b-1),2,1,1.0d0)
2268      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b -
2269     & noab - 1 + nvab * (h6b - 1)))
2270      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_4_2',10,MA_ERR)
2271      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_4_2',11,MA_E
2272     &RR)
2273      END IF
2274      END IF
2275      END IF
2276      next = NXTASK(nprocs,1)
2277      END IF
2278      count = count + 1
2279      END DO
2280      END DO
2281      next = NXTASK(-nprocs,1)
2282      call GA_SYNC()
2283      RETURN
2284      END
2285      SUBROUTINE cc2_x1_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
2286C     $Id$
2287C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2288C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2289C     i0 ( p2 h1 )_xv + = -1/2 * Sum ( p7 h6 h8 ) * x ( p2 p7 h6 h8 )_x * i1 ( h6 h8 h1 p7 )_v
2290      IMPLICIT NONE
2291#include "global.fh"
2292#include "mafdecls.fh"
2293#include "sym.fh"
2294#include "errquit.fh"
2295#include "tce.fh"
2296      INTEGER d_a
2297      INTEGER k_a_offset
2298      INTEGER d_b
2299      INTEGER k_b_offset
2300      INTEGER d_c
2301      INTEGER k_c_offset
2302      INTEGER NXTASK
2303      INTEGER next
2304      INTEGER nprocs
2305      INTEGER count
2306      INTEGER p2b
2307      INTEGER h1b
2308      INTEGER dimc
2309      INTEGER l_c_sort
2310      INTEGER k_c_sort
2311      INTEGER p7b
2312      INTEGER h6b
2313      INTEGER h8b
2314      INTEGER p2b_1
2315      INTEGER p7b_1
2316      INTEGER h6b_1
2317      INTEGER h8b_1
2318      INTEGER h6b_2
2319      INTEGER h8b_2
2320      INTEGER h1b_2
2321      INTEGER p7b_2
2322      INTEGER dim_common
2323      INTEGER dima_sort
2324      INTEGER dima
2325      INTEGER dimb_sort
2326      INTEGER dimb
2327      INTEGER l_a_sort
2328      INTEGER k_a_sort
2329      INTEGER l_a
2330      INTEGER k_a
2331      INTEGER l_b_sort
2332      INTEGER k_b_sort
2333      INTEGER l_b
2334      INTEGER k_b
2335      INTEGER nsubh(2)
2336      INTEGER isubh
2337      INTEGER l_c
2338      INTEGER k_c
2339      DOUBLE PRECISION FACTORIAL
2340      EXTERNAL NXTASK
2341      EXTERNAL FACTORIAL
2342      nprocs = GA_NNODES()
2343      count = 0
2344      next = NXTASK(nprocs,1)
2345      DO p2b = noab+1,noab+nvab
2346      DO h1b = 1,noab
2347      IF (next.eq.count) THEN
2348      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
2349     &).ne.4)) THEN
2350      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2351      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
2352     &x,irrep_v)) THEN
2353      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
2354      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
2355     & ERRQUIT('cc2_x1_5',0,MA_ERR)
2356      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
2357      DO p7b = noab+1,noab+nvab
2358      DO h6b = 1,noab
2359      DO h8b = h6b,noab
2360      IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h
2361     &6b-1)+int_mb(k_spin+h8b-1)) THEN
2362      IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb(
2363     &k_sym+h6b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_x) THEN
2364      CALL TCE_RESTRICTED_4(p2b,p7b,h6b,h8b,p2b_1,p7b_1,h6b_1,h8b_1)
2365      CALL TCE_RESTRICTED_4(h6b,h8b,h1b,p7b,h6b_2,h8b_2,h1b_2,p7b_2)
2366      dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+h6b-1) * int_m
2367     &b(k_range+h8b-1)
2368      dima_sort = int_mb(k_range+p2b-1)
2369      dima = dim_common * dima_sort
2370      dimb_sort = int_mb(k_range+h1b-1)
2371      dimb = dim_common * dimb_sort
2372      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2373      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2374     & ERRQUIT('cc2_x1_5',1,MA_ERR)
2375      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2376     &cc2_x1_5',2,MA_ERR)
2377      IF ((p7b .lt. p2b)) THEN
2378      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
2379     & - 1 + noab * (h6b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p7b_
2380     &1 - noab - 1)))))
2381      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
2382     &,int_mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h8b-1)
2383     &,2,4,3,1,-1.0d0)
2384      END IF
2385      IF ((p2b .le. p7b)) THEN
2386      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
2387     & - 1 + noab * (h6b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p2b_
2388     &1 - noab - 1)))))
2389      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
2390     &,int_mb(k_range+p7b-1),int_mb(k_range+h6b-1),int_mb(k_range+h8b-1)
2391     &,1,4,3,2,1.0d0)
2392      END IF
2393      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_5',3,MA_ERR)
2394      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
2395     & ERRQUIT('cc2_x1_5',4,MA_ERR)
2396      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2397     &cc2_x1_5',5,MA_ERR)
2398      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
2399     & - noab - 1 + nvab * (h1b_2 - 1 + noab * (h8b_2 - 1 + noab * (h6b_
2400     &2 - 1)))))
2401      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
2402     &,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),int_mb(k_range+p7b-1)
2403     &,3,2,1,4,1.0d0)
2404      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_5',6,MA_ERR)
2405      nsubh(1) = 1
2406      nsubh(2) = 1
2407      isubh = 1
2408      IF (h6b .eq. h8b) THEN
2409      nsubh(isubh) = nsubh(isubh) + 1
2410      ELSE
2411      isubh = isubh + 1
2412      END IF
2413      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
2414     &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k
2415     &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
2416      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_5',7,MA_ERR)
2417      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_5',8,MA_ERR)
2418      END IF
2419      END IF
2420      END IF
2421      END DO
2422      END DO
2423      END DO
2424      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2425     &cc2_x1_5',9,MA_ERR)
2426      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
2427     &,int_mb(k_range+p2b-1),2,1,-1.0d0/2.0d0)
2428      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
2429     & 1 + noab * (p2b - noab - 1)))
2430      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_5',10,MA_ERR)
2431      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_5',11,MA_ERR
2432     &)
2433      END IF
2434      END IF
2435      END IF
2436      next = NXTASK(nprocs,1)
2437      END IF
2438      count = count + 1
2439      END DO
2440      END DO
2441      next = NXTASK(-nprocs,1)
2442      call GA_SYNC()
2443      RETURN
2444      END
2445      SUBROUTINE cc2_x1_5_1(d_a,k_a_offset,d_c,k_c_offset)
2446C     $Id$
2447C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2448C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2449C     i1 ( h6 h8 h1 p7 )_v + = 1 * v ( h6 h8 h1 p7 )_v
2450      IMPLICIT NONE
2451#include "global.fh"
2452#include "mafdecls.fh"
2453#include "sym.fh"
2454#include "errquit.fh"
2455#include "tce.fh"
2456      INTEGER d_a
2457      INTEGER k_a_offset
2458      INTEGER d_c
2459      INTEGER k_c_offset
2460      INTEGER NXTASK
2461      INTEGER next
2462      INTEGER nprocs
2463      INTEGER count
2464      INTEGER h6b
2465      INTEGER h8b
2466      INTEGER h1b
2467      INTEGER p7b
2468      INTEGER dimc
2469      INTEGER h6b_1
2470      INTEGER h8b_1
2471      INTEGER h1b_1
2472      INTEGER p7b_1
2473      INTEGER dim_common
2474      INTEGER dima_sort
2475      INTEGER dima
2476      INTEGER l_a_sort
2477      INTEGER k_a_sort
2478      INTEGER l_a
2479      INTEGER k_a
2480      INTEGER l_c
2481      INTEGER k_c
2482      EXTERNAL NXTASK
2483      nprocs = GA_NNODES()
2484      count = 0
2485      next = NXTASK(nprocs,1)
2486      DO h6b = 1,noab
2487      DO h8b = h6b,noab
2488      DO h1b = 1,noab
2489      DO p7b = noab+1,noab+nvab
2490      IF (next.eq.count) THEN
2491      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1
2492     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p7b-1).ne.8)) THEN
2493      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h
2494     &1b-1)+int_mb(k_spin+p7b-1)) THEN
2495      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb(
2496     &k_sym+h1b-1),int_mb(k_sym+p7b-1)))) .eq. irrep_v) THEN
2497      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h8b-1) * int_mb(k_ra
2498     &nge+h1b-1) * int_mb(k_range+p7b-1)
2499      CALL TCE_RESTRICTED_4(h6b,h8b,h1b,p7b,h6b_1,h8b_1,h1b_1,p7b_1)
2500      dim_common = 1
2501      dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h8b-1) * int_mb
2502     &(k_range+h1b-1) * int_mb(k_range+p7b-1)
2503      dima = dim_common * dima_sort
2504      IF (dima .gt. 0) THEN
2505      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2506     & ERRQUIT('cc2_x1_5_1',0,MA_ERR)
2507      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2508     &cc2_x1_5_1',1,MA_ERR)
2509      IF ((h1b .le. p7b)) THEN
2510      if(.not.intorb) then
2511      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p7b_1
2512     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h8b_1 - 1 + (noab
2513     &+nvab) * (h6b_1 - 1)))))
2514      else
2515      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
2516     &(p7b_1
2517     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h8b_1 - 1 + (noab
2518     &+nvab) * (h6b_1 - 1)))),p7b_1,h1b_1,h8b_1,h6b_1)
2519      end if
2520      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1)
2521     &,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),int_mb(k_range+p7b-1)
2522     &,4,3,2,1,1.0d0)
2523      END IF
2524      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_5_1',2,MA_ERR)
2525      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2526     &cc2_x1_5_1',3,MA_ERR)
2527      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p7b-1)
2528     &,int_mb(k_range+h1b-1),int_mb(k_range+h8b-1),int_mb(k_range+h6b-1)
2529     &,4,3,2,1,1.0d0)
2530      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b -
2531     & noab - 1 + nvab * (h1b - 1 + noab * (h8b - 1 + noab * (h6b - 1)))
2532     &))
2533      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_5_1',4,MA_ERR)
2534      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_5_1',5,MA_ER
2535     &R)
2536      END IF
2537      END IF
2538      END IF
2539      END IF
2540      next = NXTASK(nprocs,1)
2541      END IF
2542      count = count + 1
2543      END DO
2544      END DO
2545      END DO
2546      END DO
2547      next = NXTASK(-nprocs,1)
2548      call GA_SYNC()
2549      RETURN
2550      END
2551      SUBROUTINE OFFSET_cc2_x1_5_1(l_a_offset,k_a_offset,size)
2552C     $Id$
2553C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2554C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2555C     i1 ( h6 h8 h1 p7 )_v
2556      IMPLICIT NONE
2557#include "global.fh"
2558#include "mafdecls.fh"
2559#include "sym.fh"
2560#include "errquit.fh"
2561#include "tce.fh"
2562      INTEGER l_a_offset
2563      INTEGER k_a_offset
2564      INTEGER size
2565      INTEGER length
2566      INTEGER addr
2567      INTEGER h6b
2568      INTEGER h8b
2569      INTEGER h1b
2570      INTEGER p7b
2571      length = 0
2572      DO h6b = 1,noab
2573      DO h8b = h6b,noab
2574      DO h1b = 1,noab
2575      DO p7b = noab+1,noab+nvab
2576      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h
2577     &1b-1)+int_mb(k_spin+p7b-1)) THEN
2578      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb(
2579     &k_sym+h1b-1),int_mb(k_sym+p7b-1)))) .eq. irrep_v) THEN
2580      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1
2581     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p7b-1).ne.8)) THEN
2582      length = length + 1
2583      END IF
2584      END IF
2585      END IF
2586      END DO
2587      END DO
2588      END DO
2589      END DO
2590      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
2591     &set)) CALL ERRQUIT('cc2_x1_5_1',0,MA_ERR)
2592      int_mb(k_a_offset) = length
2593      addr = 0
2594      size = 0
2595      DO h6b = 1,noab
2596      DO h8b = h6b,noab
2597      DO h1b = 1,noab
2598      DO p7b = noab+1,noab+nvab
2599      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h
2600     &1b-1)+int_mb(k_spin+p7b-1)) THEN
2601      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb(
2602     &k_sym+h1b-1),int_mb(k_sym+p7b-1)))) .eq. irrep_v) THEN
2603      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1
2604     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p7b-1).ne.8)) THEN
2605      addr = addr + 1
2606      int_mb(k_a_offset+addr) = p7b - noab - 1 + nvab * (h1b - 1 + noab
2607     &* (h8b - 1 + noab * (h6b - 1)))
2608      int_mb(k_a_offset+length+addr) = size
2609      size = size + int_mb(k_range+h6b-1) * int_mb(k_range+h8b-1) * int_
2610     &mb(k_range+h1b-1) * int_mb(k_range+p7b-1)
2611      END IF
2612      END IF
2613      END IF
2614      END DO
2615      END DO
2616      END DO
2617      END DO
2618      RETURN
2619      END
2620      SUBROUTINE cc2_x1_5_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
2621     &)
2622C     $Id$
2623C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2624C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2625C     i1 ( h6 h8 h1 p7 )_vt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * v ( h6 h8 p3 p7 )_v
2626      IMPLICIT NONE
2627#include "global.fh"
2628#include "mafdecls.fh"
2629#include "sym.fh"
2630#include "errquit.fh"
2631#include "tce.fh"
2632      INTEGER d_a
2633      INTEGER k_a_offset
2634      INTEGER d_b
2635      INTEGER k_b_offset
2636      INTEGER d_c
2637      INTEGER k_c_offset
2638      INTEGER NXTASK
2639      INTEGER next
2640      INTEGER nprocs
2641      INTEGER count
2642      INTEGER h6b
2643      INTEGER h8b
2644      INTEGER h1b
2645      INTEGER p7b
2646      INTEGER dimc
2647      INTEGER l_c_sort
2648      INTEGER k_c_sort
2649      INTEGER p3b
2650      INTEGER p3b_1
2651      INTEGER h1b_1
2652      INTEGER h6b_2
2653      INTEGER h8b_2
2654      INTEGER p7b_2
2655      INTEGER p3b_2
2656      INTEGER dim_common
2657      INTEGER dima_sort
2658      INTEGER dima
2659      INTEGER dimb_sort
2660      INTEGER dimb
2661      INTEGER l_a_sort
2662      INTEGER k_a_sort
2663      INTEGER l_a
2664      INTEGER k_a
2665      INTEGER l_b_sort
2666      INTEGER k_b_sort
2667      INTEGER l_b
2668      INTEGER k_b
2669      INTEGER l_c
2670      INTEGER k_c
2671      EXTERNAL NXTASK
2672      nprocs = GA_NNODES()
2673      count = 0
2674      next = NXTASK(nprocs,1)
2675      DO h6b = 1,noab
2676      DO h8b = h6b,noab
2677      DO h1b = 1,noab
2678      DO p7b = noab+1,noab+nvab
2679      IF (next.eq.count) THEN
2680      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1
2681     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p7b-1).ne.8)) THEN
2682      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h
2683     &1b-1)+int_mb(k_spin+p7b-1)) THEN
2684      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb(
2685     &k_sym+h1b-1),int_mb(k_sym+p7b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
2686     &EN
2687      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h8b-1) * int_mb(k_ra
2688     &nge+h1b-1) * int_mb(k_range+p7b-1)
2689      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
2690     & ERRQUIT('cc2_x1_5_2',0,MA_ERR)
2691      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
2692      DO p3b = noab+1,noab+nvab
2693      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2694      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
2695     &EN
2696      CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1)
2697      CALL TCE_RESTRICTED_4(h6b,h8b,p7b,p3b,h6b_2,h8b_2,p7b_2,p3b_2)
2698      dim_common = int_mb(k_range+p3b-1)
2699      dima_sort = int_mb(k_range+h1b-1)
2700      dima = dim_common * dima_sort
2701      dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h8b-1) * int_mb
2702     &(k_range+p7b-1)
2703      dimb = dim_common * dimb_sort
2704      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2705      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2706     & ERRQUIT('cc2_x1_5_2',1,MA_ERR)
2707      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2708     &cc2_x1_5_2',2,MA_ERR)
2709      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
2710     &int_mb(k_a_offset),(h1b_1
2711     & - 1 + noab * (p3b_1 - noab - 1)))
2712      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
2713     &,int_mb(k_range+h1b-1),2,1,1.0d0)
2714      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_5_2',3,MA_ERR)
2715      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
2716     & ERRQUIT('cc2_x1_5_2',4,MA_ERR)
2717      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2718     &cc2_x1_5_2',5,MA_ERR)
2719      IF ((p3b .le. p7b)) THEN
2720      if(.not.intorb) then
2721      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
2722     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
2723     &+nvab) * (h6b_2 - 1)))))
2724      else
2725      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2726     &(p7b_2
2727     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
2728     &+nvab) * (h6b_2 - 1)))),p7b_2,p3b_2,h8b_2,h6b_2)
2729      end if
2730      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
2731     &,int_mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1)
2732     &,4,2,1,3,1.0d0)
2733      END IF
2734      IF ((p7b .lt. p3b)) THEN
2735      if(.not.intorb) then
2736      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
2737     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
2738     &+nvab) * (h6b_2 - 1)))))
2739      else
2740      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2741     &(p3b_2
2742     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
2743     &+nvab) * (h6b_2 - 1)))),p3b_2,p7b_2,h8b_2,h6b_2)
2744      end if
2745      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
2746     &,int_mb(k_range+h8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p3b-1)
2747     &,3,2,1,4,-1.0d0)
2748      END IF
2749      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_5_2',6,MA_ERR)
2750      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
2751     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
2752     &t),dima_sort)
2753      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_5_2',7,MA_ER
2754     &R)
2755      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_5_2',8,MA_ER
2756     &R)
2757      END IF
2758      END IF
2759      END IF
2760      END DO
2761      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2762     &cc2_x1_5_2',9,MA_ERR)
2763      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p7b-1)
2764     &,int_mb(k_range+h8b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1)
2765     &,3,2,4,1,1.0d0)
2766      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b -
2767     & noab - 1 + nvab * (h1b - 1 + noab * (h8b - 1 + noab * (h6b - 1)))
2768     &))
2769      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_5_2',10,MA_ERR)
2770      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_5_2',11,MA_E
2771     &RR)
2772      END IF
2773      END IF
2774      END IF
2775      next = NXTASK(nprocs,1)
2776      END IF
2777      count = count + 1
2778      END DO
2779      END DO
2780      END DO
2781      END DO
2782      next = NXTASK(-nprocs,1)
2783      call GA_SYNC()
2784      RETURN
2785      END
2786      SUBROUTINE cc2_x1_6(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
2787C     $Id$
2788C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2789C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2790C     i0 ( p2 h1 )_xv + = -1/2 * Sum ( p4 p5 h3 ) * x ( p4 p5 h1 h3 )_x * v ( h3 p2 p4 p5 )_v
2791      IMPLICIT NONE
2792#include "global.fh"
2793#include "mafdecls.fh"
2794#include "sym.fh"
2795#include "errquit.fh"
2796#include "tce.fh"
2797      INTEGER d_a
2798      INTEGER k_a_offset
2799      INTEGER d_b
2800      INTEGER k_b_offset
2801      INTEGER d_c
2802      INTEGER k_c_offset
2803      INTEGER NXTASK
2804      INTEGER next
2805      INTEGER nprocs
2806      INTEGER count
2807      INTEGER p2b
2808      INTEGER h1b
2809      INTEGER dimc
2810      INTEGER l_c_sort
2811      INTEGER k_c_sort
2812      INTEGER p4b
2813      INTEGER p5b
2814      INTEGER h3b
2815      INTEGER p4b_1
2816      INTEGER p5b_1
2817      INTEGER h1b_1
2818      INTEGER h3b_1
2819      INTEGER p2b_2
2820      INTEGER h3b_2
2821      INTEGER p4b_2
2822      INTEGER p5b_2
2823      INTEGER dim_common
2824      INTEGER dima_sort
2825      INTEGER dima
2826      INTEGER dimb_sort
2827      INTEGER dimb
2828      INTEGER l_a_sort
2829      INTEGER k_a_sort
2830      INTEGER l_a
2831      INTEGER k_a
2832      INTEGER l_b_sort
2833      INTEGER k_b_sort
2834      INTEGER l_b
2835      INTEGER k_b
2836      INTEGER nsuperp(2)
2837      INTEGER isuperp
2838      INTEGER l_c
2839      INTEGER k_c
2840      DOUBLE PRECISION FACTORIAL
2841      EXTERNAL NXTASK
2842      EXTERNAL FACTORIAL
2843      nprocs = GA_NNODES()
2844      count = 0
2845      next = NXTASK(nprocs,1)
2846      DO p2b = noab+1,noab+nvab
2847      DO h1b = 1,noab
2848      IF (next.eq.count) THEN
2849      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
2850     &).ne.4)) THEN
2851      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2852      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
2853     &x,irrep_v)) THEN
2854      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
2855      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
2856     & ERRQUIT('cc2_x1_6',0,MA_ERR)
2857      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
2858      DO p4b = noab+1,noab+nvab
2859      DO p5b = p4b,noab+nvab
2860      DO h3b = 1,noab
2861      IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
2862     &1b-1)+int_mb(k_spin+h3b-1)) THEN
2863      IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
2864     &k_sym+h1b-1),int_mb(k_sym+h3b-1)))) .eq. irrep_x) THEN
2865      CALL TCE_RESTRICTED_4(p4b,p5b,h1b,h3b,p4b_1,p5b_1,h1b_1,h3b_1)
2866      CALL TCE_RESTRICTED_4(p2b,h3b,p4b,p5b,p2b_2,h3b_2,p4b_2,p5b_2)
2867      dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_m
2868     &b(k_range+h3b-1)
2869      dima_sort = int_mb(k_range+h1b-1)
2870      dima = dim_common * dima_sort
2871      dimb_sort = int_mb(k_range+p2b-1)
2872      dimb = dim_common * dimb_sort
2873      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2874      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2875     & ERRQUIT('cc2_x1_6',1,MA_ERR)
2876      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2877     &cc2_x1_6',2,MA_ERR)
2878      IF ((h3b .lt. h1b)) THEN
2879      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
2880     & - 1 + noab * (h3b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_
2881     &1 - noab - 1)))))
2882      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
2883     &,int_mb(k_range+p5b-1),int_mb(k_range+h3b-1),int_mb(k_range+h1b-1)
2884     &,4,3,2,1,-1.0d0)
2885      END IF
2886      IF ((h1b .le. h3b)) THEN
2887      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
2888     & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p4b_
2889     &1 - noab - 1)))))
2890      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
2891     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h3b-1)
2892     &,3,4,2,1,1.0d0)
2893      END IF
2894      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_6',3,MA_ERR)
2895      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
2896     & ERRQUIT('cc2_x1_6',4,MA_ERR)
2897      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2898     &cc2_x1_6',5,MA_ERR)
2899      IF ((h3b .le. p2b)) THEN
2900      if(.not.intorb) then
2901      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
2902     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
2903     &+nvab) * (h3b_2 - 1)))))
2904      else
2905      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2906     &(p5b_2
2907     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
2908     &+nvab) * (h3b_2 - 1)))),p5b_2,p4b_2,p2b_2,h3b_2)
2909      end if
2910      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
2911     &,int_mb(k_range+p2b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1)
2912     &,2,1,4,3,1.0d0)
2913      END IF
2914      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_6',6,MA_ERR)
2915      nsuperp(1) = 1
2916      nsuperp(2) = 1
2917      isuperp = 1
2918      IF (p4b .eq. p5b) THEN
2919      nsuperp(isuperp) = nsuperp(isuperp) + 1
2920      ELSE
2921      isuperp = isuperp + 1
2922      END IF
2923      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
2924     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
2925     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
2926      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_6',7,MA_ERR)
2927      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_6',8,MA_ERR)
2928      END IF
2929      END IF
2930      END IF
2931      END DO
2932      END DO
2933      END DO
2934      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2935     &cc2_x1_6',9,MA_ERR)
2936      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1)
2937     &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0)
2938      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
2939     & 1 + noab * (p2b - noab - 1)))
2940      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_6',10,MA_ERR)
2941      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_6',11,MA_ERR
2942     &)
2943      END IF
2944      END IF
2945      END IF
2946      next = NXTASK(nprocs,1)
2947      END IF
2948      count = count + 1
2949      END DO
2950      END DO
2951      next = NXTASK(-nprocs,1)
2952      call GA_SYNC()
2953      RETURN
2954      END
2955      SUBROUTINE cc2_x1_7(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
2956C     $Id$
2957C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2958C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2959C     i0 ( p2 h1 )_fxt + = -1 * Sum ( h8 ) * t ( p2 h8 )_t * i1 ( h8 h1 )_fx
2960      IMPLICIT NONE
2961#include "global.fh"
2962#include "mafdecls.fh"
2963#include "sym.fh"
2964#include "errquit.fh"
2965#include "tce.fh"
2966      INTEGER d_a
2967      INTEGER k_a_offset
2968      INTEGER d_b
2969      INTEGER k_b_offset
2970      INTEGER d_c
2971      INTEGER k_c_offset
2972      INTEGER NXTASK
2973      INTEGER next
2974      INTEGER nprocs
2975      INTEGER count
2976      INTEGER p2b
2977      INTEGER h1b
2978      INTEGER dimc
2979      INTEGER l_c_sort
2980      INTEGER k_c_sort
2981      INTEGER h8b
2982      INTEGER p2b_1
2983      INTEGER h8b_1
2984      INTEGER h8b_2
2985      INTEGER h1b_2
2986      INTEGER dim_common
2987      INTEGER dima_sort
2988      INTEGER dima
2989      INTEGER dimb_sort
2990      INTEGER dimb
2991      INTEGER l_a_sort
2992      INTEGER k_a_sort
2993      INTEGER l_a
2994      INTEGER k_a
2995      INTEGER l_b_sort
2996      INTEGER k_b_sort
2997      INTEGER l_b
2998      INTEGER k_b
2999      INTEGER l_c
3000      INTEGER k_c
3001      EXTERNAL NXTASK
3002      nprocs = GA_NNODES()
3003      count = 0
3004      next = NXTASK(nprocs,1)
3005      DO p2b = noab+1,noab+nvab
3006      DO h1b = 1,noab
3007      IF (next.eq.count) THEN
3008      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
3009     &).ne.4)) THEN
3010      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3011      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
3012     &f,ieor(irrep_x,irrep_t))) THEN
3013      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
3014      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3015     & ERRQUIT('cc2_x1_7',0,MA_ERR)
3016      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3017      DO h8b = 1,noab
3018      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h8b-1)) THEN
3019      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h8b-1)) .eq. irrep_t) TH
3020     &EN
3021      CALL TCE_RESTRICTED_2(p2b,h8b,p2b_1,h8b_1)
3022      CALL TCE_RESTRICTED_2(h8b,h1b,h8b_2,h1b_2)
3023      dim_common = int_mb(k_range+h8b-1)
3024      dima_sort = int_mb(k_range+p2b-1)
3025      dima = dim_common * dima_sort
3026      dimb_sort = int_mb(k_range+h1b-1)
3027      dimb = dim_common * dimb_sort
3028      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
3029      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3030     & ERRQUIT('cc2_x1_7',1,MA_ERR)
3031      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3032     &cc2_x1_7',2,MA_ERR)
3033      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
3034     &int_mb(k_a_offset),(h8b_1
3035     & - 1 + noab * (p2b_1 - noab - 1)))
3036      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
3037     &,int_mb(k_range+h8b-1),1,2,1.0d0)
3038      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7',3,MA_ERR)
3039      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
3040     & ERRQUIT('cc2_x1_7',4,MA_ERR)
3041      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
3042     &cc2_x1_7',5,MA_ERR)
3043      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2
3044     & - 1 + noab * (h8b_2 - 1)))
3045      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
3046     &,int_mb(k_range+h1b-1),2,1,1.0d0)
3047      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7',6,MA_ERR)
3048      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
3049     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
3050     &t),dima_sort)
3051      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7',7,MA_ERR)
3052      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7',8,MA_ERR)
3053      END IF
3054      END IF
3055      END IF
3056      END DO
3057      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3058     &cc2_x1_7',9,MA_ERR)
3059      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
3060     &,int_mb(k_range+p2b-1),2,1,-1.0d0)
3061      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
3062     & 1 + noab * (p2b - noab - 1)))
3063      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7',10,MA_ERR)
3064      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7',11,MA_ERR
3065     &)
3066      END IF
3067      END IF
3068      END IF
3069      next = NXTASK(nprocs,1)
3070      END IF
3071      count = count + 1
3072      END DO
3073      END DO
3074      next = NXTASK(-nprocs,1)
3075      call GA_SYNC()
3076      RETURN
3077      END
3078      SUBROUTINE cc2_x1_7_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
3079     &)
3080C     $Id$
3081C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3082C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3083C     i1 ( h8 h1 )_fx + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * i2 ( h8 p3 )_f
3084      IMPLICIT NONE
3085#include "global.fh"
3086#include "mafdecls.fh"
3087#include "sym.fh"
3088#include "errquit.fh"
3089#include "tce.fh"
3090      INTEGER d_a
3091      INTEGER k_a_offset
3092      INTEGER d_b
3093      INTEGER k_b_offset
3094      INTEGER d_c
3095      INTEGER k_c_offset
3096      INTEGER NXTASK
3097      INTEGER next
3098      INTEGER nprocs
3099      INTEGER count
3100      INTEGER h8b
3101      INTEGER h1b
3102      INTEGER dimc
3103      INTEGER l_c_sort
3104      INTEGER k_c_sort
3105      INTEGER p3b
3106      INTEGER p3b_1
3107      INTEGER h1b_1
3108      INTEGER h8b_2
3109      INTEGER p3b_2
3110      INTEGER dim_common
3111      INTEGER dima_sort
3112      INTEGER dima
3113      INTEGER dimb_sort
3114      INTEGER dimb
3115      INTEGER l_a_sort
3116      INTEGER k_a_sort
3117      INTEGER l_a
3118      INTEGER k_a
3119      INTEGER l_b_sort
3120      INTEGER k_b_sort
3121      INTEGER l_b
3122      INTEGER k_b
3123      INTEGER l_c
3124      INTEGER k_c
3125      EXTERNAL NXTASK
3126      nprocs = GA_NNODES()
3127      count = 0
3128      next = NXTASK(nprocs,1)
3129      DO h8b = 1,noab
3130      DO h1b = 1,noab
3131      IF (next.eq.count) THEN
3132      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
3133     &).ne.4)) THEN
3134      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3135      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
3136     &f,irrep_x)) THEN
3137      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
3138      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3139     & ERRQUIT('cc2_x1_7_1',0,MA_ERR)
3140      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3141      DO p3b = noab+1,noab+nvab
3142      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3143      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH
3144     &EN
3145      CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1)
3146      CALL TCE_RESTRICTED_2(h8b,p3b,h8b_2,p3b_2)
3147      dim_common = int_mb(k_range+p3b-1)
3148      dima_sort = int_mb(k_range+h1b-1)
3149      dima = dim_common * dima_sort
3150      dimb_sort = int_mb(k_range+h8b-1)
3151      dimb = dim_common * dimb_sort
3152      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
3153      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3154     & ERRQUIT('cc2_x1_7_1',1,MA_ERR)
3155      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3156     &cc2_x1_7_1',2,MA_ERR)
3157      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
3158     &int_mb(k_a_offset),(h1b_1
3159     & - 1 + noab * (p3b_1 - noab - 1)))
3160      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
3161     &,int_mb(k_range+h1b-1),2,1,1.0d0)
3162      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_1',3,MA_ERR)
3163      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
3164     & ERRQUIT('cc2_x1_7_1',4,MA_ERR)
3165      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
3166     &cc2_x1_7_1',5,MA_ERR)
3167      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
3168     & - noab - 1 + nvab * (h8b_2 - 1)))
3169      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
3170     &,int_mb(k_range+p3b-1),1,2,1.0d0)
3171      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_1',6,MA_ERR)
3172      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
3173     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
3174     &t),dima_sort)
3175      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_1',7,MA_ER
3176     &R)
3177      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_1',8,MA_ER
3178     &R)
3179      END IF
3180      END IF
3181      END IF
3182      END DO
3183      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3184     &cc2_x1_7_1',9,MA_ERR)
3185      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1)
3186     &,int_mb(k_range+h1b-1),1,2,1.0d0)
3187      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
3188     & 1 + noab * (h8b - 1)))
3189      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_1',10,MA_ERR)
3190      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_1',11,MA_E
3191     &RR)
3192      END IF
3193      END IF
3194      END IF
3195      next = NXTASK(nprocs,1)
3196      END IF
3197      count = count + 1
3198      END DO
3199      END DO
3200      next = NXTASK(-nprocs,1)
3201      call GA_SYNC()
3202      RETURN
3203      END
3204      SUBROUTINE OFFSET_cc2_x1_7_1(l_a_offset,k_a_offset,size)
3205C     $Id$
3206C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3207C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3208C     i1 ( h8 h1 )_fx
3209      IMPLICIT NONE
3210#include "global.fh"
3211#include "mafdecls.fh"
3212#include "sym.fh"
3213#include "errquit.fh"
3214#include "tce.fh"
3215      INTEGER l_a_offset
3216      INTEGER k_a_offset
3217      INTEGER size
3218      INTEGER length
3219      INTEGER addr
3220      INTEGER h8b
3221      INTEGER h1b
3222      length = 0
3223      DO h8b = 1,noab
3224      DO h1b = 1,noab
3225      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3226      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
3227     &f,irrep_x)) THEN
3228      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
3229     &).ne.4)) THEN
3230      length = length + 1
3231      END IF
3232      END IF
3233      END IF
3234      END DO
3235      END DO
3236      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
3237     &set)) CALL ERRQUIT('cc2_x1_7_1',0,MA_ERR)
3238      int_mb(k_a_offset) = length
3239      addr = 0
3240      size = 0
3241      DO h8b = 1,noab
3242      DO h1b = 1,noab
3243      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3244      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
3245     &f,irrep_x)) THEN
3246      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
3247     &).ne.4)) THEN
3248      addr = addr + 1
3249      int_mb(k_a_offset+addr) = h1b - 1 + noab * (h8b - 1)
3250      int_mb(k_a_offset+length+addr) = size
3251      size = size + int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
3252      END IF
3253      END IF
3254      END IF
3255      END DO
3256      END DO
3257      RETURN
3258      END
3259      SUBROUTINE cc2_x1_7_1_1(d_a,k_a_offset,d_c,k_c_offset)
3260C     $Id$
3261C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3262C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3263C     i2 ( h8 p3 )_f + = 1 * f ( h8 p3 )_f
3264      IMPLICIT NONE
3265#include "global.fh"
3266#include "mafdecls.fh"
3267#include "sym.fh"
3268#include "errquit.fh"
3269#include "tce.fh"
3270      INTEGER d_a
3271      INTEGER k_a_offset
3272      INTEGER d_c
3273      INTEGER k_c_offset
3274      INTEGER NXTASK
3275      INTEGER next
3276      INTEGER nprocs
3277      INTEGER count
3278      INTEGER h8b
3279      INTEGER p3b
3280      INTEGER dimc
3281      INTEGER h8b_1
3282      INTEGER p3b_1
3283      INTEGER dim_common
3284      INTEGER dima_sort
3285      INTEGER dima
3286      INTEGER l_a_sort
3287      INTEGER k_a_sort
3288      INTEGER l_a
3289      INTEGER k_a
3290      INTEGER l_c
3291      INTEGER k_c
3292      EXTERNAL NXTASK
3293      nprocs = GA_NNODES()
3294      count = 0
3295      next = NXTASK(nprocs,1)
3296      DO h8b = 1,noab
3297      DO p3b = noab+1,noab+nvab
3298      IF (next.eq.count) THEN
3299      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1
3300     &).ne.4)) THEN
3301      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN
3302      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. irrep_f) TH
3303     &EN
3304      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1)
3305      CALL TCE_RESTRICTED_2(h8b,p3b,h8b_1,p3b_1)
3306      dim_common = 1
3307      dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1)
3308      dima = dim_common * dima_sort
3309      IF (dima .gt. 0) THEN
3310      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3311     & ERRQUIT('cc2_x1_7_1_1',0,MA_ERR)
3312      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3313     &cc2_x1_7_1_1',1,MA_ERR)
3314      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p3b_1
3315     & - 1 + (noab+nvab) * (h8b_1 - 1)))
3316      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1)
3317     &,int_mb(k_range+p3b-1),2,1,1.0d0)
3318      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_1_1',2,MA_ERR)
3319      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3320     &cc2_x1_7_1_1',3,MA_ERR)
3321      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
3322     &,int_mb(k_range+h8b-1),2,1,1.0d0)
3323      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
3324     & noab - 1 + nvab * (h8b - 1)))
3325      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_1_1',4,MA_ERR)
3326      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_1_1',5,MA_
3327     &ERR)
3328      END IF
3329      END IF
3330      END IF
3331      END IF
3332      next = NXTASK(nprocs,1)
3333      END IF
3334      count = count + 1
3335      END DO
3336      END DO
3337      next = NXTASK(-nprocs,1)
3338      call GA_SYNC()
3339      RETURN
3340      END
3341      SUBROUTINE OFFSET_cc2_x1_7_1_1(l_a_offset,k_a_offset,size)
3342C     $Id$
3343C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3344C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3345C     i2 ( h8 p3 )_f
3346      IMPLICIT NONE
3347#include "global.fh"
3348#include "mafdecls.fh"
3349#include "sym.fh"
3350#include "errquit.fh"
3351#include "tce.fh"
3352      INTEGER l_a_offset
3353      INTEGER k_a_offset
3354      INTEGER size
3355      INTEGER length
3356      INTEGER addr
3357      INTEGER h8b
3358      INTEGER p3b
3359      length = 0
3360      DO h8b = 1,noab
3361      DO p3b = noab+1,noab+nvab
3362      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN
3363      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. irrep_f) TH
3364     &EN
3365      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1
3366     &).ne.4)) THEN
3367      length = length + 1
3368      END IF
3369      END IF
3370      END IF
3371      END DO
3372      END DO
3373      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
3374     &set)) CALL ERRQUIT('cc2_x1_7_1_1',0,MA_ERR)
3375      int_mb(k_a_offset) = length
3376      addr = 0
3377      size = 0
3378      DO h8b = 1,noab
3379      DO p3b = noab+1,noab+nvab
3380      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN
3381      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. irrep_f) TH
3382     &EN
3383      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1
3384     &).ne.4)) THEN
3385      addr = addr + 1
3386      int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h8b - 1)
3387      int_mb(k_a_offset+length+addr) = size
3388      size = size + int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1)
3389      END IF
3390      END IF
3391      END IF
3392      END DO
3393      END DO
3394      RETURN
3395      END
3396      SUBROUTINE cc2_x1_7_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offs
3397     &et)
3398C     $Id$
3399C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3400C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3401C     i2 ( h8 p3 )_vt + = -1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 h8 p3 p4 )_v
3402      IMPLICIT NONE
3403#include "global.fh"
3404#include "mafdecls.fh"
3405#include "sym.fh"
3406#include "errquit.fh"
3407#include "tce.fh"
3408      INTEGER d_a
3409      INTEGER k_a_offset
3410      INTEGER d_b
3411      INTEGER k_b_offset
3412      INTEGER d_c
3413      INTEGER k_c_offset
3414      INTEGER NXTASK
3415      INTEGER next
3416      INTEGER nprocs
3417      INTEGER count
3418      INTEGER h8b
3419      INTEGER p3b
3420      INTEGER dimc
3421      INTEGER l_c_sort
3422      INTEGER k_c_sort
3423      INTEGER p4b
3424      INTEGER h5b
3425      INTEGER p4b_1
3426      INTEGER h5b_1
3427      INTEGER h8b_2
3428      INTEGER h5b_2
3429      INTEGER p3b_2
3430      INTEGER p4b_2
3431      INTEGER dim_common
3432      INTEGER dima_sort
3433      INTEGER dima
3434      INTEGER dimb_sort
3435      INTEGER dimb
3436      INTEGER l_a_sort
3437      INTEGER k_a_sort
3438      INTEGER l_a
3439      INTEGER k_a
3440      INTEGER l_b_sort
3441      INTEGER k_b_sort
3442      INTEGER l_b
3443      INTEGER k_b
3444      INTEGER l_c
3445      INTEGER k_c
3446      EXTERNAL NXTASK
3447      nprocs = GA_NNODES()
3448      count = 0
3449      next = NXTASK(nprocs,1)
3450      DO h8b = 1,noab
3451      DO p3b = noab+1,noab+nvab
3452      IF (next.eq.count) THEN
3453      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1
3454     &).ne.4)) THEN
3455      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN
3456      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
3457     &v,irrep_t)) THEN
3458      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1)
3459      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3460     & ERRQUIT('cc2_x1_7_1_2',0,MA_ERR)
3461      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3462      DO p4b = noab+1,noab+nvab
3463      DO h5b = 1,noab
3464      IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h5b-1)) THEN
3465      IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h5b-1)) .eq. irrep_t) TH
3466     &EN
3467      CALL TCE_RESTRICTED_2(p4b,h5b,p4b_1,h5b_1)
3468      CALL TCE_RESTRICTED_4(h8b,h5b,p3b,p4b,h8b_2,h5b_2,p3b_2,p4b_2)
3469      dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h5b-1)
3470      dima_sort = 1
3471      dima = dim_common * dima_sort
3472      dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1)
3473      dimb = dim_common * dimb_sort
3474      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
3475      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3476     & ERRQUIT('cc2_x1_7_1_2',1,MA_ERR)
3477      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3478     &cc2_x1_7_1_2',2,MA_ERR)
3479      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
3480     &int_mb(k_a_offset),(h5b_1
3481     & - 1 + noab * (p4b_1 - noab - 1)))
3482      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
3483     &,int_mb(k_range+h5b-1),2,1,1.0d0)
3484      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_1_2',3,MA_ERR)
3485      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
3486     & ERRQUIT('cc2_x1_7_1_2',4,MA_ERR)
3487      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
3488     &cc2_x1_7_1_2',5,MA_ERR)
3489      IF ((h5b .le. h8b) .and. (p4b .lt. p3b)) THEN
3490      if(.not.intorb) then
3491      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
3492     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3493     &+nvab) * (h5b_2 - 1)))))
3494      else
3495      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3496     &(p3b_2
3497     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3498     &+nvab) * (h5b_2 - 1)))),p3b_2,p4b_2,h8b_2,h5b_2)
3499      end if
3500      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
3501     &,int_mb(k_range+h8b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
3502     &,4,2,1,3,-1.0d0)
3503      END IF
3504      IF ((h5b .le. h8b) .and. (p3b .le. p4b)) THEN
3505      if(.not.intorb) then
3506      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
3507     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3508     &+nvab) * (h5b_2 - 1)))))
3509      else
3510      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3511     &(p4b_2
3512     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3513     &+nvab) * (h5b_2 - 1)))),p4b_2,p3b_2,h8b_2,h5b_2)
3514      end if
3515      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
3516     &,int_mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1)
3517     &,3,2,1,4,1.0d0)
3518      END IF
3519      IF ((h8b .lt. h5b) .and. (p4b .lt. p3b)) THEN
3520      if(.not.intorb) then
3521      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
3522     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
3523     &+nvab) * (h8b_2 - 1)))))
3524      else
3525      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3526     &(p3b_2
3527     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
3528     &+nvab) * (h8b_2 - 1)))),p3b_2,p4b_2,h5b_2,h8b_2)
3529      end if
3530      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
3531     &,int_mb(k_range+h5b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
3532     &,4,1,2,3,1.0d0)
3533      END IF
3534      IF ((h8b .lt. h5b) .and. (p3b .le. p4b)) THEN
3535      if(.not.intorb) then
3536      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
3537     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
3538     &+nvab) * (h8b_2 - 1)))))
3539      else
3540      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3541     &(p4b_2
3542     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
3543     &+nvab) * (h8b_2 - 1)))),p4b_2,p3b_2,h5b_2,h8b_2)
3544      end if
3545      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
3546     &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1)
3547     &,3,1,2,4,-1.0d0)
3548      END IF
3549      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_1_2',6,MA_ERR)
3550      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
3551     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
3552     &t),dima_sort)
3553      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_1_2',7,MA_
3554     &ERR)
3555      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_1_2',8,MA_
3556     &ERR)
3557      END IF
3558      END IF
3559      END IF
3560      END DO
3561      END DO
3562      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3563     &cc2_x1_7_1_2',9,MA_ERR)
3564      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
3565     &,int_mb(k_range+h8b-1),2,1,-1.0d0)
3566      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
3567     & noab - 1 + nvab * (h8b - 1)))
3568      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_1_2',10,MA_ERR)
3569      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_1_2',11,MA
3570     &_ERR)
3571      END IF
3572      END IF
3573      END IF
3574      next = NXTASK(nprocs,1)
3575      END IF
3576      count = count + 1
3577      END DO
3578      END DO
3579      next = NXTASK(-nprocs,1)
3580      call GA_SYNC()
3581      RETURN
3582      END
3583      SUBROUTINE cc2_x1_7_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
3584     &)
3585C     $Id$
3586C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3587C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3588C     i1 ( h8 h1 )_vx + = -1 * Sum ( h4 p5 ) * x ( p5 h4 )_x * v ( h4 h8 h1 p5 )_v
3589      IMPLICIT NONE
3590#include "global.fh"
3591#include "mafdecls.fh"
3592#include "sym.fh"
3593#include "errquit.fh"
3594#include "tce.fh"
3595      INTEGER d_a
3596      INTEGER k_a_offset
3597      INTEGER d_b
3598      INTEGER k_b_offset
3599      INTEGER d_c
3600      INTEGER k_c_offset
3601      INTEGER NXTASK
3602      INTEGER next
3603      INTEGER nprocs
3604      INTEGER count
3605      INTEGER h8b
3606      INTEGER h1b
3607      INTEGER dimc
3608      INTEGER l_c_sort
3609      INTEGER k_c_sort
3610      INTEGER p5b
3611      INTEGER h4b
3612      INTEGER p5b_1
3613      INTEGER h4b_1
3614      INTEGER h8b_2
3615      INTEGER h4b_2
3616      INTEGER h1b_2
3617      INTEGER p5b_2
3618      INTEGER dim_common
3619      INTEGER dima_sort
3620      INTEGER dima
3621      INTEGER dimb_sort
3622      INTEGER dimb
3623      INTEGER l_a_sort
3624      INTEGER k_a_sort
3625      INTEGER l_a
3626      INTEGER k_a
3627      INTEGER l_b_sort
3628      INTEGER k_b_sort
3629      INTEGER l_b
3630      INTEGER k_b
3631      INTEGER l_c
3632      INTEGER k_c
3633      EXTERNAL NXTASK
3634      nprocs = GA_NNODES()
3635      count = 0
3636      next = NXTASK(nprocs,1)
3637      DO h8b = 1,noab
3638      DO h1b = 1,noab
3639      IF (next.eq.count) THEN
3640      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
3641     &).ne.4)) THEN
3642      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3643      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
3644     &v,irrep_x)) THEN
3645      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
3646      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3647     & ERRQUIT('cc2_x1_7_2',0,MA_ERR)
3648      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3649      DO p5b = noab+1,noab+nvab
3650      DO h4b = 1,noab
3651      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h4b-1)) THEN
3652      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h4b-1)) .eq. irrep_x) TH
3653     &EN
3654      CALL TCE_RESTRICTED_2(p5b,h4b,p5b_1,h4b_1)
3655      CALL TCE_RESTRICTED_4(h8b,h4b,h1b,p5b,h8b_2,h4b_2,h1b_2,p5b_2)
3656      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h4b-1)
3657      dima_sort = 1
3658      dima = dim_common * dima_sort
3659      dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
3660      dimb = dim_common * dimb_sort
3661      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
3662      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3663     & ERRQUIT('cc2_x1_7_2',1,MA_ERR)
3664      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3665     &cc2_x1_7_2',2,MA_ERR)
3666      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
3667     &int_mb(k_a_offset),(h4b_1
3668     & - 1 + noab * (p5b_1 - noab - 1)))
3669      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
3670     &,int_mb(k_range+h4b-1),2,1,1.0d0)
3671      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_2',3,MA_ERR)
3672      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
3673     & ERRQUIT('cc2_x1_7_2',4,MA_ERR)
3674      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
3675     &cc2_x1_7_2',5,MA_ERR)
3676      IF ((h4b .le. h8b) .and. (h1b .le. p5b)) THEN
3677      if(.not.intorb) then
3678      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
3679     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3680     &+nvab) * (h4b_2 - 1)))))
3681      else
3682      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3683     &(p5b_2
3684     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3685     &+nvab) * (h4b_2 - 1)))),p5b_2,h1b_2,h8b_2,h4b_2)
3686      end if
3687      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
3688     &,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1)
3689     &,3,2,1,4,1.0d0)
3690      END IF
3691      IF ((h8b .lt. h4b) .and. (h1b .le. p5b)) THEN
3692      if(.not.intorb) then
3693      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
3694     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
3695     &+nvab) * (h8b_2 - 1)))))
3696      else
3697      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3698     &(p5b_2
3699     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
3700     &+nvab) * (h8b_2 - 1)))),p5b_2,h1b_2,h4b_2,h8b_2)
3701      end if
3702      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
3703     &,int_mb(k_range+h4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1)
3704     &,3,1,2,4,-1.0d0)
3705      END IF
3706      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_2',6,MA_ERR)
3707      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
3708     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
3709     &t),dima_sort)
3710      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_2',7,MA_ER
3711     &R)
3712      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_2',8,MA_ER
3713     &R)
3714      END IF
3715      END IF
3716      END IF
3717      END DO
3718      END DO
3719      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3720     &cc2_x1_7_2',9,MA_ERR)
3721      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
3722     &,int_mb(k_range+h8b-1),2,1,-1.0d0)
3723      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
3724     & 1 + noab * (h8b - 1)))
3725      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_2',10,MA_ERR)
3726      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_2',11,MA_E
3727     &RR)
3728      END IF
3729      END IF
3730      END IF
3731      next = NXTASK(nprocs,1)
3732      END IF
3733      count = count + 1
3734      END DO
3735      END DO
3736      next = NXTASK(-nprocs,1)
3737      call GA_SYNC()
3738      RETURN
3739      END
3740      SUBROUTINE cc2_x1_7_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
3741     &)
3742C     $Id$
3743C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3744C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3745C     i1 ( h8 h1 )_vx + = -1/2 * Sum ( h4 p5 p6 ) * x ( p5 p6 h1 h4 )_x * v ( h4 h8 p5 p6 )_v
3746      IMPLICIT NONE
3747#include "global.fh"
3748#include "mafdecls.fh"
3749#include "sym.fh"
3750#include "errquit.fh"
3751#include "tce.fh"
3752      INTEGER d_a
3753      INTEGER k_a_offset
3754      INTEGER d_b
3755      INTEGER k_b_offset
3756      INTEGER d_c
3757      INTEGER k_c_offset
3758      INTEGER NXTASK
3759      INTEGER next
3760      INTEGER nprocs
3761      INTEGER count
3762      INTEGER h8b
3763      INTEGER h1b
3764      INTEGER dimc
3765      INTEGER l_c_sort
3766      INTEGER k_c_sort
3767      INTEGER p5b
3768      INTEGER p6b
3769      INTEGER h4b
3770      INTEGER p5b_1
3771      INTEGER p6b_1
3772      INTEGER h1b_1
3773      INTEGER h4b_1
3774      INTEGER h8b_2
3775      INTEGER h4b_2
3776      INTEGER p5b_2
3777      INTEGER p6b_2
3778      INTEGER dim_common
3779      INTEGER dima_sort
3780      INTEGER dima
3781      INTEGER dimb_sort
3782      INTEGER dimb
3783      INTEGER l_a_sort
3784      INTEGER k_a_sort
3785      INTEGER l_a
3786      INTEGER k_a
3787      INTEGER l_b_sort
3788      INTEGER k_b_sort
3789      INTEGER l_b
3790      INTEGER k_b
3791      INTEGER nsuperp(2)
3792      INTEGER isuperp
3793      INTEGER l_c
3794      INTEGER k_c
3795      DOUBLE PRECISION FACTORIAL
3796      EXTERNAL NXTASK
3797      EXTERNAL FACTORIAL
3798      nprocs = GA_NNODES()
3799      count = 0
3800      next = NXTASK(nprocs,1)
3801      DO h8b = 1,noab
3802      DO h1b = 1,noab
3803      IF (next.eq.count) THEN
3804      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
3805     &).ne.4)) THEN
3806      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3807      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
3808     &v,irrep_x)) THEN
3809      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
3810      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3811     & ERRQUIT('cc2_x1_7_3',0,MA_ERR)
3812      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3813      DO p5b = noab+1,noab+nvab
3814      DO p6b = p5b,noab+nvab
3815      DO h4b = 1,noab
3816      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h
3817     &1b-1)+int_mb(k_spin+h4b-1)) THEN
3818      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb(
3819     &k_sym+h1b-1),int_mb(k_sym+h4b-1)))) .eq. irrep_x) THEN
3820      CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h4b,p5b_1,p6b_1,h1b_1,h4b_1)
3821      CALL TCE_RESTRICTED_4(h8b,h4b,p5b,p6b,h8b_2,h4b_2,p5b_2,p6b_2)
3822      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_m
3823     &b(k_range+h4b-1)
3824      dima_sort = int_mb(k_range+h1b-1)
3825      dima = dim_common * dima_sort
3826      dimb_sort = int_mb(k_range+h8b-1)
3827      dimb = dim_common * dimb_sort
3828      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
3829      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3830     & ERRQUIT('cc2_x1_7_3',1,MA_ERR)
3831      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3832     &cc2_x1_7_3',2,MA_ERR)
3833      IF ((h4b .lt. h1b)) THEN
3834      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
3835     & - 1 + noab * (h4b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_
3836     &1 - noab - 1)))))
3837      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
3838     &,int_mb(k_range+p6b-1),int_mb(k_range+h4b-1),int_mb(k_range+h1b-1)
3839     &,4,3,2,1,-1.0d0)
3840      END IF
3841      IF ((h1b .le. h4b)) THEN
3842      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1
3843     & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_
3844     &1 - noab - 1)))))
3845      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
3846     &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h4b-1)
3847     &,3,4,2,1,1.0d0)
3848      END IF
3849      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_3',3,MA_ERR)
3850      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
3851     & ERRQUIT('cc2_x1_7_3',4,MA_ERR)
3852      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
3853     &cc2_x1_7_3',5,MA_ERR)
3854      IF ((h4b .le. h8b)) THEN
3855      if(.not.intorb) then
3856      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
3857     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3858     &+nvab) * (h4b_2 - 1)))))
3859      else
3860      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3861     &(p6b_2
3862     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3863     &+nvab) * (h4b_2 - 1)))),p6b_2,p5b_2,h8b_2,h4b_2)
3864      end if
3865      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
3866     &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1)
3867     &,2,1,4,3,1.0d0)
3868      END IF
3869      IF ((h8b .lt. h4b)) THEN
3870      if(.not.intorb) then
3871      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
3872     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
3873     &+nvab) * (h8b_2 - 1)))))
3874      else
3875      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3876     &(p6b_2
3877     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
3878     &+nvab) * (h8b_2 - 1)))),p6b_2,p5b_2,h4b_2,h8b_2)
3879      end if
3880      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
3881     &,int_mb(k_range+h4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1)
3882     &,1,2,4,3,-1.0d0)
3883      END IF
3884      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_3',6,MA_ERR)
3885      nsuperp(1) = 1
3886      nsuperp(2) = 1
3887      isuperp = 1
3888      IF (p5b .eq. p6b) THEN
3889      nsuperp(isuperp) = nsuperp(isuperp) + 1
3890      ELSE
3891      isuperp = isuperp + 1
3892      END IF
3893      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
3894     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
3895     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
3896      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_3',7,MA_ER
3897     &R)
3898      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_3',8,MA_ER
3899     &R)
3900      END IF
3901      END IF
3902      END IF
3903      END DO
3904      END DO
3905      END DO
3906      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3907     &cc2_x1_7_3',9,MA_ERR)
3908      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1)
3909     &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0)
3910      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
3911     & 1 + noab * (h8b - 1)))
3912      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_3',10,MA_ERR)
3913      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_3',11,MA_E
3914     &RR)
3915      END IF
3916      END IF
3917      END IF
3918      next = NXTASK(nprocs,1)
3919      END IF
3920      count = count + 1
3921      END DO
3922      END DO
3923      next = NXTASK(-nprocs,1)
3924      call GA_SYNC()
3925      RETURN
3926      END
3927      SUBROUTINE cc2_x1_7_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
3928     &)
3929C     $Id$
3930C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3931C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3932C     i1 ( h8 h1 )_vxt + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * i2 ( h8 p3 )_vx
3933      IMPLICIT NONE
3934#include "global.fh"
3935#include "mafdecls.fh"
3936#include "sym.fh"
3937#include "errquit.fh"
3938#include "tce.fh"
3939      INTEGER d_a
3940      INTEGER k_a_offset
3941      INTEGER d_b
3942      INTEGER k_b_offset
3943      INTEGER d_c
3944      INTEGER k_c_offset
3945      INTEGER NXTASK
3946      INTEGER next
3947      INTEGER nprocs
3948      INTEGER count
3949      INTEGER h8b
3950      INTEGER h1b
3951      INTEGER dimc
3952      INTEGER l_c_sort
3953      INTEGER k_c_sort
3954      INTEGER p3b
3955      INTEGER p3b_1
3956      INTEGER h1b_1
3957      INTEGER h8b_2
3958      INTEGER p3b_2
3959      INTEGER dim_common
3960      INTEGER dima_sort
3961      INTEGER dima
3962      INTEGER dimb_sort
3963      INTEGER dimb
3964      INTEGER l_a_sort
3965      INTEGER k_a_sort
3966      INTEGER l_a
3967      INTEGER k_a
3968      INTEGER l_b_sort
3969      INTEGER k_b_sort
3970      INTEGER l_b
3971      INTEGER k_b
3972      INTEGER l_c
3973      INTEGER k_c
3974      EXTERNAL NXTASK
3975      nprocs = GA_NNODES()
3976      count = 0
3977      next = NXTASK(nprocs,1)
3978      DO h8b = 1,noab
3979      DO h1b = 1,noab
3980      IF (next.eq.count) THEN
3981      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
3982     &).ne.4)) THEN
3983      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3984      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
3985     &v,ieor(irrep_x,irrep_t))) THEN
3986      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
3987      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3988     & ERRQUIT('cc2_x1_7_4',0,MA_ERR)
3989      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3990      DO p3b = noab+1,noab+nvab
3991      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3992      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
3993     &EN
3994      CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1)
3995      CALL TCE_RESTRICTED_2(h8b,p3b,h8b_2,p3b_2)
3996      dim_common = int_mb(k_range+p3b-1)
3997      dima_sort = int_mb(k_range+h1b-1)
3998      dima = dim_common * dima_sort
3999      dimb_sort = int_mb(k_range+h8b-1)
4000      dimb = dim_common * dimb_sort
4001      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
4002      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4003     & ERRQUIT('cc2_x1_7_4',1,MA_ERR)
4004      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4005     &cc2_x1_7_4',2,MA_ERR)
4006      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
4007     &int_mb(k_a_offset),(h1b_1
4008     & - 1 + noab * (p3b_1 - noab - 1)))
4009      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
4010     &,int_mb(k_range+h1b-1),2,1,1.0d0)
4011      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_4',3,MA_ERR)
4012      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
4013     & ERRQUIT('cc2_x1_7_4',4,MA_ERR)
4014      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
4015     &cc2_x1_7_4',5,MA_ERR)
4016      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
4017     & - noab - 1 + nvab * (h8b_2 - 1)))
4018      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
4019     &,int_mb(k_range+p3b-1),1,2,1.0d0)
4020      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_4',6,MA_ERR)
4021      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
4022     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
4023     &t),dima_sort)
4024      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_4',7,MA_ER
4025     &R)
4026      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_4',8,MA_ER
4027     &R)
4028      END IF
4029      END IF
4030      END IF
4031      END DO
4032      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4033     &cc2_x1_7_4',9,MA_ERR)
4034      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1)
4035     &,int_mb(k_range+h1b-1),1,2,1.0d0)
4036      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
4037     & 1 + noab * (h8b - 1)))
4038      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_4',10,MA_ERR)
4039      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_4',11,MA_E
4040     &RR)
4041      END IF
4042      END IF
4043      END IF
4044      next = NXTASK(nprocs,1)
4045      END IF
4046      count = count + 1
4047      END DO
4048      END DO
4049      next = NXTASK(-nprocs,1)
4050      call GA_SYNC()
4051      RETURN
4052      END
4053      SUBROUTINE cc2_x1_7_4_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offs
4054     &et)
4055C     $Id$
4056C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4057C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4058C     i2 ( h8 p3 )_vx + = -1 * Sum ( h5 p6 ) * x ( p6 h5 )_x * v ( h5 h8 p3 p6 )_v
4059      IMPLICIT NONE
4060#include "global.fh"
4061#include "mafdecls.fh"
4062#include "sym.fh"
4063#include "errquit.fh"
4064#include "tce.fh"
4065      INTEGER d_a
4066      INTEGER k_a_offset
4067      INTEGER d_b
4068      INTEGER k_b_offset
4069      INTEGER d_c
4070      INTEGER k_c_offset
4071      INTEGER NXTASK
4072      INTEGER next
4073      INTEGER nprocs
4074      INTEGER count
4075      INTEGER h8b
4076      INTEGER p3b
4077      INTEGER dimc
4078      INTEGER l_c_sort
4079      INTEGER k_c_sort
4080      INTEGER p6b
4081      INTEGER h5b
4082      INTEGER p6b_1
4083      INTEGER h5b_1
4084      INTEGER h8b_2
4085      INTEGER h5b_2
4086      INTEGER p3b_2
4087      INTEGER p6b_2
4088      INTEGER dim_common
4089      INTEGER dima_sort
4090      INTEGER dima
4091      INTEGER dimb_sort
4092      INTEGER dimb
4093      INTEGER l_a_sort
4094      INTEGER k_a_sort
4095      INTEGER l_a
4096      INTEGER k_a
4097      INTEGER l_b_sort
4098      INTEGER k_b_sort
4099      INTEGER l_b
4100      INTEGER k_b
4101      INTEGER l_c
4102      INTEGER k_c
4103      EXTERNAL NXTASK
4104      nprocs = GA_NNODES()
4105      count = 0
4106      next = NXTASK(nprocs,1)
4107      DO h8b = 1,noab
4108      DO p3b = noab+1,noab+nvab
4109      IF (next.eq.count) THEN
4110      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1
4111     &).ne.4)) THEN
4112      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN
4113      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
4114     &v,irrep_x)) THEN
4115      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1)
4116      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
4117     & ERRQUIT('cc2_x1_7_4_1',0,MA_ERR)
4118      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
4119      DO p6b = noab+1,noab+nvab
4120      DO h5b = 1,noab
4121      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h5b-1)) THEN
4122      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h5b-1)) .eq. irrep_x) TH
4123     &EN
4124      CALL TCE_RESTRICTED_2(p6b,h5b,p6b_1,h5b_1)
4125      CALL TCE_RESTRICTED_4(h8b,h5b,p3b,p6b,h8b_2,h5b_2,p3b_2,p6b_2)
4126      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h5b-1)
4127      dima_sort = 1
4128      dima = dim_common * dima_sort
4129      dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1)
4130      dimb = dim_common * dimb_sort
4131      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
4132      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4133     & ERRQUIT('cc2_x1_7_4_1',1,MA_ERR)
4134      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4135     &cc2_x1_7_4_1',2,MA_ERR)
4136      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
4137     &int_mb(k_a_offset),(h5b_1
4138     & - 1 + noab * (p6b_1 - noab - 1)))
4139      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
4140     &,int_mb(k_range+h5b-1),2,1,1.0d0)
4141      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_7_4_1',3,MA_ERR)
4142      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
4143     & ERRQUIT('cc2_x1_7_4_1',4,MA_ERR)
4144      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
4145     &cc2_x1_7_4_1',5,MA_ERR)
4146      IF ((h5b .le. h8b) .and. (p6b .lt. p3b)) THEN
4147      if(.not.intorb) then
4148      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
4149     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
4150     &+nvab) * (h5b_2 - 1)))))
4151      else
4152      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4153     &(p3b_2
4154     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
4155     &+nvab) * (h5b_2 - 1)))),p3b_2,p6b_2,h8b_2,h5b_2)
4156      end if
4157      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
4158     &,int_mb(k_range+h8b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1)
4159     &,4,2,1,3,-1.0d0)
4160      END IF
4161      IF ((h5b .le. h8b) .and. (p3b .le. p6b)) THEN
4162      if(.not.intorb) then
4163      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
4164     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
4165     &+nvab) * (h5b_2 - 1)))))
4166      else
4167      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4168     &(p6b_2
4169     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
4170     &+nvab) * (h5b_2 - 1)))),p6b_2,p3b_2,h8b_2,h5b_2)
4171      end if
4172      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
4173     &,int_mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1)
4174     &,3,2,1,4,1.0d0)
4175      END IF
4176      IF ((h8b .lt. h5b) .and. (p6b .lt. p3b)) THEN
4177      if(.not.intorb) then
4178      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
4179     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
4180     &+nvab) * (h8b_2 - 1)))))
4181      else
4182      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4183     &(p3b_2
4184     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
4185     &+nvab) * (h8b_2 - 1)))),p3b_2,p6b_2,h5b_2,h8b_2)
4186      end if
4187      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
4188     &,int_mb(k_range+h5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1)
4189     &,4,1,2,3,1.0d0)
4190      END IF
4191      IF ((h8b .lt. h5b) .and. (p3b .le. p6b)) THEN
4192      if(.not.intorb) then
4193      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
4194     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
4195     &+nvab) * (h8b_2 - 1)))))
4196      else
4197      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4198     &(p6b_2
4199     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
4200     &+nvab) * (h8b_2 - 1)))),p6b_2,p3b_2,h5b_2,h8b_2)
4201      end if
4202      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
4203     &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1)
4204     &,3,1,2,4,-1.0d0)
4205      END IF
4206      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_7_4_1',6,MA_ERR)
4207      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
4208     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
4209     &t),dima_sort)
4210      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_7_4_1',7,MA_
4211     &ERR)
4212      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_7_4_1',8,MA_
4213     &ERR)
4214      END IF
4215      END IF
4216      END IF
4217      END DO
4218      END DO
4219      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4220     &cc2_x1_7_4_1',9,MA_ERR)
4221      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
4222     &,int_mb(k_range+h8b-1),2,1,-1.0d0)
4223      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
4224     & noab - 1 + nvab * (h8b - 1)))
4225      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_7_4_1',10,MA_ERR)
4226      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_7_4_1',11,MA
4227     &_ERR)
4228      END IF
4229      END IF
4230      END IF
4231      next = NXTASK(nprocs,1)
4232      END IF
4233      count = count + 1
4234      END DO
4235      END DO
4236      next = NXTASK(-nprocs,1)
4237      call GA_SYNC()
4238      RETURN
4239      END
4240      SUBROUTINE OFFSET_cc2_x1_7_4_1(l_a_offset,k_a_offset,size)
4241C     $Id$
4242C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4243C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4244C     i2 ( h8 p3 )_vx
4245      IMPLICIT NONE
4246#include "global.fh"
4247#include "mafdecls.fh"
4248#include "sym.fh"
4249#include "errquit.fh"
4250#include "tce.fh"
4251      INTEGER l_a_offset
4252      INTEGER k_a_offset
4253      INTEGER size
4254      INTEGER length
4255      INTEGER addr
4256      INTEGER h8b
4257      INTEGER p3b
4258      length = 0
4259      DO h8b = 1,noab
4260      DO p3b = noab+1,noab+nvab
4261      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN
4262      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
4263     &v,irrep_x)) THEN
4264      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1
4265     &).ne.4)) THEN
4266      length = length + 1
4267      END IF
4268      END IF
4269      END IF
4270      END DO
4271      END DO
4272      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
4273     &set)) CALL ERRQUIT('cc2_x1_7_4_1',0,MA_ERR)
4274      int_mb(k_a_offset) = length
4275      addr = 0
4276      size = 0
4277      DO h8b = 1,noab
4278      DO p3b = noab+1,noab+nvab
4279      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p3b-1)) THEN
4280      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
4281     &v,irrep_x)) THEN
4282      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p3b-1
4283     &).ne.4)) THEN
4284      addr = addr + 1
4285      int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h8b - 1)
4286      int_mb(k_a_offset+length+addr) = size
4287      size = size + int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1)
4288      END IF
4289      END IF
4290      END IF
4291      END DO
4292      END DO
4293      RETURN
4294      END
4295      SUBROUTINE cc2_x1_8(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
4296C     $Id$
4297C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4298C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4299C     i0 ( p2 h1 )_vxt + = -1 * Sum ( p3 ) * t ( p3 h1 )_t * i1 ( p2 p3 )_vx
4300      IMPLICIT NONE
4301#include "global.fh"
4302#include "mafdecls.fh"
4303#include "sym.fh"
4304#include "errquit.fh"
4305#include "tce.fh"
4306      INTEGER d_a
4307      INTEGER k_a_offset
4308      INTEGER d_b
4309      INTEGER k_b_offset
4310      INTEGER d_c
4311      INTEGER k_c_offset
4312      INTEGER NXTASK
4313      INTEGER next
4314      INTEGER nprocs
4315      INTEGER count
4316      INTEGER p2b
4317      INTEGER h1b
4318      INTEGER dimc
4319      INTEGER l_c_sort
4320      INTEGER k_c_sort
4321      INTEGER p3b
4322      INTEGER p3b_1
4323      INTEGER h1b_1
4324      INTEGER p2b_2
4325      INTEGER p3b_2
4326      INTEGER dim_common
4327      INTEGER dima_sort
4328      INTEGER dima
4329      INTEGER dimb_sort
4330      INTEGER dimb
4331      INTEGER l_a_sort
4332      INTEGER k_a_sort
4333      INTEGER l_a
4334      INTEGER k_a
4335      INTEGER l_b_sort
4336      INTEGER k_b_sort
4337      INTEGER l_b
4338      INTEGER k_b
4339      INTEGER l_c
4340      INTEGER k_c
4341      EXTERNAL NXTASK
4342      nprocs = GA_NNODES()
4343      count = 0
4344      next = NXTASK(nprocs,1)
4345      DO p2b = noab+1,noab+nvab
4346      DO h1b = 1,noab
4347      IF (next.eq.count) THEN
4348      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
4349     &).ne.4)) THEN
4350      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
4351      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
4352     &v,ieor(irrep_x,irrep_t))) THEN
4353      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
4354      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
4355     & ERRQUIT('cc2_x1_8',0,MA_ERR)
4356      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
4357      DO p3b = noab+1,noab+nvab
4358      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
4359      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
4360     &EN
4361      CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1)
4362      CALL TCE_RESTRICTED_2(p2b,p3b,p2b_2,p3b_2)
4363      dim_common = int_mb(k_range+p3b-1)
4364      dima_sort = int_mb(k_range+h1b-1)
4365      dima = dim_common * dima_sort
4366      dimb_sort = int_mb(k_range+p2b-1)
4367      dimb = dim_common * dimb_sort
4368      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
4369      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4370     & ERRQUIT('cc2_x1_8',1,MA_ERR)
4371      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4372     &cc2_x1_8',2,MA_ERR)
4373      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
4374     &int_mb(k_a_offset),(h1b_1
4375     & - 1 + noab * (p3b_1 - noab - 1)))
4376      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
4377     &,int_mb(k_range+h1b-1),2,1,1.0d0)
4378      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_8',3,MA_ERR)
4379      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
4380     & ERRQUIT('cc2_x1_8',4,MA_ERR)
4381      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
4382     &cc2_x1_8',5,MA_ERR)
4383      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
4384     & - noab - 1 + nvab * (p2b_2 - noab - 1)))
4385      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1)
4386     &,int_mb(k_range+p3b-1),1,2,1.0d0)
4387      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_8',6,MA_ERR)
4388      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
4389     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
4390     &t),dima_sort)
4391      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_8',7,MA_ERR)
4392      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_8',8,MA_ERR)
4393      END IF
4394      END IF
4395      END IF
4396      END DO
4397      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4398     &cc2_x1_8',9,MA_ERR)
4399      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1)
4400     &,int_mb(k_range+h1b-1),1,2,-1.0d0)
4401      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
4402     & 1 + noab * (p2b - noab - 1)))
4403      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_8',10,MA_ERR)
4404      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_8',11,MA_ERR
4405     &)
4406      END IF
4407      END IF
4408      END IF
4409      next = NXTASK(nprocs,1)
4410      END IF
4411      count = count + 1
4412      END DO
4413      END DO
4414      next = NXTASK(-nprocs,1)
4415      call GA_SYNC()
4416      RETURN
4417      END
4418      SUBROUTINE cc2_x1_8_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
4419     &)
4420C     $Id$
4421C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4422C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4423C     i1 ( p2 p3 )_vx + = 1 * Sum ( h4 p5 ) * x ( p5 h4 )_x * v ( h4 p2 p3 p5 )_v
4424      IMPLICIT NONE
4425#include "global.fh"
4426#include "mafdecls.fh"
4427#include "sym.fh"
4428#include "errquit.fh"
4429#include "tce.fh"
4430      INTEGER d_a
4431      INTEGER k_a_offset
4432      INTEGER d_b
4433      INTEGER k_b_offset
4434      INTEGER d_c
4435      INTEGER k_c_offset
4436      INTEGER NXTASK
4437      INTEGER next
4438      INTEGER nprocs
4439      INTEGER count
4440      INTEGER p2b
4441      INTEGER p3b
4442      INTEGER dimc
4443      INTEGER l_c_sort
4444      INTEGER k_c_sort
4445      INTEGER p5b
4446      INTEGER h4b
4447      INTEGER p5b_1
4448      INTEGER h4b_1
4449      INTEGER p2b_2
4450      INTEGER h4b_2
4451      INTEGER p3b_2
4452      INTEGER p5b_2
4453      INTEGER dim_common
4454      INTEGER dima_sort
4455      INTEGER dima
4456      INTEGER dimb_sort
4457      INTEGER dimb
4458      INTEGER l_a_sort
4459      INTEGER k_a_sort
4460      INTEGER l_a
4461      INTEGER k_a
4462      INTEGER l_b_sort
4463      INTEGER k_b_sort
4464      INTEGER l_b
4465      INTEGER k_b
4466      INTEGER l_c
4467      INTEGER k_c
4468      EXTERNAL NXTASK
4469      nprocs = GA_NNODES()
4470      count = 0
4471      next = NXTASK(nprocs,1)
4472      DO p2b = noab+1,noab+nvab
4473      DO p3b = noab+1,noab+nvab
4474      IF (next.eq.count) THEN
4475      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1
4476     &).ne.4)) THEN
4477      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN
4478      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
4479     &v,irrep_x)) THEN
4480      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1)
4481      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
4482     & ERRQUIT('cc2_x1_8_1',0,MA_ERR)
4483      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
4484      DO p5b = noab+1,noab+nvab
4485      DO h4b = 1,noab
4486      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h4b-1)) THEN
4487      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h4b-1)) .eq. irrep_x) TH
4488     &EN
4489      CALL TCE_RESTRICTED_2(p5b,h4b,p5b_1,h4b_1)
4490      CALL TCE_RESTRICTED_4(p2b,h4b,p3b,p5b,p2b_2,h4b_2,p3b_2,p5b_2)
4491      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h4b-1)
4492      dima_sort = 1
4493      dima = dim_common * dima_sort
4494      dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1)
4495      dimb = dim_common * dimb_sort
4496      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
4497      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4498     & ERRQUIT('cc2_x1_8_1',1,MA_ERR)
4499      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4500     &cc2_x1_8_1',2,MA_ERR)
4501      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
4502     &int_mb(k_a_offset),(h4b_1
4503     & - 1 + noab * (p5b_1 - noab - 1)))
4504      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
4505     &,int_mb(k_range+h4b-1),2,1,1.0d0)
4506      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_8_1',3,MA_ERR)
4507      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
4508     & ERRQUIT('cc2_x1_8_1',4,MA_ERR)
4509      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
4510     &cc2_x1_8_1',5,MA_ERR)
4511      IF ((h4b .le. p2b) .and. (p5b .lt. p3b)) THEN
4512      if(.not.intorb) then
4513      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
4514     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
4515     &+nvab) * (h4b_2 - 1)))))
4516      else
4517      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4518     &(p3b_2
4519     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
4520     &+nvab) * (h4b_2 - 1)))),p3b_2,p5b_2,p2b_2,h4b_2)
4521      end if
4522      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
4523     &,int_mb(k_range+p2b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1)
4524     &,4,2,1,3,-1.0d0)
4525      END IF
4526      IF ((h4b .le. p2b) .and. (p3b .le. p5b)) THEN
4527      if(.not.intorb) then
4528      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
4529     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
4530     &+nvab) * (h4b_2 - 1)))))
4531      else
4532      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4533     &(p5b_2
4534     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
4535     &+nvab) * (h4b_2 - 1)))),p5b_2,p3b_2,p2b_2,h4b_2)
4536      end if
4537      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
4538     &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1)
4539     &,3,2,1,4,1.0d0)
4540      END IF
4541      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_8_1',6,MA_ERR)
4542      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
4543     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
4544     &t),dima_sort)
4545      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_8_1',7,MA_ER
4546     &R)
4547      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_8_1',8,MA_ER
4548     &R)
4549      END IF
4550      END IF
4551      END IF
4552      END DO
4553      END DO
4554      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4555     &cc2_x1_8_1',9,MA_ERR)
4556      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
4557     &,int_mb(k_range+p2b-1),2,1,1.0d0)
4558      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
4559     & noab - 1 + nvab * (p2b - noab - 1)))
4560      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_8_1',10,MA_ERR)
4561      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_8_1',11,MA_E
4562     &RR)
4563      END IF
4564      END IF
4565      END IF
4566      next = NXTASK(nprocs,1)
4567      END IF
4568      count = count + 1
4569      END DO
4570      END DO
4571      next = NXTASK(-nprocs,1)
4572      call GA_SYNC()
4573      RETURN
4574      END
4575      SUBROUTINE OFFSET_cc2_x1_8_1(l_a_offset,k_a_offset,size)
4576C     $Id$
4577C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4578C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4579C     i1 ( p2 p3 )_vx
4580      IMPLICIT NONE
4581#include "global.fh"
4582#include "mafdecls.fh"
4583#include "sym.fh"
4584#include "errquit.fh"
4585#include "tce.fh"
4586      INTEGER l_a_offset
4587      INTEGER k_a_offset
4588      INTEGER size
4589      INTEGER length
4590      INTEGER addr
4591      INTEGER p2b
4592      INTEGER p3b
4593      length = 0
4594      DO p2b = noab+1,noab+nvab
4595      DO p3b = noab+1,noab+nvab
4596      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN
4597      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
4598     &v,irrep_x)) THEN
4599      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1
4600     &).ne.4)) THEN
4601      length = length + 1
4602      END IF
4603      END IF
4604      END IF
4605      END DO
4606      END DO
4607      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
4608     &set)) CALL ERRQUIT('cc2_x1_8_1',0,MA_ERR)
4609      int_mb(k_a_offset) = length
4610      addr = 0
4611      size = 0
4612      DO p2b = noab+1,noab+nvab
4613      DO p3b = noab+1,noab+nvab
4614      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN
4615      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
4616     &v,irrep_x)) THEN
4617      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1
4618     &).ne.4)) THEN
4619      addr = addr + 1
4620      int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (p2b - noab - 1)
4621      int_mb(k_a_offset+length+addr) = size
4622      size = size + int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1)
4623      END IF
4624      END IF
4625      END IF
4626      END DO
4627      END DO
4628      RETURN
4629      END
4630      SUBROUTINE cc2_x1_9(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
4631C     $Id$
4632C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4633C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4634C     i0 ( p2 h1 )_vxt + = 1 * Sum ( h4 p3 ) * t ( p2 p3 h1 h4 )_t * i1 ( h4 p3 )_vx
4635      IMPLICIT NONE
4636#include "global.fh"
4637#include "mafdecls.fh"
4638#include "sym.fh"
4639#include "errquit.fh"
4640#include "tce.fh"
4641      INTEGER d_a
4642      INTEGER k_a_offset
4643      INTEGER d_b
4644      INTEGER k_b_offset
4645      INTEGER d_c
4646      INTEGER k_c_offset
4647      INTEGER NXTASK
4648      INTEGER next
4649      INTEGER nprocs
4650      INTEGER count
4651      INTEGER p2b
4652      INTEGER h1b
4653      INTEGER dimc
4654      INTEGER l_c_sort
4655      INTEGER k_c_sort
4656      INTEGER p3b
4657      INTEGER h4b
4658      INTEGER p2b_1
4659      INTEGER p3b_1
4660      INTEGER h1b_1
4661      INTEGER h4b_1
4662      INTEGER h4b_2
4663      INTEGER p3b_2
4664      INTEGER dim_common
4665      INTEGER dima_sort
4666      INTEGER dima
4667      INTEGER dimb_sort
4668      INTEGER dimb
4669      INTEGER l_a_sort
4670      INTEGER k_a_sort
4671      INTEGER l_a
4672      INTEGER k_a
4673      INTEGER l_b_sort
4674      INTEGER k_b_sort
4675      INTEGER l_b
4676      INTEGER k_b
4677      INTEGER l_c
4678      INTEGER k_c
4679      EXTERNAL NXTASK
4680      nprocs = GA_NNODES()
4681      count = 0
4682      next = NXTASK(nprocs,1)
4683      DO p2b = noab+1,noab+nvab
4684      DO h1b = 1,noab
4685      IF (next.eq.count) THEN
4686      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
4687     &).ne.4)) THEN
4688      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
4689      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
4690     &v,ieor(irrep_x,irrep_t))) THEN
4691      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
4692      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
4693     & ERRQUIT('cc2_x1_9',0,MA_ERR)
4694      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
4695      DO p3b = noab+1,noab+nvab
4696      DO h4b = 1,noab
4697      IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
4698     &1b-1)+int_mb(k_spin+h4b-1)) THEN
4699      IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
4700     &k_sym+h1b-1),int_mb(k_sym+h4b-1)))) .eq. irrep_t) THEN
4701      CALL TCE_RESTRICTED_4(p2b,p3b,h1b,h4b,p2b_1,p3b_1,h1b_1,h4b_1)
4702      CALL TCE_RESTRICTED_2(h4b,p3b,h4b_2,p3b_2)
4703      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1)
4704      dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
4705      dima = dim_common * dima_sort
4706      dimb_sort = 1
4707      dimb = dim_common * dimb_sort
4708      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
4709      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4710     & ERRQUIT('cc2_x1_9',1,MA_ERR)
4711      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4712     &cc2_x1_9',2,MA_ERR)
4713      IF ((p3b .lt. p2b) .and. (h4b .lt. h1b)) THEN
4714      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
4715     & - 1 + noab * (h4b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p3b_
4716     &1 - noab - 1)))))
4717      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
4718     &,int_mb(k_range+p2b-1),int_mb(k_range+h4b-1),int_mb(k_range+h1b-1)
4719     &,4,2,3,1,1.0d0)
4720      END IF
4721      IF ((p3b .lt. p2b) .and. (h1b .le. h4b)) THEN
4722      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1
4723     & - 1 + noab * (h1b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p3b_
4724     &1 - noab - 1)))))
4725      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
4726     &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+h4b-1)
4727     &,3,2,4,1,-1.0d0)
4728      END IF
4729      IF ((p2b .le. p3b) .and. (h4b .lt. h1b)) THEN
4730      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
4731     & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p2b_
4732     &1 - noab - 1)))))
4733      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
4734     &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h1b-1)
4735     &,4,1,3,2,-1.0d0)
4736      END IF
4737      IF ((p2b .le. p3b) .and. (h1b .le. h4b)) THEN
4738      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1
4739     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p2b_
4740     &1 - noab - 1)))))
4741      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
4742     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h4b-1)
4743     &,3,1,4,2,1.0d0)
4744      END IF
4745      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_9',3,MA_ERR)
4746      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
4747     & ERRQUIT('cc2_x1_9',4,MA_ERR)
4748      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
4749     &cc2_x1_9',5,MA_ERR)
4750      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
4751     & - noab - 1 + nvab * (h4b_2 - 1)))
4752      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
4753     &,int_mb(k_range+p3b-1),1,2,1.0d0)
4754      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_9',6,MA_ERR)
4755      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
4756     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
4757     &t),dima_sort)
4758      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_9',7,MA_ERR)
4759      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_9',8,MA_ERR)
4760      END IF
4761      END IF
4762      END IF
4763      END DO
4764      END DO
4765      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4766     &cc2_x1_9',9,MA_ERR)
4767      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
4768     &,int_mb(k_range+p2b-1),2,1,1.0d0)
4769      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
4770     & 1 + noab * (p2b - noab - 1)))
4771      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_9',10,MA_ERR)
4772      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_9',11,MA_ERR
4773     &)
4774      END IF
4775      END IF
4776      END IF
4777      next = NXTASK(nprocs,1)
4778      END IF
4779      count = count + 1
4780      END DO
4781      END DO
4782      next = NXTASK(-nprocs,1)
4783      call GA_SYNC()
4784      RETURN
4785      END
4786      SUBROUTINE cc2_x1_9_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
4787     &)
4788C     $Id$
4789C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4790C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4791C     i1 ( h4 p3 )_vx + = 1 * Sum ( h5 p6 ) * x ( p6 h5 )_x * v ( h4 h5 p3 p6 )_v
4792      IMPLICIT NONE
4793#include "global.fh"
4794#include "mafdecls.fh"
4795#include "sym.fh"
4796#include "errquit.fh"
4797#include "tce.fh"
4798      INTEGER d_a
4799      INTEGER k_a_offset
4800      INTEGER d_b
4801      INTEGER k_b_offset
4802      INTEGER d_c
4803      INTEGER k_c_offset
4804      INTEGER NXTASK
4805      INTEGER next
4806      INTEGER nprocs
4807      INTEGER count
4808      INTEGER h4b
4809      INTEGER p3b
4810      INTEGER dimc
4811      INTEGER l_c_sort
4812      INTEGER k_c_sort
4813      INTEGER p6b
4814      INTEGER h5b
4815      INTEGER p6b_1
4816      INTEGER h5b_1
4817      INTEGER h4b_2
4818      INTEGER h5b_2
4819      INTEGER p3b_2
4820      INTEGER p6b_2
4821      INTEGER dim_common
4822      INTEGER dima_sort
4823      INTEGER dima
4824      INTEGER dimb_sort
4825      INTEGER dimb
4826      INTEGER l_a_sort
4827      INTEGER k_a_sort
4828      INTEGER l_a
4829      INTEGER k_a
4830      INTEGER l_b_sort
4831      INTEGER k_b_sort
4832      INTEGER l_b
4833      INTEGER k_b
4834      INTEGER l_c
4835      INTEGER k_c
4836      EXTERNAL NXTASK
4837      nprocs = GA_NNODES()
4838      count = 0
4839      next = NXTASK(nprocs,1)
4840      DO h4b = 1,noab
4841      DO p3b = noab+1,noab+nvab
4842      IF (next.eq.count) THEN
4843      IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1
4844     &).ne.4)) THEN
4845      IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p3b-1)) THEN
4846      IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
4847     &v,irrep_x)) THEN
4848      dimc = int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1)
4849      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
4850     & ERRQUIT('cc2_x1_9_1',0,MA_ERR)
4851      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
4852      DO p6b = noab+1,noab+nvab
4853      DO h5b = 1,noab
4854      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h5b-1)) THEN
4855      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h5b-1)) .eq. irrep_x) TH
4856     &EN
4857      CALL TCE_RESTRICTED_2(p6b,h5b,p6b_1,h5b_1)
4858      CALL TCE_RESTRICTED_4(h4b,h5b,p3b,p6b,h4b_2,h5b_2,p3b_2,p6b_2)
4859      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h5b-1)
4860      dima_sort = 1
4861      dima = dim_common * dima_sort
4862      dimb_sort = int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1)
4863      dimb = dim_common * dimb_sort
4864      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
4865      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4866     & ERRQUIT('cc2_x1_9_1',1,MA_ERR)
4867      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4868     &cc2_x1_9_1',2,MA_ERR)
4869      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
4870     &int_mb(k_a_offset),(h5b_1
4871     & - 1 + noab * (p6b_1 - noab - 1)))
4872      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
4873     &,int_mb(k_range+h5b-1),2,1,1.0d0)
4874      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_9_1',3,MA_ERR)
4875      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
4876     & ERRQUIT('cc2_x1_9_1',4,MA_ERR)
4877      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
4878     &cc2_x1_9_1',5,MA_ERR)
4879      IF ((h5b .lt. h4b) .and. (p6b .lt. p3b)) THEN
4880      if(.not.intorb) then
4881      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
4882     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
4883     &+nvab) * (h5b_2 - 1)))))
4884      else
4885      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4886     &(p3b_2
4887     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
4888     &+nvab) * (h5b_2 - 1)))),p3b_2,p6b_2,h4b_2,h5b_2)
4889      end if
4890      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
4891     &,int_mb(k_range+h4b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1)
4892     &,4,2,1,3,1.0d0)
4893      END IF
4894      IF ((h5b .lt. h4b) .and. (p3b .le. p6b)) THEN
4895      if(.not.intorb) then
4896      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
4897     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
4898     &+nvab) * (h5b_2 - 1)))))
4899      else
4900      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4901     &(p6b_2
4902     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
4903     &+nvab) * (h5b_2 - 1)))),p6b_2,p3b_2,h4b_2,h5b_2)
4904      end if
4905      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
4906     &,int_mb(k_range+h4b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1)
4907     &,3,2,1,4,-1.0d0)
4908      END IF
4909      IF ((h4b .le. h5b) .and. (p6b .lt. p3b)) THEN
4910      if(.not.intorb) then
4911      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
4912     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
4913     &+nvab) * (h4b_2 - 1)))))
4914      else
4915      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4916     &(p3b_2
4917     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
4918     &+nvab) * (h4b_2 - 1)))),p3b_2,p6b_2,h5b_2,h4b_2)
4919      end if
4920      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
4921     &,int_mb(k_range+h5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1)
4922     &,4,1,2,3,-1.0d0)
4923      END IF
4924      IF ((h4b .le. h5b) .and. (p3b .le. p6b)) THEN
4925      if(.not.intorb) then
4926      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
4927     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
4928     &+nvab) * (h4b_2 - 1)))))
4929      else
4930      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4931     &(p6b_2
4932     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
4933     &+nvab) * (h4b_2 - 1)))),p6b_2,p3b_2,h5b_2,h4b_2)
4934      end if
4935      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
4936     &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1)
4937     &,3,1,2,4,1.0d0)
4938      END IF
4939      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_9_1',6,MA_ERR)
4940      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
4941     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
4942     &t),dima_sort)
4943      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_9_1',7,MA_ER
4944     &R)
4945      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_9_1',8,MA_ER
4946     &R)
4947      END IF
4948      END IF
4949      END IF
4950      END DO
4951      END DO
4952      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4953     &cc2_x1_9_1',9,MA_ERR)
4954      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
4955     &,int_mb(k_range+h4b-1),2,1,1.0d0)
4956      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
4957     & noab - 1 + nvab * (h4b - 1)))
4958      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_9_1',10,MA_ERR)
4959      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_9_1',11,MA_E
4960     &RR)
4961      END IF
4962      END IF
4963      END IF
4964      next = NXTASK(nprocs,1)
4965      END IF
4966      count = count + 1
4967      END DO
4968      END DO
4969      next = NXTASK(-nprocs,1)
4970      call GA_SYNC()
4971      RETURN
4972      END
4973      SUBROUTINE OFFSET_cc2_x1_9_1(l_a_offset,k_a_offset,size)
4974C     $Id$
4975C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4976C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4977C     i1 ( h4 p3 )_vx
4978      IMPLICIT NONE
4979#include "global.fh"
4980#include "mafdecls.fh"
4981#include "sym.fh"
4982#include "errquit.fh"
4983#include "tce.fh"
4984      INTEGER l_a_offset
4985      INTEGER k_a_offset
4986      INTEGER size
4987      INTEGER length
4988      INTEGER addr
4989      INTEGER h4b
4990      INTEGER p3b
4991      length = 0
4992      DO h4b = 1,noab
4993      DO p3b = noab+1,noab+nvab
4994      IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p3b-1)) THEN
4995      IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
4996     &v,irrep_x)) THEN
4997      IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1
4998     &).ne.4)) THEN
4999      length = length + 1
5000      END IF
5001      END IF
5002      END IF
5003      END DO
5004      END DO
5005      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
5006     &set)) CALL ERRQUIT('cc2_x1_9_1',0,MA_ERR)
5007      int_mb(k_a_offset) = length
5008      addr = 0
5009      size = 0
5010      DO h4b = 1,noab
5011      DO p3b = noab+1,noab+nvab
5012      IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p3b-1)) THEN
5013      IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
5014     &v,irrep_x)) THEN
5015      IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1
5016     &).ne.4)) THEN
5017      addr = addr + 1
5018      int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h4b - 1)
5019      int_mb(k_a_offset+length+addr) = size
5020      size = size + int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1)
5021      END IF
5022      END IF
5023      END IF
5024      END DO
5025      END DO
5026      RETURN
5027      END
5028      SUBROUTINE cc2_x1_10(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
5029C     $Id$
5030C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5031C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5032C     i0 ( p2 h1 )_vxt + = 1/2 * Sum ( h4 h5 p3 ) * t ( p2 p3 h4 h5 )_t * i1 ( h4 h5 h1 p3 )_vx
5033      IMPLICIT NONE
5034#include "global.fh"
5035#include "mafdecls.fh"
5036#include "sym.fh"
5037#include "errquit.fh"
5038#include "tce.fh"
5039      INTEGER d_a
5040      INTEGER k_a_offset
5041      INTEGER d_b
5042      INTEGER k_b_offset
5043      INTEGER d_c
5044      INTEGER k_c_offset
5045      INTEGER NXTASK
5046      INTEGER next
5047      INTEGER nprocs
5048      INTEGER count
5049      INTEGER p2b
5050      INTEGER h1b
5051      INTEGER dimc
5052      INTEGER l_c_sort
5053      INTEGER k_c_sort
5054      INTEGER p3b
5055      INTEGER h4b
5056      INTEGER h5b
5057      INTEGER p2b_1
5058      INTEGER p3b_1
5059      INTEGER h4b_1
5060      INTEGER h5b_1
5061      INTEGER h4b_2
5062      INTEGER h5b_2
5063      INTEGER h1b_2
5064      INTEGER p3b_2
5065      INTEGER dim_common
5066      INTEGER dima_sort
5067      INTEGER dima
5068      INTEGER dimb_sort
5069      INTEGER dimb
5070      INTEGER l_a_sort
5071      INTEGER k_a_sort
5072      INTEGER l_a
5073      INTEGER k_a
5074      INTEGER l_b_sort
5075      INTEGER k_b_sort
5076      INTEGER l_b
5077      INTEGER k_b
5078      INTEGER nsubh(2)
5079      INTEGER isubh
5080      INTEGER l_c
5081      INTEGER k_c
5082      DOUBLE PRECISION FACTORIAL
5083      EXTERNAL NXTASK
5084      EXTERNAL FACTORIAL
5085      nprocs = GA_NNODES()
5086      count = 0
5087      next = NXTASK(nprocs,1)
5088      DO p2b = noab+1,noab+nvab
5089      DO h1b = 1,noab
5090      IF (next.eq.count) THEN
5091      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
5092     &).ne.4)) THEN
5093      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
5094      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
5095     &v,ieor(irrep_x,irrep_t))) THEN
5096      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
5097      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
5098     & ERRQUIT('cc2_x1_10',0,MA_ERR)
5099      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
5100      DO p3b = noab+1,noab+nvab
5101      DO h4b = 1,noab
5102      DO h5b = h4b,noab
5103      IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
5104     &4b-1)+int_mb(k_spin+h5b-1)) THEN
5105      IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
5106     &k_sym+h4b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN
5107      CALL TCE_RESTRICTED_4(p2b,p3b,h4b,h5b,p2b_1,p3b_1,h4b_1,h5b_1)
5108      CALL TCE_RESTRICTED_4(h4b,h5b,h1b,p3b,h4b_2,h5b_2,h1b_2,p3b_2)
5109      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) * int_m
5110     &b(k_range+h5b-1)
5111      dima_sort = int_mb(k_range+p2b-1)
5112      dima = dim_common * dima_sort
5113      dimb_sort = int_mb(k_range+h1b-1)
5114      dimb = dim_common * dimb_sort
5115      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
5116      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
5117     & ERRQUIT('cc2_x1_10',1,MA_ERR)
5118      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
5119     &cc2_x1_10',2,MA_ERR)
5120      IF ((p3b .lt. p2b)) THEN
5121      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1
5122     & - 1 + noab * (h4b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p3b_
5123     &1 - noab - 1)))))
5124      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
5125     &,int_mb(k_range+p2b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1)
5126     &,2,4,3,1,-1.0d0)
5127      END IF
5128      IF ((p2b .le. p3b)) THEN
5129      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1
5130     & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p2b_
5131     &1 - noab - 1)))))
5132      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
5133     &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1)
5134     &,1,4,3,2,1.0d0)
5135      END IF
5136      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_10',3,MA_ERR)
5137      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
5138     & ERRQUIT('cc2_x1_10',4,MA_ERR)
5139      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
5140     &cc2_x1_10',5,MA_ERR)
5141      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
5142     & - noab - 1 + nvab * (h1b_2 - 1 + noab * (h5b_2 - 1 + noab * (h4b_
5143     &2 - 1)))))
5144      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
5145     &,int_mb(k_range+h5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
5146     &,3,2,1,4,1.0d0)
5147      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_10',6,MA_ERR)
5148      nsubh(1) = 1
5149      nsubh(2) = 1
5150      isubh = 1
5151      IF (h4b .eq. h5b) THEN
5152      nsubh(isubh) = nsubh(isubh) + 1
5153      ELSE
5154      isubh = isubh + 1
5155      END IF
5156      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
5157     &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k
5158     &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
5159      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_10',7,MA_ERR
5160     &)
5161      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_10',8,MA_ERR
5162     &)
5163      END IF
5164      END IF
5165      END IF
5166      END DO
5167      END DO
5168      END DO
5169      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
5170     &cc2_x1_10',9,MA_ERR)
5171      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
5172     &,int_mb(k_range+p2b-1),2,1,1.0d0/2.0d0)
5173      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
5174     & 1 + noab * (p2b - noab - 1)))
5175      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_10',10,MA_ERR)
5176      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_10',11,MA_ER
5177     &R)
5178      END IF
5179      END IF
5180      END IF
5181      next = NXTASK(nprocs,1)
5182      END IF
5183      count = count + 1
5184      END DO
5185      END DO
5186      next = NXTASK(-nprocs,1)
5187      call GA_SYNC()
5188      RETURN
5189      END
5190      SUBROUTINE cc2_x1_10_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
5191     &t)
5192C     $Id$
5193C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5194C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5195C     i1 ( h4 h5 h1 p3 )_vx + = 1 * Sum ( p6 ) * x ( p6 h1 )_x * v ( h4 h5 p3 p6 )_v
5196      IMPLICIT NONE
5197#include "global.fh"
5198#include "mafdecls.fh"
5199#include "sym.fh"
5200#include "errquit.fh"
5201#include "tce.fh"
5202      INTEGER d_a
5203      INTEGER k_a_offset
5204      INTEGER d_b
5205      INTEGER k_b_offset
5206      INTEGER d_c
5207      INTEGER k_c_offset
5208      INTEGER NXTASK
5209      INTEGER next
5210      INTEGER nprocs
5211      INTEGER count
5212      INTEGER h4b
5213      INTEGER h5b
5214      INTEGER h1b
5215      INTEGER p3b
5216      INTEGER dimc
5217      INTEGER l_c_sort
5218      INTEGER k_c_sort
5219      INTEGER p6b
5220      INTEGER p6b_1
5221      INTEGER h1b_1
5222      INTEGER h4b_2
5223      INTEGER h5b_2
5224      INTEGER p3b_2
5225      INTEGER p6b_2
5226      INTEGER dim_common
5227      INTEGER dima_sort
5228      INTEGER dima
5229      INTEGER dimb_sort
5230      INTEGER dimb
5231      INTEGER l_a_sort
5232      INTEGER k_a_sort
5233      INTEGER l_a
5234      INTEGER k_a
5235      INTEGER l_b_sort
5236      INTEGER k_b_sort
5237      INTEGER l_b
5238      INTEGER k_b
5239      INTEGER l_c
5240      INTEGER k_c
5241      EXTERNAL NXTASK
5242      nprocs = GA_NNODES()
5243      count = 0
5244      next = NXTASK(nprocs,1)
5245      DO h4b = 1,noab
5246      DO h5b = h4b,noab
5247      DO h1b = 1,noab
5248      DO p3b = noab+1,noab+nvab
5249      IF (next.eq.count) THEN
5250      IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1
5251     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN
5252      IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h
5253     &1b-1)+int_mb(k_spin+p3b-1)) THEN
5254      IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb(
5255     &k_sym+h1b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
5256     &EN
5257      dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra
5258     &nge+h1b-1) * int_mb(k_range+p3b-1)
5259      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
5260     & ERRQUIT('cc2_x1_10_1',0,MA_ERR)
5261      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
5262      DO p6b = noab+1,noab+nvab
5263      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
5264      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH
5265     &EN
5266      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
5267      CALL TCE_RESTRICTED_4(h4b,h5b,p3b,p6b,h4b_2,h5b_2,p3b_2,p6b_2)
5268      dim_common = int_mb(k_range+p6b-1)
5269      dima_sort = int_mb(k_range+h1b-1)
5270      dima = dim_common * dima_sort
5271      dimb_sort = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb
5272     &(k_range+p3b-1)
5273      dimb = dim_common * dimb_sort
5274      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
5275      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
5276     & ERRQUIT('cc2_x1_10_1',1,MA_ERR)
5277      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
5278     &cc2_x1_10_1',2,MA_ERR)
5279      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
5280     &int_mb(k_a_offset),(h1b_1
5281     & - 1 + noab * (p6b_1 - noab - 1)))
5282      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
5283     &,int_mb(k_range+h1b-1),2,1,1.0d0)
5284      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cc2_x1_10_1',3,MA_ERR)
5285      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
5286     & ERRQUIT('cc2_x1_10_1',4,MA_ERR)
5287      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
5288     &cc2_x1_10_1',5,MA_ERR)
5289      IF ((p6b .lt. p3b)) THEN
5290      if(.not.intorb) then
5291      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
5292     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
5293     &+nvab) * (h4b_2 - 1)))))
5294      else
5295      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
5296     &(p3b_2
5297     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
5298     &+nvab) * (h4b_2 - 1)))),p3b_2,p6b_2,h5b_2,h4b_2)
5299      end if
5300      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
5301     &,int_mb(k_range+h5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1)
5302     &,4,2,1,3,-1.0d0)
5303      END IF
5304      IF ((p3b .le. p6b)) THEN
5305      if(.not.intorb) then
5306      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
5307     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
5308     &+nvab) * (h4b_2 - 1)))))
5309      else
5310      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
5311     &(p6b_2
5312     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
5313     &+nvab) * (h4b_2 - 1)))),p6b_2,p3b_2,h5b_2,h4b_2)
5314      end if
5315      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
5316     &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1)
5317     &,3,2,1,4,1.0d0)
5318      END IF
5319      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cc2_x1_10_1',6,MA_ERR)
5320      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
5321     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
5322     &t),dima_sort)
5323      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cc2_x1_10_1',7,MA_E
5324     &RR)
5325      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cc2_x1_10_1',8,MA_E
5326     &RR)
5327      END IF
5328      END IF
5329      END IF
5330      END DO
5331      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
5332     &cc2_x1_10_1',9,MA_ERR)
5333      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
5334     &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),int_mb(k_range+h1b-1)
5335     &,3,2,4,1,1.0d0)
5336      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
5337     & noab - 1 + nvab * (h1b - 1 + noab * (h5b - 1 + noab * (h4b - 1)))
5338     &))
5339      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cc2_x1_10_1',10,MA_ERR)
5340      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cc2_x1_10_1',11,MA_
5341     &ERR)
5342      END IF
5343      END IF
5344      END IF
5345      next = NXTASK(nprocs,1)
5346      END IF
5347      count = count + 1
5348      END DO
5349      END DO
5350      END DO
5351      END DO
5352      next = NXTASK(-nprocs,1)
5353      call GA_SYNC()
5354      RETURN
5355      END
5356      SUBROUTINE OFFSET_cc2_x1_10_1(l_a_offset,k_a_offset,size)
5357C     $Id$
5358C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5359C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5360C     i1 ( h4 h5 h1 p3 )_vx
5361      IMPLICIT NONE
5362#include "global.fh"
5363#include "mafdecls.fh"
5364#include "sym.fh"
5365#include "errquit.fh"
5366#include "tce.fh"
5367      INTEGER l_a_offset
5368      INTEGER k_a_offset
5369      INTEGER size
5370      INTEGER length
5371      INTEGER addr
5372      INTEGER h4b
5373      INTEGER h5b
5374      INTEGER h1b
5375      INTEGER p3b
5376      length = 0
5377      DO h4b = 1,noab
5378      DO h5b = h4b,noab
5379      DO h1b = 1,noab
5380      DO p3b = noab+1,noab+nvab
5381      IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h
5382     &1b-1)+int_mb(k_spin+p3b-1)) THEN
5383      IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb(
5384     &k_sym+h1b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
5385     &EN
5386      IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1
5387     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN
5388      length = length + 1
5389      END IF
5390      END IF
5391      END IF
5392      END DO
5393      END DO
5394      END DO
5395      END DO
5396      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
5397     &set)) CALL ERRQUIT('cc2_x1_10_1',0,MA_ERR)
5398      int_mb(k_a_offset) = length
5399      addr = 0
5400      size = 0
5401      DO h4b = 1,noab
5402      DO h5b = h4b,noab
5403      DO h1b = 1,noab
5404      DO p3b = noab+1,noab+nvab
5405      IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h
5406     &1b-1)+int_mb(k_spin+p3b-1)) THEN
5407      IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb(
5408     &k_sym+h1b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
5409     &EN
5410      IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1
5411     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN
5412      addr = addr + 1
5413      int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h1b - 1 + noab
5414     &* (h5b - 1 + noab * (h4b - 1)))
5415      int_mb(k_a_offset+length+addr) = size
5416      size = size + int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_
5417     &mb(k_range+h1b-1) * int_mb(k_range+p3b-1)
5418      END IF
5419      END IF
5420      END IF
5421      END DO
5422      END DO
5423      END DO
5424      END DO
5425      RETURN
5426      END
5427