1ckbn Kiran Bhaskaran-Nair EOM-IPCCSD X2 equations
2      SUBROUTINE ipccsd_x2(d_f1,d_i0,d_t1,d_t2,d_v2,d_x1,d_x2,k_f1_offse
3     &t,k_i0_offset,k_t1_offset,k_t2_offset,k_v2_offset,k_x1_offset,k_x2
4     &_offset)
5C     $Id$
6C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
7C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
8ckbn p3
9C     i0 ( p3 p4 h1 h2 )_xv + = -1 * P( 2 ) * Sum ( h9 ) * x ( p3 h9 )_x * i1 ( h9 p4 h1 h2 )_v
10C         i1 ( h9 p3 h1 h2 )_v + = 1 * v ( h9 p3 h1 h2 )_v
11C         i1 ( h9 p3 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h9 p3 h2 p5 )_v
12C             i2 ( h9 p3 h1 p5 )_v + = 1 * v ( h9 p3 h1 p5 )_v
13C             i2 ( h9 p3 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 p3 p5 p6 )_v
14C         i1 ( h9 p3 h1 h2 )_ft + = -1 * Sum ( p8 ) * t ( p3 p8 h1 h2 )_t * i2 ( h9 p8 )_f
15C             i2 ( h9 p8 )_f + = 1 * f ( h9 p8 )_f
16C             i2 ( h9 p8 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 p6 p8 )_v
17C         i1 ( h9 p3 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i2 ( h6 h9 h2 p5 )_v
18C             i2 ( h6 h9 h1 p5 )_v + = 1 * v ( h6 h9 h1 p5 )_v
19C             i2 ( h6 h9 h1 p5 )_vt + = -1 * Sum ( p7 ) * t ( p7 h1 )_t * v ( h6 h9 p5 p7 )_v
20C         i1 ( h9 p3 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 p3 p5 p6 )_v
21ckbn p4
22C     i0 ( p3 p4 h1 h2 )_xf + = -1 * P( 2 ) * Sum ( h8 ) * x ( p3 p4 h1 h8 )_x * i1 ( h8 h2 )_f
23C         i1 ( h8 h1 )_f + = 1 * f ( h8 h1 )_f
24C         i1 ( h8 h1 )_ft + = 1 * Sum ( p9 ) * t ( p9 h1 )_t * i2 ( h8 p9 )_f
25C             i2 ( h8 p9 )_f + = 1 * f ( h8 p9 )_f
26C             i2 ( h8 p9 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h8 p6 p9 )_v
27C         i1 ( h8 h1 )_vt + = -1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 h8 h1 p5 )_v
28C         i1 ( h8 h1 )_vt + = -1/2 * Sum ( h7 p5 p6 ) * t ( p5 p6 h1 h7 )_t * v ( h7 h8 p5 p6 )_v
29ckbn p3
30C     i0 ( p3 p4 h1 h2 )_xf + = 1 * P( 2 ) * Sum ( p8 ) * x ( p3 p8 h1 h2 )_x * i1 ( p4 p8 )_f
31C         i1 ( p3 p8 )_f + = 1 * f ( p3 p8 )_f
32C         i1 ( p3 p8 )_vt + = 1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 p3 p5 p8 )_v
33C         i1 ( p3 p8 )_vt + = 1/2 * Sum ( h6 h7 p5 ) * t ( p3 p5 h6 h7 )_t * v ( h6 h7 p5 p8 )_v
34ckbn p4
35C     i0 ( p3 p4 h1 h2 )_xv + = 1/2 * Sum ( h9 h10 ) * x ( p3 p4 h9 h10 )_x * i1 ( h9 h10 h1 h2 )_v
36C         i1 ( h9 h10 h1 h2 )_v + = 1 * v ( h9 h10 h1 h2 )_v
37C         i1 ( h9 h10 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h9 h10 h2 p5 )_v
38C             i2 ( h9 h10 h1 p5 )_v + = 1 * v ( h9 h10 h1 p5 )_v
39C             i2 ( h9 h10 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 h10 p5 p6 )_v
40C         i1 ( h9 h10 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 h10 p5 p6 )_v
41ckbn p3
42C     i0 ( p3 p4 h1 h2 )_xv + = -1 * P( 4 ) * Sum ( p8 h7 ) * x ( p3 p8 h1 h7 )_x * i1 ( h7 p4 h2 p8 )_v
43C         i1 ( h7 p3 h1 p8 )_v + = 1 * v ( h7 p3 h1 p8 )_v
44C         i1 ( h7 p3 h1 p8 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h7 p3 p5 p8 )_v
45ckbn p4
46C     i0 ( p3 p4 h1 h2 )_vxt + = 1 * P( 2 ) * Sum ( h10 ) * t ( p3 h10 )_t * i1 ( h10 p4 h1 h2 )_vx
47ckbn p3
48C         i1 ( h10 p3 h1 h2 )_vx + = -1 * Sum ( h8 ) * x ( p3 h8 )_x * i2 ( h8 h10 h1 h2 )_v
49C             i2 ( h8 h10 h1 h2 )_v + = 1 * v ( h8 h10 h1 h2 )_v
50C             i2 ( h8 h10 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i3 ( h8 h10 h2 p5 )_v
51C                 i3 ( h8 h10 h1 p5 )_v + = 1 * v ( h8 h10 h1 p5 )_v
52C                 i3 ( h8 h10 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h8 h10 p5 p6 )_v
53C             i2 ( h8 h10 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h8 h10 p5 p6 )_v
54ckbn p3
55C         i1 ( h10 p3 h1 h2 )_fx + = 1 * Sum ( p5 ) * x ( p3 p5 h1 h2 )_x * i2 ( h10 p5 )_f
56C             i2 ( h10 p5 )_f + = 1 * f ( h10 p5 )_f
57C             i2 ( h10 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h10 p5 p6 )_v
58ckbn p3
59C         i1 ( h10 p3 h1 h2 )_vx + = -1 * P( 2 ) * Sum ( h8 p9 ) * x ( p3 p9 h1 h8 )_x * i2 ( h8 h10 h2 p9 )_v
60C             i2 ( h8 h10 h1 p9 )_v + = 1 * v ( h8 h10 h1 p9 )_v
61C             i2 ( h8 h10 h1 p9 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h8 h10 p5 p9 )_v
62ckbn p4 m
63C     i0 ( p3 p4 h1 h2 )_vxt + = 1/2 * P( 2 ) * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i1 ( p4 p5 )_vx
64ckbn p3 m
65C         i1 ( p3 p5 )_vx + = -1 * Sum ( h6 h7 p8 ) * x ( p3 p8 h6 h7 )_x * v ( h6 h7 p5 p8 )_v
66ckbn p4
67C     i0 ( p3 p4 h1 h2 )_vxt + = 1 * P( 4 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i1 ( h6 p4 h2 p5 )_vx
68ckbn p3
69C         i1 ( h6 p3 h1 p5 )_vx + = 1 * Sum ( h7 p8 ) * x ( p3 p8 h1 h7 )_x * v ( h6 h7 p5 p8 )_v
70      IMPLICIT NONE
71#include "global.fh"
72#include "mafdecls.fh"
73#include "util.fh"
74#include "errquit.fh"
75#include "tce.fh"
76#include "stdio.fh"
77      INTEGER d_i0
78      INTEGER k_i0_offset
79      INTEGER d_x1
80      INTEGER k_x1_offset
81      INTEGER d_i1
82      INTEGER k_i1_offset
83      INTEGER d_x2
84      INTEGER k_x2_offset
85      INTEGER d_t1
86      INTEGER k_t1_offset
87      INTEGER d_t2
88      INTEGER k_t2_offset
89      INTEGER l_i1_offset
90      INTEGER d_v2
91      INTEGER k_v2_offset
92      INTEGER size_i1
93      INTEGER d_i2
94      INTEGER k_i2_offset
95      INTEGER l_i2_offset
96      INTEGER size_i2
97      INTEGER d_f1
98      INTEGER k_f1_offset
99      INTEGER d_i3
100      INTEGER k_i3_offset
101      INTEGER l_i3_offset
102      INTEGER size_i3
103      CHARACTER*255 filename
104      CALL OFFSET_ipccsd_x2_1_1(l_i1_offset,k_i1_offset,size_i1)
105      CALL TCE_FILENAME('ipccsd_x2_1_1_i1',filename)
106      CALL CREATEFILE(filename,d_i1,size_i1)
107      CALL ipccsd_x2_1_1(d_v2,k_v2_offset,d_i1,k_i1_offset)
108      CALL OFFSET_ipccsd_x2_1_2_1(l_i2_offset,k_i2_offset,size_i2)
109      CALL TCE_FILENAME('ipccsd_x2_1_2_1_i2',filename)
110      CALL CREATEFILE(filename,d_i2,size_i2)
111      CALL ipccsd_x2_1_2_1(d_v2,k_v2_offset,d_i2,k_i2_offset)
112      CALL ipccsd_x2_1_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o
113     &ffset)
114      CALL RECONCILEFILE(d_i2,size_i2)
115      CALL ipccsd_x2_1_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k_i1_off
116     &set)
117      CALL DELETEFILE(d_i2)
118      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
119     &_ERR)
120      CALL OFFSET_ipccsd_x2_1_3_1(l_i2_offset,k_i2_offset,size_i2)
121      CALL TCE_FILENAME('ipccsd_x2_1_3_1_i2',filename)
122      CALL CREATEFILE(filename,d_i2,size_i2)
123      CALL ipccsd_x2_1_3_1(d_f1,k_f1_offset,d_i2,k_i2_offset)
124      CALL ipccsd_x2_1_3_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o
125     &ffset)
126      CALL RECONCILEFILE(d_i2,size_i2)
127      CALL ipccsd_x2_1_3(d_t2,k_t2_offset,d_i2,k_i2_offset,d_i1,k_i1_off
128     &set)
129      CALL DELETEFILE(d_i2)
130      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
131     &_ERR)
132      CALL OFFSET_ipccsd_x2_1_4_1(l_i2_offset,k_i2_offset,size_i2)
133      CALL TCE_FILENAME('ipccsd_x2_1_4_1_i2',filename)
134      CALL CREATEFILE(filename,d_i2,size_i2)
135      CALL ipccsd_x2_1_4_1(d_v2,k_v2_offset,d_i2,k_i2_offset)
136      CALL ipccsd_x2_1_4_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o
137     &ffset)
138      CALL RECONCILEFILE(d_i2,size_i2)
139      CALL ipccsd_x2_1_4(d_t2,k_t2_offset,d_i2,k_i2_offset,d_i1,k_i1_off
140     &set)
141      CALL DELETEFILE(d_i2)
142      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
143     &_ERR)
144      CALL ipccsd_x2_1_5(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1,k_i1_off
145     &set)
146      CALL RECONCILEFILE(d_i1,size_i1)
147      CALL ipccsd_x2_1(d_x1,k_x1_offset,d_i1,k_i1_offset,d_i0,k_i0_offse
148     &t)
149      CALL DELETEFILE(d_i1)
150      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
151     &_ERR)
152      CALL OFFSET_ipccsd_x2_2_1(l_i1_offset,k_i1_offset,size_i1)
153      CALL TCE_FILENAME('ipccsd_x2_2_1_i1',filename)
154      CALL CREATEFILE(filename,d_i1,size_i1)
155      CALL ipccsd_x2_2_1(d_f1,k_f1_offset,d_i1,k_i1_offset)
156      CALL OFFSET_ipccsd_x2_2_2_1(l_i2_offset,k_i2_offset,size_i2)
157      CALL TCE_FILENAME('ipccsd_x2_2_2_1_i2',filename)
158      CALL CREATEFILE(filename,d_i2,size_i2)
159      CALL ipccsd_x2_2_2_1(d_f1,k_f1_offset,d_i2,k_i2_offset)
160      CALL ipccsd_x2_2_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o
161     &ffset)
162      CALL RECONCILEFILE(d_i2,size_i2)
163      CALL ipccsd_x2_2_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k_i1_off
164     &set)
165      CALL DELETEFILE(d_i2)
166      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
167     &_ERR)
168      CALL ipccsd_x2_2_3(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_off
169     &set)
170      CALL ipccsd_x2_2_4(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1,k_i1_off
171     &set)
172      CALL RECONCILEFILE(d_i1,size_i1)
173      CALL ipccsd_x2_2(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse
174     &t)
175      CALL DELETEFILE(d_i1)
176      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
177     &_ERR)
178      CALL OFFSET_ipccsd_x2_3_1(l_i1_offset,k_i1_offset,size_i1)
179      CALL TCE_FILENAME('ipccsd_x2_3_1_i1',filename)
180      CALL CREATEFILE(filename,d_i1,size_i1)
181      CALL ipccsd_x2_3_1(d_f1,k_f1_offset,d_i1,k_i1_offset)
182      CALL ipccsd_x2_3_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_off
183     &set)
184      CALL ipccsd_x2_3_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1,k_i1_off
185     &set)
186      CALL RECONCILEFILE(d_i1,size_i1)
187      CALL ipccsd_x2_3(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse
188     &t)
189      CALL DELETEFILE(d_i1)
190      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
191     &_ERR)
192      CALL OFFSET_ipccsd_x2_4_1(l_i1_offset,k_i1_offset,size_i1)
193      CALL TCE_FILENAME('ipccsd_x2_4_1_i1',filename)
194      CALL CREATEFILE(filename,d_i1,size_i1)
195      CALL ipccsd_x2_4_1(d_v2,k_v2_offset,d_i1,k_i1_offset)
196      CALL OFFSET_ipccsd_x2_4_2_1(l_i2_offset,k_i2_offset,size_i2)
197      CALL TCE_FILENAME('ipccsd_x2_4_2_1_i2',filename)
198      CALL CREATEFILE(filename,d_i2,size_i2)
199      CALL ipccsd_x2_4_2_1(d_v2,k_v2_offset,d_i2,k_i2_offset)
200      CALL ipccsd_x2_4_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o
201     &ffset)
202      CALL RECONCILEFILE(d_i2,size_i2)
203      CALL ipccsd_x2_4_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1,k_i1_off
204     &set)
205      CALL DELETEFILE(d_i2)
206      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
207     &_ERR)
208      CALL ipccsd_x2_4_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1,k_i1_off
209     &set)
210      CALL RECONCILEFILE(d_i1,size_i1)
211      CALL ipccsd_x2_4(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse
212     &t)
213      CALL DELETEFILE(d_i1)
214      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
215     &_ERR)
216      CALL OFFSET_ipccsd_x2_5_1(l_i1_offset,k_i1_offset,size_i1)
217      CALL TCE_FILENAME('ipccsd_x2_5_1_i1',filename)
218      CALL CREATEFILE(filename,d_i1,size_i1)
219      CALL ipccsd_x2_5_1(d_v2,k_v2_offset,d_i1,k_i1_offset)
220      CALL ipccsd_x2_5_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_off
221     &set)
222      CALL RECONCILEFILE(d_i1,size_i1)
223      CALL ipccsd_x2_5(d_x2,k_x2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse
224     &t)
225      CALL DELETEFILE(d_i1)
226      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
227     &_ERR)
228      CALL OFFSET_ipccsd_x2_6_1(l_i1_offset,k_i1_offset,size_i1)
229      CALL TCE_FILENAME('ipccsd_x2_6_1_i1',filename)
230      CALL CREATEFILE(filename,d_i1,size_i1)
231      CALL OFFSET_ipccsd_x2_6_1_1(l_i2_offset,k_i2_offset,size_i2)
232      CALL TCE_FILENAME('ipccsd_x2_6_1_1_i2',filename)
233      CALL CREATEFILE(filename,d_i2,size_i2)
234      CALL ipccsd_x2_6_1_1(d_v2,k_v2_offset,d_i2,k_i2_offset)
235      CALL OFFSET_ipccsd_x2_6_1_2_1(l_i3_offset,k_i3_offset,size_i3)
236      CALL TCE_FILENAME('ipccsd_x2_6_1_2_1_i3',filename)
237      CALL CREATEFILE(filename,d_i3,size_i3)
238      CALL ipccsd_x2_6_1_2_1(d_v2,k_v2_offset,d_i3,k_i3_offset)
239      CALL ipccsd_x2_6_1_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i3,k_i3
240     &_offset)
241      CALL RECONCILEFILE(d_i3,size_i3)
242      CALL ipccsd_x2_6_1_2(d_t1,k_t1_offset,d_i3,k_i3_offset,d_i2,k_i2_o
243     &ffset)
244      CALL DELETEFILE(d_i3)
245      IF (.not.MA_POP_STACK(l_i3_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
246     &_ERR)
247      CALL ipccsd_x2_6_1_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i2,k_i2_o
248     &ffset)
249c      write(LuOut,*) "I am here 1"
250c      call util_flush(LuOut)
251      CALL RECONCILEFILE(d_i2,size_i2)
252      CALL ipccsd_x2_6_1(d_x1,k_x1_offset,d_i2,k_i2_offset,d_i1,k_i1_off
253     &set)
254c      write(LuOut,*) "I am here 2"
255c      call util_flush(LuOut)
256      CALL DELETEFILE(d_i2)
257      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
258     &_ERR)
259      CALL OFFSET_ipccsd_x2_6_2_1(l_i2_offset,k_i2_offset,size_i2)
260      CALL TCE_FILENAME('ipccsd_x2_6_2_1_i2',filename)
261      CALL CREATEFILE(filename,d_i2,size_i2)
262      CALL ipccsd_x2_6_2_1(d_f1,k_f1_offset,d_i2,k_i2_offset)
263c      write(LuOut,*) "I am here 3"
264c      call util_flush(LuOut)
265      CALL ipccsd_x2_6_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o
266     &ffset)
267c      write(LuOut,*) "I am here 4"
268c      call util_flush(LuOut)
269      CALL RECONCILEFILE(d_i2,size_i2)
270      CALL ipccsd_x2_6_2(d_x2,k_x2_offset,d_i2,k_i2_offset,d_i1,k_i1_off
271     &set)
272      CALL DELETEFILE(d_i2)
273      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
274     &_ERR)
275      CALL OFFSET_ipccsd_x2_6_3_1(l_i2_offset,k_i2_offset,size_i2)
276      CALL TCE_FILENAME('ipccsd_x2_6_3_1_i2',filename)
277      CALL CREATEFILE(filename,d_i2,size_i2)
278      CALL ipccsd_x2_6_3_1(d_v2,k_v2_offset,d_i2,k_i2_offset)
279      CALL ipccsd_x2_6_3_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2,k_i2_o
280     &ffset)
281      CALL RECONCILEFILE(d_i2,size_i2)
282      CALL ipccsd_x2_6_3(d_x2,k_x2_offset,d_i2,k_i2_offset,d_i1,k_i1_off
283     &set)
284      CALL DELETEFILE(d_i2)
285      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
286     &_ERR)
287      CALL RECONCILEFILE(d_i1,size_i1)
288      CALL ipccsd_x2_6(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offse
289     &t)
290      CALL DELETEFILE(d_i1)
291      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
292     &_ERR)
293      CALL OFFSET_ipccsd_x2_7_1(l_i1_offset,k_i1_offset,size_i1)
294      CALL TCE_FILENAME('ipccsd_x2_7_1_i1',filename)
295      CALL CREATEFILE(filename,d_i1,size_i1)
296      CALL ipccsd_x2_7_1(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i1,k_i1_off
297     &set)
298      CALL RECONCILEFILE(d_i1,size_i1)
299      CALL ipccsd_x2_7(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse
300     &t)
301      CALL DELETEFILE(d_i1)
302      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
303     &_ERR)
304      CALL OFFSET_ipccsd_x2_8_1(l_i1_offset,k_i1_offset,size_i1)
305      CALL TCE_FILENAME('ipccsd_x2_8_1_i1',filename)
306      CALL CREATEFILE(filename,d_i1,size_i1)
307      CALL ipccsd_x2_8_1(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i1,k_i1_off
308     &set)
309      CALL RECONCILEFILE(d_i1,size_i1)
310      CALL ipccsd_x2_8(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offse
311     &t)
312      CALL DELETEFILE(d_i1)
313      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ipccsd_x2',-1,MA
314     &_ERR)
315      RETURN
316      END
317      SUBROUTINE ipccsd_x2_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
318     &t)
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     i0 ( p3 p4 h1 h2 )_xv + = -1 * P( 2 ) * Sum ( h9 ) * x ( p3 h9 )_x * i1 ( h9 p4 h1 h2 )_v
323      IMPLICIT NONE
324#include "global.fh"
325#include "mafdecls.fh"
326#include "sym.fh"
327#include "errquit.fh"
328#include "tce.fh"
329#include "stdio.fh"
330      INTEGER d_a
331      INTEGER k_a_offset
332      INTEGER d_b
333      INTEGER k_b_offset
334      INTEGER d_c
335      INTEGER k_c_offset
336      INTEGER NXTASK
337      INTEGER next
338      INTEGER nprocs
339      INTEGER count
340      INTEGER p3b
341      INTEGER p4b
342      INTEGER h1b
343      INTEGER h2b
344      INTEGER dimc
345      INTEGER l_c_sort
346      INTEGER k_c_sort
347      INTEGER h9b
348      INTEGER p3b_1
349      INTEGER h9b_1
350      INTEGER p4b_2
351      INTEGER h9b_2
352      INTEGER h1b_2
353      INTEGER h2b_2
354      INTEGER dim_common
355      INTEGER dima_sort
356      INTEGER dima
357      INTEGER dimb_sort
358      INTEGER dimb
359      INTEGER l_a_sort
360      INTEGER k_a_sort
361      INTEGER l_a
362      INTEGER k_a
363      INTEGER l_b_sort
364      INTEGER k_b_sort
365      INTEGER l_b
366      INTEGER k_b
367      INTEGER l_c
368      INTEGER k_c
369      EXTERNAL NXTASK
370      nprocs = GA_NNODES()
371      count = 0
372      next = NXTASK(nprocs, 1)
373ckbn      DO p3b = noab+1,noab+nvab
374      DO p3b = 1,1
375      DO p4b = noab+1,noab+nvab
376      DO h1b = 1,noab
377      DO h2b = h1b,noab
378      IF (next.eq.count) THEN
379ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
380ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
381      IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p4b-1
382     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
383ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
384ckbn     &1b-1)+int_mb(k_spin+h2b-1)) THEN
385      IF (ip_unused_spin +int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
386     &1b-1)+int_mb(k_spin+h2b-1)) THEN
387ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
388ckbn     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH
389ckbn     &EN
390      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
391     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH
392     &EN
393ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
394ckbn     &nge+h1b-1) * int_mb(k_range+h2b-1)
395      dimc = 1 * int_mb(k_range+p4b-1) * int_mb(k_ra
396     &nge+h1b-1) * int_mb(k_range+h2b-1)
397      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
398     & ERRQUIT('ipccsd_x2_1',0,MA_ERR)
399      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
400      DO h9b = 1,noab
401ckbn      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h9b-1)) THEN
402      IF (ip_unused_spin .eq. int_mb(k_spin+h9b-1)) THEN
403ckbn      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h9b-1)) .eq. irrep_x) TH
404ckbn     &EN
405      IF (ieor(ip_unused_sym ,int_mb(k_sym+h9b-1)) .eq. irrep_x) TH
406     &EN
407      CALL TCE_RESTRICTED_2(p3b,h9b,p3b_1,h9b_1)
408      CALL TCE_RESTRICTED_4(p4b,h9b,h1b,h2b,p4b_2,h9b_2,h1b_2,h2b_2)
409      dim_common = int_mb(k_range+h9b-1)
410ckbn      dima_sort = int_mb(k_range+p3b-1)
411      dima_sort = 1
412      dima = dim_common * dima_sort
413      dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1) * int_mb
414     &(k_range+h2b-1)
415      dimb = dim_common * dimb_sort
416      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
417      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
418     & ERRQUIT('ipccsd_x2_1',1,MA_ERR)
419      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
420     &ipccsd_x2_1',2,MA_ERR)
421c      write(LuOut,*) "I am here 1."
422c      call util_flush(LuOut)
423      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h9b_1
424     & - 1 + noab * (p3b_1 - noab - 1)))
425ckbn      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
426ckbn     &,int_mb(k_range+h9b-1),1,2,1.0d0)
427      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),1
428     &,int_mb(k_range+h9b-1),1,2,1.0d0)
429c      write(LuOut,*) "I am here 2."
430c      call util_flush(LuOut)
431      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1',3,MA_ERR)
432      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
433     & ERRQUIT('ipccsd_x2_1',4,MA_ERR)
434      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
435     &ipccsd_x2_1',5,MA_ERR)
436      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
437     & - 1 + noab * (h1b_2 - 1 + noab * (h9b_2 - 1 + noab * (p4b_2 - noa
438     &b - 1)))))
439      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
440     &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
441     &,4,3,1,2,1.0d0)
442      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1',6,MA_ERR)
443      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
444     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
445     &t),dima_sort)
446      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1',7,MA_E
447     &RR)
448      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1',8,MA_E
449     &RR)
450      END IF
451      END IF
452      END IF
453      END DO
454      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
455     &ipccsd_x2_1',9,MA_ERR)
456ckbn      IF ((p3b .le. p4b)) THEN
457ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
458ckbn     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
459ckbn     &,4,3,2,1,-1.0d0)
460c      write(LuOut,*) "I am here 3."
461c      call util_flush(LuOut)
462ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
463ckbn     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),1
464ckbn     &,4,3,2,1,-1.0d0)
465ckbn      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
466ckbn     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
467ckbn     & - 1)))))
468ckbn      END IF
469ckbn      IF ((p4b .le. p3b)) THEN
470ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
471ckbn     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
472ckbn     &,3,4,2,1,1.0d0)
473      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
474     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),1
475     &,3,4,2,1,1.0d0)
476c      write(LuOut,*) "I am here 3.1"
477c      call util_flush(LuOut)
478      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
479     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
480     & - 1)))))
481c      write(LuOut,*) "I am here 4."
482c      call util_flush(LuOut)
483ckbn      END IF
484      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1',10,MA_ERR)
485      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1',11,MA_
486     &ERR)
487      END IF
488      END IF
489      END IF
490      next = NXTASK(nprocs, 1)
491      END IF
492      count = count + 1
493      END DO
494      END DO
495      END DO
496      END DO
497      next = NXTASK(-nprocs, 1)
498      call GA_SYNC()
499      RETURN
500      END
501      SUBROUTINE ipccsd_x2_1_1(d_a,k_a_offset,d_c,k_c_offset)
502C     $Id$
503C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
504C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
505C     i1 ( h9 p3 h1 h2 )_v + = 1 * v ( h9 p3 h1 h2 )_v
506      IMPLICIT NONE
507#include "global.fh"
508#include "mafdecls.fh"
509#include "sym.fh"
510#include "errquit.fh"
511#include "tce.fh"
512      INTEGER d_a
513      INTEGER k_a_offset
514      INTEGER d_c
515      INTEGER k_c_offset
516      INTEGER NXTASK
517      INTEGER next
518      INTEGER nprocs
519      INTEGER count
520      INTEGER p3b
521      INTEGER h9b
522      INTEGER h1b
523      INTEGER h2b
524      INTEGER dimc
525      INTEGER p3b_1
526      INTEGER h9b_1
527      INTEGER h1b_1
528      INTEGER h2b_1
529      INTEGER dim_common
530      INTEGER dima_sort
531      INTEGER dima
532      INTEGER l_a_sort
533      INTEGER k_a_sort
534      INTEGER l_a
535      INTEGER k_a
536      INTEGER l_c
537      INTEGER k_c
538      EXTERNAL NXTASK
539      nprocs = GA_NNODES()
540      count = 0
541      next = NXTASK(nprocs, 1)
542      DO p3b = noab+1,noab+nvab
543      DO h9b = 1,noab
544      DO h1b = 1,noab
545      DO h2b = h1b,noab
546      IF (next.eq.count) THEN
547      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1
548     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
549      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
550     &1b-1)+int_mb(k_spin+h2b-1)) THEN
551      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
552     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
553      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra
554     &nge+h1b-1) * int_mb(k_range+h2b-1)
555      CALL TCE_RESTRICTED_4(p3b,h9b,h1b,h2b,p3b_1,h9b_1,h1b_1,h2b_1)
556      dim_common = 1
557      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb
558     &(k_range+h1b-1) * int_mb(k_range+h2b-1)
559      dima = dim_common * dima_sort
560      IF (dima .gt. 0) THEN
561      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
562     & ERRQUIT('ipccsd_x2_1_1',0,MA_ERR)
563      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
564     &ipccsd_x2_1_1',1,MA_ERR)
565      IF ((h9b .le. p3b)) THEN
566      if(.not.intorb) then
567      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
568     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
569     &+nvab) * (h9b_1 - 1)))))
570      else
571      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
572     &(h2b_1
573     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
574     &+nvab) * (h9b_1 - 1)))),h2b_1,h1b_1,p3b_1,h9b_1)
575      end if
576      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1)
577     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
578     &,4,3,1,2,1.0d0)
579      END IF
580      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_1',2,MA_ERR)
581      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
582     &ipccsd_x2_1_1',3,MA_ERR)
583      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
584     &,int_mb(k_range+h1b-1),int_mb(k_range+h9b-1),int_mb(k_range+p3b-1)
585     &,4,3,2,1,1.0d0)
586      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
587     & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1)))
588     &))
589      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_1',4,MA_ERR)
590      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_1',5,MA
591     &_ERR)
592      END IF
593      END IF
594      END IF
595      END IF
596      next = NXTASK(nprocs, 1)
597      END IF
598      count = count + 1
599      END DO
600      END DO
601      END DO
602      END DO
603      next = NXTASK(-nprocs, 1)
604      call GA_SYNC()
605      RETURN
606      END
607      SUBROUTINE OFFSET_ipccsd_x2_1_1(l_a_offset,k_a_offset,size)
608C     $Id$
609C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
610C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
611C     i1 ( h9 p3 h1 h2 )_v
612      IMPLICIT NONE
613#include "global.fh"
614#include "mafdecls.fh"
615#include "sym.fh"
616#include "errquit.fh"
617#include "tce.fh"
618      INTEGER l_a_offset
619      INTEGER k_a_offset
620      INTEGER size
621      INTEGER length
622      INTEGER addr
623      INTEGER p3b
624      INTEGER h9b
625      INTEGER h1b
626      INTEGER h2b
627      length = 0
628      DO p3b = noab+1,noab+nvab
629      DO h9b = 1,noab
630      DO h1b = 1,noab
631      DO h2b = h1b,noab
632      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
633     &1b-1)+int_mb(k_spin+h2b-1)) THEN
634      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
635     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
636      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1
637     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
638      length = length + 1
639      END IF
640      END IF
641      END IF
642      END DO
643      END DO
644      END DO
645      END DO
646      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
647     &set)) CALL ERRQUIT('ipccsd_x2_1_1',0,MA_ERR)
648      int_mb(k_a_offset) = length
649      addr = 0
650      size = 0
651      DO p3b = noab+1,noab+nvab
652      DO h9b = 1,noab
653      DO h1b = 1,noab
654      DO h2b = h1b,noab
655      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
656     &1b-1)+int_mb(k_spin+h2b-1)) THEN
657      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
658     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
659      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1
660     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
661      addr = addr + 1
662      int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h9b
663     &- 1 + noab * (p3b - noab - 1)))
664      int_mb(k_a_offset+length+addr) = size
665      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_
666     &mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
667      END IF
668      END IF
669      END IF
670      END DO
671      END DO
672      END DO
673      END DO
674      RETURN
675      END
676      SUBROUTINE ipccsd_x2_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
677     &set)
678C     $Id$
679C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
680C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
681C     i1 ( h9 p3 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h9 p3 h2 p5 )_v
682      IMPLICIT NONE
683#include "global.fh"
684#include "mafdecls.fh"
685#include "sym.fh"
686#include "errquit.fh"
687#include "tce.fh"
688      INTEGER d_a
689      INTEGER k_a_offset
690      INTEGER d_b
691      INTEGER k_b_offset
692      INTEGER d_c
693      INTEGER k_c_offset
694      INTEGER NXTASK
695      INTEGER next
696      INTEGER nprocs
697      INTEGER count
698      INTEGER p3b
699      INTEGER h9b
700      INTEGER h1b
701      INTEGER h2b
702      INTEGER dimc
703      INTEGER l_c_sort
704      INTEGER k_c_sort
705      INTEGER p5b
706      INTEGER p5b_1
707      INTEGER h1b_1
708      INTEGER p3b_2
709      INTEGER h9b_2
710      INTEGER h2b_2
711      INTEGER p5b_2
712      INTEGER dim_common
713      INTEGER dima_sort
714      INTEGER dima
715      INTEGER dimb_sort
716      INTEGER dimb
717      INTEGER l_a_sort
718      INTEGER k_a_sort
719      INTEGER l_a
720      INTEGER k_a
721      INTEGER l_b_sort
722      INTEGER k_b_sort
723      INTEGER l_b
724      INTEGER k_b
725      INTEGER l_c
726      INTEGER k_c
727      EXTERNAL NXTASK
728      nprocs = GA_NNODES()
729      count = 0
730      next = NXTASK(nprocs, 1)
731      DO p3b = noab+1,noab+nvab
732      DO h9b = 1,noab
733      DO h1b = 1,noab
734      DO h2b = 1,noab
735      IF (next.eq.count) THEN
736      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1
737     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
738      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
739     &1b-1)+int_mb(k_spin+h2b-1)) THEN
740      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
741     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
742     &EN
743      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra
744     &nge+h1b-1) * int_mb(k_range+h2b-1)
745      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
746     & ERRQUIT('ipccsd_x2_1_2',0,MA_ERR)
747      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
748      DO p5b = noab+1,noab+nvab
749      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
750      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
751     &EN
752      CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1)
753      CALL TCE_RESTRICTED_4(p3b,h9b,h2b,p5b,p3b_2,h9b_2,h2b_2,p5b_2)
754      dim_common = int_mb(k_range+p5b-1)
755      dima_sort = int_mb(k_range+h1b-1)
756      dima = dim_common * dima_sort
757      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb
758     &(k_range+h2b-1)
759      dimb = dim_common * dimb_sort
760      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
761      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
762     & ERRQUIT('ipccsd_x2_1_2',1,MA_ERR)
763      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
764     &ipccsd_x2_1_2',2,MA_ERR)
765      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
766     & - 1 + noab * (p5b_1 - noab - 1)))
767      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
768     &,int_mb(k_range+h1b-1),2,1,1.0d0)
769      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_2',3,MA_ERR)
770      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
771     & ERRQUIT('ipccsd_x2_1_2',4,MA_ERR)
772      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
773     &ipccsd_x2_1_2',5,MA_ERR)
774      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
775     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h9b_2 - 1 + noab * (p3b_
776     &2 - noab - 1)))))
777      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1)
778     &,int_mb(k_range+h9b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1)
779     &,3,2,1,4,1.0d0)
780      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_2',6,MA_ERR)
781      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
782     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
783     &t),dima_sort)
784      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_2',7,MA
785     &_ERR)
786      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_2',8,MA
787     &_ERR)
788      END IF
789      END IF
790      END IF
791      END DO
792      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
793     &ipccsd_x2_1_2',9,MA_ERR)
794      IF ((h1b .le. h2b)) THEN
795      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
796     &,int_mb(k_range+h9b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
797     &,3,2,4,1,-1.0d0)
798      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
799     & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1)))
800     &))
801      END IF
802      IF ((h2b .le. h1b)) THEN
803      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
804     &,int_mb(k_range+h9b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
805     &,3,2,1,4,1.0d0)
806      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
807     & 1 + noab * (h2b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1)))
808     &))
809      END IF
810      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_2',10,MA_ERR
811     &)
812      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_2',11,M
813     &A_ERR)
814      END IF
815      END IF
816      END IF
817      next = NXTASK(nprocs, 1)
818      END IF
819      count = count + 1
820      END DO
821      END DO
822      END DO
823      END DO
824      next = NXTASK(-nprocs, 1)
825      call GA_SYNC()
826      RETURN
827      END
828      SUBROUTINE ipccsd_x2_1_2_1(d_a,k_a_offset,d_c,k_c_offset)
829C     $Id$
830C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
831C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
832C     i2 ( h9 p3 h1 p5 )_v + = 1 * v ( h9 p3 h1 p5 )_v
833      IMPLICIT NONE
834#include "global.fh"
835#include "mafdecls.fh"
836#include "sym.fh"
837#include "errquit.fh"
838#include "tce.fh"
839      INTEGER d_a
840      INTEGER k_a_offset
841      INTEGER d_c
842      INTEGER k_c_offset
843      INTEGER NXTASK
844      INTEGER next
845      INTEGER nprocs
846      INTEGER count
847      INTEGER p3b
848      INTEGER h9b
849      INTEGER h1b
850      INTEGER p5b
851      INTEGER dimc
852      INTEGER p3b_1
853      INTEGER h9b_1
854      INTEGER h1b_1
855      INTEGER p5b_1
856      INTEGER dim_common
857      INTEGER dima_sort
858      INTEGER dima
859      INTEGER l_a_sort
860      INTEGER k_a_sort
861      INTEGER l_a
862      INTEGER k_a
863      INTEGER l_c
864      INTEGER k_c
865      EXTERNAL NXTASK
866      nprocs = GA_NNODES()
867      count = 0
868      next = NXTASK(nprocs, 1)
869      DO p3b = noab+1,noab+nvab
870      DO h9b = 1,noab
871      DO h1b = 1,noab
872      DO p5b = noab+1,noab+nvab
873      IF (next.eq.count) THEN
874      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1
875     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
876      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
877     &1b-1)+int_mb(k_spin+p5b-1)) THEN
878      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
879     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
880      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra
881     &nge+h1b-1) * int_mb(k_range+p5b-1)
882      CALL TCE_RESTRICTED_4(p3b,h9b,h1b,p5b,p3b_1,h9b_1,h1b_1,p5b_1)
883      dim_common = 1
884      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb
885     &(k_range+h1b-1) * int_mb(k_range+p5b-1)
886      dima = dim_common * dima_sort
887      IF (dima .gt. 0) THEN
888      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
889     & ERRQUIT('ipccsd_x2_1_2_1',0,MA_ERR)
890      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
891     &ipccsd_x2_1_2_1',1,MA_ERR)
892      IF ((h9b .le. p3b) .and. (h1b .le. p5b)) THEN
893      if(.not.intorb) then
894      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
895     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
896     &+nvab) * (h9b_1 - 1)))))
897      else
898      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
899     &(p5b_1
900     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
901     &+nvab) * (h9b_1 - 1)))),p5b_1,h1b_1,p3b_1,h9b_1)
902      end if
903      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1)
904     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1)
905     &,4,3,1,2,1.0d0)
906      END IF
907      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_2_1',2,MA_ER
908     &R)
909      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
910     &ipccsd_x2_1_2_1',3,MA_ERR)
911      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
912     &,int_mb(k_range+h1b-1),int_mb(k_range+h9b-1),int_mb(k_range+p3b-1)
913     &,4,3,2,1,1.0d0)
914      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
915     & noab - 1 + nvab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab
916     & - 1)))))
917      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_2_1',4,MA_ER
918     &R)
919      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_2_1',5,
920     &MA_ERR)
921      END IF
922      END IF
923      END IF
924      END IF
925      next = NXTASK(nprocs, 1)
926      END IF
927      count = count + 1
928      END DO
929      END DO
930      END DO
931      END DO
932      next = NXTASK(-nprocs, 1)
933      call GA_SYNC()
934      RETURN
935      END
936      SUBROUTINE OFFSET_ipccsd_x2_1_2_1(l_a_offset,k_a_offset,size)
937C     $Id$
938C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
939C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
940C     i2 ( h9 p3 h1 p5 )_v
941      IMPLICIT NONE
942#include "global.fh"
943#include "mafdecls.fh"
944#include "sym.fh"
945#include "errquit.fh"
946#include "tce.fh"
947      INTEGER l_a_offset
948      INTEGER k_a_offset
949      INTEGER size
950      INTEGER length
951      INTEGER addr
952      INTEGER p3b
953      INTEGER h9b
954      INTEGER h1b
955      INTEGER p5b
956      length = 0
957      DO p3b = noab+1,noab+nvab
958      DO h9b = 1,noab
959      DO h1b = 1,noab
960      DO p5b = noab+1,noab+nvab
961      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
962     &1b-1)+int_mb(k_spin+p5b-1)) THEN
963      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
964     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
965      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1
966     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
967      length = length + 1
968      END IF
969      END IF
970      END IF
971      END DO
972      END DO
973      END DO
974      END DO
975      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
976     &set)) CALL ERRQUIT('ipccsd_x2_1_2_1',0,MA_ERR)
977      int_mb(k_a_offset) = length
978      addr = 0
979      size = 0
980      DO p3b = noab+1,noab+nvab
981      DO h9b = 1,noab
982      DO h1b = 1,noab
983      DO p5b = noab+1,noab+nvab
984      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
985     &1b-1)+int_mb(k_spin+p5b-1)) THEN
986      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
987     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
988      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p3b-1
989     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
990      addr = addr + 1
991      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab
992     &* (h9b - 1 + noab * (p3b - noab - 1)))
993      int_mb(k_a_offset+length+addr) = size
994      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_
995     &mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
996      END IF
997      END IF
998      END IF
999      END DO
1000      END DO
1001      END DO
1002      END DO
1003      RETURN
1004      END
1005      SUBROUTINE ipccsd_x2_1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
1006     &ffset)
1007C     $Id$
1008C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1009C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1010C     i2 ( h9 p3 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 p3 p5 p6 )_v
1011      IMPLICIT NONE
1012#include "global.fh"
1013#include "mafdecls.fh"
1014#include "sym.fh"
1015#include "errquit.fh"
1016#include "tce.fh"
1017      INTEGER d_a
1018      INTEGER k_a_offset
1019      INTEGER d_b
1020      INTEGER k_b_offset
1021      INTEGER d_c
1022      INTEGER k_c_offset
1023      INTEGER NXTASK
1024      INTEGER next
1025      INTEGER nprocs
1026      INTEGER count
1027      INTEGER p3b
1028      INTEGER h9b
1029      INTEGER h1b
1030      INTEGER p5b
1031      INTEGER dimc
1032      INTEGER l_c_sort
1033      INTEGER k_c_sort
1034      INTEGER p6b
1035      INTEGER p6b_1
1036      INTEGER h1b_1
1037      INTEGER p3b_2
1038      INTEGER h9b_2
1039      INTEGER p5b_2
1040      INTEGER p6b_2
1041      INTEGER dim_common
1042      INTEGER dima_sort
1043      INTEGER dima
1044      INTEGER dimb_sort
1045      INTEGER dimb
1046      INTEGER l_a_sort
1047      INTEGER k_a_sort
1048      INTEGER l_a
1049      INTEGER k_a
1050      INTEGER l_b_sort
1051      INTEGER k_b_sort
1052      INTEGER l_b
1053      INTEGER k_b
1054      INTEGER l_c
1055      INTEGER k_c
1056      EXTERNAL NXTASK
1057      nprocs = GA_NNODES()
1058      count = 0
1059      next = NXTASK(nprocs, 1)
1060      DO p3b = noab+1,noab+nvab
1061      DO h9b = 1,noab
1062      DO h1b = 1,noab
1063      DO p5b = noab+1,noab+nvab
1064      IF (next.eq.count) THEN
1065      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1
1066     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
1067      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
1068     &1b-1)+int_mb(k_spin+p5b-1)) THEN
1069      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
1070     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
1071     &EN
1072      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra
1073     &nge+h1b-1) * int_mb(k_range+p5b-1)
1074      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1075     & ERRQUIT('ipccsd_x2_1_2_2',0,MA_ERR)
1076      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1077      DO p6b = noab+1,noab+nvab
1078      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1079      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
1080     &EN
1081      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
1082      CALL TCE_RESTRICTED_4(p3b,h9b,p5b,p6b,p3b_2,h9b_2,p5b_2,p6b_2)
1083      dim_common = int_mb(k_range+p6b-1)
1084      dima_sort = int_mb(k_range+h1b-1)
1085      dima = dim_common * dima_sort
1086      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb
1087     &(k_range+p5b-1)
1088      dimb = dim_common * dimb_sort
1089      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1090      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1091     & ERRQUIT('ipccsd_x2_1_2_2',1,MA_ERR)
1092      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1093     &ipccsd_x2_1_2_2',2,MA_ERR)
1094      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
1095     & - 1 + noab * (p6b_1 - noab - 1)))
1096      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
1097     &,int_mb(k_range+h1b-1),2,1,1.0d0)
1098      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_2_2',3,MA_ER
1099     &R)
1100      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1101     & ERRQUIT('ipccsd_x2_1_2_2',4,MA_ERR)
1102      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1103     &ipccsd_x2_1_2_2',5,MA_ERR)
1104      IF ((h9b .le. p3b) .and. (p6b .lt. p5b)) THEN
1105      if(.not.intorb) then
1106      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
1107     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
1108     &+nvab) * (h9b_2 - 1)))))
1109      else
1110      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1111     &(p5b_2
1112     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
1113     &+nvab) * (h9b_2 - 1)))),p5b_2,p6b_2,p3b_2,h9b_2)
1114      end if
1115      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
1116     &,int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1)
1117     &,4,1,2,3,-1.0d0)
1118      END IF
1119      IF ((h9b .le. p3b) .and. (p5b .le. p6b)) THEN
1120      if(.not.intorb) then
1121      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
1122     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
1123     &+nvab) * (h9b_2 - 1)))))
1124      else
1125      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1126     &(p6b_2
1127     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
1128     &+nvab) * (h9b_2 - 1)))),p6b_2,p5b_2,p3b_2,h9b_2)
1129      end if
1130      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
1131     &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1)
1132     &,3,1,2,4,1.0d0)
1133      END IF
1134      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_2_2',6,MA_ER
1135     &R)
1136      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1137     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1138     &t),dima_sort)
1139      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_2_2',7,
1140     &MA_ERR)
1141      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_2_2',8,
1142     &MA_ERR)
1143      END IF
1144      END IF
1145      END IF
1146      END DO
1147      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1148     &ipccsd_x2_1_2_2',9,MA_ERR)
1149      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
1150     &,int_mb(k_range+h9b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
1151     &,3,2,4,1,-1.0d0/2.0d0)
1152      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
1153     & noab - 1 + nvab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab
1154     & - 1)))))
1155      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_2_2',10,MA_E
1156     &RR)
1157      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_2_2',11
1158     &,MA_ERR)
1159      END IF
1160      END IF
1161      END IF
1162      next = NXTASK(nprocs, 1)
1163      END IF
1164      count = count + 1
1165      END DO
1166      END DO
1167      END DO
1168      END DO
1169      next = NXTASK(-nprocs, 1)
1170      call GA_SYNC()
1171      RETURN
1172      END
1173      SUBROUTINE ipccsd_x2_1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
1174     &set)
1175C     $Id$
1176C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1177C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1178C     i1 ( h9 p3 h1 h2 )_ft + = -1 * Sum ( p8 ) * t ( p3 p8 h1 h2 )_t * i2 ( h9 p8 )_f
1179      IMPLICIT NONE
1180#include "global.fh"
1181#include "mafdecls.fh"
1182#include "sym.fh"
1183#include "errquit.fh"
1184#include "tce.fh"
1185      INTEGER d_a
1186      INTEGER k_a_offset
1187      INTEGER d_b
1188      INTEGER k_b_offset
1189      INTEGER d_c
1190      INTEGER k_c_offset
1191      INTEGER NXTASK
1192      INTEGER next
1193      INTEGER nprocs
1194      INTEGER count
1195      INTEGER p3b
1196      INTEGER h9b
1197      INTEGER h1b
1198      INTEGER h2b
1199      INTEGER dimc
1200      INTEGER l_c_sort
1201      INTEGER k_c_sort
1202      INTEGER p8b
1203      INTEGER p3b_1
1204      INTEGER p8b_1
1205      INTEGER h1b_1
1206      INTEGER h2b_1
1207      INTEGER h9b_2
1208      INTEGER p8b_2
1209      INTEGER dim_common
1210      INTEGER dima_sort
1211      INTEGER dima
1212      INTEGER dimb_sort
1213      INTEGER dimb
1214      INTEGER l_a_sort
1215      INTEGER k_a_sort
1216      INTEGER l_a
1217      INTEGER k_a
1218      INTEGER l_b_sort
1219      INTEGER k_b_sort
1220      INTEGER l_b
1221      INTEGER k_b
1222      INTEGER l_c
1223      INTEGER k_c
1224      EXTERNAL NXTASK
1225      nprocs = GA_NNODES()
1226      count = 0
1227      next = NXTASK(nprocs, 1)
1228      DO p3b = noab+1,noab+nvab
1229      DO h9b = 1,noab
1230      DO h1b = 1,noab
1231      DO h2b = h1b,noab
1232      IF (next.eq.count) THEN
1233      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1
1234     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
1235      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
1236     &1b-1)+int_mb(k_spin+h2b-1)) THEN
1237      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
1238     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_f,irrep_t)) TH
1239     &EN
1240      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra
1241     &nge+h1b-1) * int_mb(k_range+h2b-1)
1242      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1243     & ERRQUIT('ipccsd_x2_1_3',0,MA_ERR)
1244      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1245      DO p8b = noab+1,noab+nvab
1246      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
1247     &1b-1)+int_mb(k_spin+h2b-1)) THEN
1248      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
1249     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
1250      CALL TCE_RESTRICTED_4(p3b,p8b,h1b,h2b,p3b_1,p8b_1,h1b_1,h2b_1)
1251      CALL TCE_RESTRICTED_2(h9b,p8b,h9b_2,p8b_2)
1252      dim_common = int_mb(k_range+p8b-1)
1253      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb
1254     &(k_range+h2b-1)
1255      dima = dim_common * dima_sort
1256      dimb_sort = int_mb(k_range+h9b-1)
1257      dimb = dim_common * dimb_sort
1258      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1259      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1260     & ERRQUIT('ipccsd_x2_1_3',1,MA_ERR)
1261      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1262     &ipccsd_x2_1_3',2,MA_ERR)
1263      IF ((p8b .lt. p3b)) THEN
1264      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
1265     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_
1266     &1 - noab - 1)))))
1267      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
1268     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
1269     &,4,3,2,1,-1.0d0)
1270      END IF
1271      IF ((p3b .le. p8b)) THEN
1272      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
1273     & - 1 + noab * (h1b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_
1274     &1 - noab - 1)))))
1275      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
1276     &,int_mb(k_range+p8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
1277     &,4,3,1,2,1.0d0)
1278      END IF
1279      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_3',3,MA_ERR)
1280      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1281     & ERRQUIT('ipccsd_x2_1_3',4,MA_ERR)
1282      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1283     &ipccsd_x2_1_3',5,MA_ERR)
1284      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
1285     & - noab - 1 + nvab * (h9b_2 - 1)))
1286      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
1287     &,int_mb(k_range+p8b-1),1,2,1.0d0)
1288      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_3',6,MA_ERR)
1289      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1290     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1291     &t),dima_sort)
1292      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_3',7,MA
1293     &_ERR)
1294      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_3',8,MA
1295     &_ERR)
1296      END IF
1297      END IF
1298      END IF
1299      END DO
1300      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1301     &ipccsd_x2_1_3',9,MA_ERR)
1302      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h9b-1)
1303     &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
1304     &,4,1,3,2,-1.0d0)
1305      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
1306     & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1)))
1307     &))
1308      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_3',10,MA_ERR
1309     &)
1310      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_3',11,M
1311     &A_ERR)
1312      END IF
1313      END IF
1314      END IF
1315      next = NXTASK(nprocs, 1)
1316      END IF
1317      count = count + 1
1318      END DO
1319      END DO
1320      END DO
1321      END DO
1322      next = NXTASK(-nprocs, 1)
1323      call GA_SYNC()
1324      RETURN
1325      END
1326      SUBROUTINE ipccsd_x2_1_3_1(d_a,k_a_offset,d_c,k_c_offset)
1327C     $Id$
1328C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1329C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1330C     i2 ( h9 p8 )_f + = 1 * f ( h9 p8 )_f
1331      IMPLICIT NONE
1332#include "global.fh"
1333#include "mafdecls.fh"
1334#include "sym.fh"
1335#include "errquit.fh"
1336#include "tce.fh"
1337      INTEGER d_a
1338      INTEGER k_a_offset
1339      INTEGER d_c
1340      INTEGER k_c_offset
1341      INTEGER NXTASK
1342      INTEGER next
1343      INTEGER nprocs
1344      INTEGER count
1345      INTEGER h9b
1346      INTEGER p8b
1347      INTEGER dimc
1348      INTEGER h9b_1
1349      INTEGER p8b_1
1350      INTEGER dim_common
1351      INTEGER dima_sort
1352      INTEGER dima
1353      INTEGER l_a_sort
1354      INTEGER k_a_sort
1355      INTEGER l_a
1356      INTEGER k_a
1357      INTEGER l_c
1358      INTEGER k_c
1359      EXTERNAL NXTASK
1360      nprocs = GA_NNODES()
1361      count = 0
1362      next = NXTASK(nprocs, 1)
1363      DO h9b = 1,noab
1364      DO p8b = noab+1,noab+nvab
1365      IF (next.eq.count) THEN
1366      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1
1367     &).ne.4)) THEN
1368      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN
1369      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH
1370     &EN
1371      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1)
1372      CALL TCE_RESTRICTED_2(h9b,p8b,h9b_1,p8b_1)
1373      dim_common = 1
1374      dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1)
1375      dima = dim_common * dima_sort
1376      IF (dima .gt. 0) THEN
1377      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1378     & ERRQUIT('ipccsd_x2_1_3_1',0,MA_ERR)
1379      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1380     &ipccsd_x2_1_3_1',1,MA_ERR)
1381      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1
1382     & - 1 + (noab+nvab) * (h9b_1 - 1)))
1383      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1)
1384     &,int_mb(k_range+p8b-1),2,1,1.0d0)
1385      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_3_1',2,MA_ER
1386     &R)
1387      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1388     &ipccsd_x2_1_3_1',3,MA_ERR)
1389      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
1390     &,int_mb(k_range+h9b-1),2,1,1.0d0)
1391      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
1392     & noab - 1 + nvab * (h9b - 1)))
1393      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_3_1',4,MA_ER
1394     &R)
1395      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_3_1',5,
1396     &MA_ERR)
1397      END IF
1398      END IF
1399      END IF
1400      END IF
1401      next = NXTASK(nprocs, 1)
1402      END IF
1403      count = count + 1
1404      END DO
1405      END DO
1406      next = NXTASK(-nprocs, 1)
1407      call GA_SYNC()
1408      RETURN
1409      END
1410      SUBROUTINE OFFSET_ipccsd_x2_1_3_1(l_a_offset,k_a_offset,size)
1411C     $Id$
1412C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1413C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1414C     i2 ( h9 p8 )_f
1415      IMPLICIT NONE
1416#include "global.fh"
1417#include "mafdecls.fh"
1418#include "sym.fh"
1419#include "errquit.fh"
1420#include "tce.fh"
1421      INTEGER l_a_offset
1422      INTEGER k_a_offset
1423      INTEGER size
1424      INTEGER length
1425      INTEGER addr
1426      INTEGER h9b
1427      INTEGER p8b
1428      length = 0
1429      DO h9b = 1,noab
1430      DO p8b = noab+1,noab+nvab
1431      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN
1432      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH
1433     &EN
1434      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1
1435     &).ne.4)) THEN
1436      length = length + 1
1437      END IF
1438      END IF
1439      END IF
1440      END DO
1441      END DO
1442      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
1443     &set)) CALL ERRQUIT('ipccsd_x2_1_3_1',0,MA_ERR)
1444      int_mb(k_a_offset) = length
1445      addr = 0
1446      size = 0
1447      DO h9b = 1,noab
1448      DO p8b = noab+1,noab+nvab
1449      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN
1450      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH
1451     &EN
1452      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1
1453     &).ne.4)) THEN
1454      addr = addr + 1
1455      int_mb(k_a_offset+addr) = p8b - noab - 1 + nvab * (h9b - 1)
1456      int_mb(k_a_offset+length+addr) = size
1457      size = size + int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1)
1458      END IF
1459      END IF
1460      END IF
1461      END DO
1462      END DO
1463      RETURN
1464      END
1465      SUBROUTINE ipccsd_x2_1_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
1466     &ffset)
1467C     $Id$
1468C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1469C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1470C     i2 ( h9 p8 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 p6 p8 )_v
1471      IMPLICIT NONE
1472#include "global.fh"
1473#include "mafdecls.fh"
1474#include "sym.fh"
1475#include "errquit.fh"
1476#include "tce.fh"
1477      INTEGER d_a
1478      INTEGER k_a_offset
1479      INTEGER d_b
1480      INTEGER k_b_offset
1481      INTEGER d_c
1482      INTEGER k_c_offset
1483      INTEGER NXTASK
1484      INTEGER next
1485      INTEGER nprocs
1486      INTEGER count
1487      INTEGER h9b
1488      INTEGER p8b
1489      INTEGER dimc
1490      INTEGER l_c_sort
1491      INTEGER k_c_sort
1492      INTEGER p6b
1493      INTEGER h7b
1494      INTEGER p6b_1
1495      INTEGER h7b_1
1496      INTEGER h9b_2
1497      INTEGER h7b_2
1498      INTEGER p8b_2
1499      INTEGER p6b_2
1500      INTEGER dim_common
1501      INTEGER dima_sort
1502      INTEGER dima
1503      INTEGER dimb_sort
1504      INTEGER dimb
1505      INTEGER l_a_sort
1506      INTEGER k_a_sort
1507      INTEGER l_a
1508      INTEGER k_a
1509      INTEGER l_b_sort
1510      INTEGER k_b_sort
1511      INTEGER l_b
1512      INTEGER k_b
1513      INTEGER l_c
1514      INTEGER k_c
1515      EXTERNAL NXTASK
1516      nprocs = GA_NNODES()
1517      count = 0
1518      next = NXTASK(nprocs, 1)
1519      DO h9b = 1,noab
1520      DO p8b = noab+1,noab+nvab
1521      IF (next.eq.count) THEN
1522      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1
1523     &).ne.4)) THEN
1524      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN
1525      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. ieor(irrep_
1526     &v,irrep_t)) THEN
1527      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1)
1528      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1529     & ERRQUIT('ipccsd_x2_1_3_2',0,MA_ERR)
1530      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1531      DO p6b = noab+1,noab+nvab
1532      DO h7b = 1,noab
1533      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN
1534      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH
1535     &EN
1536      CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1)
1537      CALL TCE_RESTRICTED_4(h9b,h7b,p8b,p6b,h9b_2,h7b_2,p8b_2,p6b_2)
1538      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1)
1539      dima_sort = 1
1540      dima = dim_common * dima_sort
1541      dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1)
1542      dimb = dim_common * dimb_sort
1543      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1544      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1545     & ERRQUIT('ipccsd_x2_1_3_2',1,MA_ERR)
1546      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1547     &ipccsd_x2_1_3_2',2,MA_ERR)
1548      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
1549     & - 1 + noab * (p6b_1 - noab - 1)))
1550      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
1551     &,int_mb(k_range+h7b-1),2,1,1.0d0)
1552      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_3_2',3,MA_ER
1553     &R)
1554      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1555     & ERRQUIT('ipccsd_x2_1_3_2',4,MA_ERR)
1556      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1557     &ipccsd_x2_1_3_2',5,MA_ERR)
1558      IF ((h7b .le. h9b) .and. (p6b .le. p8b)) THEN
1559      if(.not.intorb) then
1560      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
1561     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
1562     &+nvab) * (h7b_2 - 1)))))
1563      else
1564      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1565     &(p8b_2
1566     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
1567     &+nvab) * (h7b_2 - 1)))),p8b_2,p6b_2,h9b_2,h7b_2)
1568      end if
1569      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
1570     &,int_mb(k_range+h9b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1)
1571     &,4,2,1,3,1.0d0)
1572      END IF
1573      IF ((h7b .le. h9b) .and. (p8b .lt. p6b)) THEN
1574      if(.not.intorb) then
1575      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
1576     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
1577     &+nvab) * (h7b_2 - 1)))))
1578      else
1579      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1580     &(p6b_2
1581     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
1582     &+nvab) * (h7b_2 - 1)))),p6b_2,p8b_2,h9b_2,h7b_2)
1583      end if
1584      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
1585     &,int_mb(k_range+h9b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1)
1586     &,3,2,1,4,-1.0d0)
1587      END IF
1588      IF ((h9b .lt. h7b) .and. (p6b .le. p8b)) THEN
1589      if(.not.intorb) then
1590      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
1591     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
1592     &+nvab) * (h9b_2 - 1)))))
1593      else
1594      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1595     &(p8b_2
1596     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
1597     &+nvab) * (h9b_2 - 1)))),p8b_2,p6b_2,h7b_2,h9b_2)
1598      end if
1599      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
1600     &,int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1)
1601     &,4,1,2,3,-1.0d0)
1602      END IF
1603      IF ((h9b .lt. h7b) .and. (p8b .lt. p6b)) THEN
1604      if(.not.intorb) then
1605      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
1606     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
1607     &+nvab) * (h9b_2 - 1)))))
1608      else
1609      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1610     &(p6b_2
1611     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
1612     &+nvab) * (h9b_2 - 1)))),p6b_2,p8b_2,h7b_2,h9b_2)
1613      end if
1614      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
1615     &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1)
1616     &,3,1,2,4,1.0d0)
1617      END IF
1618      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_3_2',6,MA_ER
1619     &R)
1620      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1621     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1622     &t),dima_sort)
1623      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_3_2',7,
1624     &MA_ERR)
1625      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_3_2',8,
1626     &MA_ERR)
1627      END IF
1628      END IF
1629      END IF
1630      END DO
1631      END DO
1632      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1633     &ipccsd_x2_1_3_2',9,MA_ERR)
1634      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
1635     &,int_mb(k_range+h9b-1),2,1,1.0d0)
1636      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
1637     & noab - 1 + nvab * (h9b - 1)))
1638      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_3_2',10,MA_E
1639     &RR)
1640      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_3_2',11
1641     &,MA_ERR)
1642      END IF
1643      END IF
1644      END IF
1645      next = NXTASK(nprocs, 1)
1646      END IF
1647      count = count + 1
1648      END DO
1649      END DO
1650      next = NXTASK(-nprocs, 1)
1651      call GA_SYNC()
1652      RETURN
1653      END
1654      SUBROUTINE ipccsd_x2_1_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
1655     &set)
1656C     $Id$
1657C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1658C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1659C     i1 ( h9 p3 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i2 ( h6 h9 h2 p5 )_v
1660      IMPLICIT NONE
1661#include "global.fh"
1662#include "mafdecls.fh"
1663#include "sym.fh"
1664#include "errquit.fh"
1665#include "tce.fh"
1666      INTEGER d_a
1667      INTEGER k_a_offset
1668      INTEGER d_b
1669      INTEGER k_b_offset
1670      INTEGER d_c
1671      INTEGER k_c_offset
1672      INTEGER NXTASK
1673      INTEGER next
1674      INTEGER nprocs
1675      INTEGER count
1676      INTEGER p3b
1677      INTEGER h9b
1678      INTEGER h1b
1679      INTEGER h2b
1680      INTEGER dimc
1681      INTEGER l_c_sort
1682      INTEGER k_c_sort
1683      INTEGER p5b
1684      INTEGER h6b
1685      INTEGER p3b_1
1686      INTEGER p5b_1
1687      INTEGER h1b_1
1688      INTEGER h6b_1
1689      INTEGER h9b_2
1690      INTEGER h6b_2
1691      INTEGER h2b_2
1692      INTEGER p5b_2
1693      INTEGER dim_common
1694      INTEGER dima_sort
1695      INTEGER dima
1696      INTEGER dimb_sort
1697      INTEGER dimb
1698      INTEGER l_a_sort
1699      INTEGER k_a_sort
1700      INTEGER l_a
1701      INTEGER k_a
1702      INTEGER l_b_sort
1703      INTEGER k_b_sort
1704      INTEGER l_b
1705      INTEGER k_b
1706      INTEGER l_c
1707      INTEGER k_c
1708      EXTERNAL NXTASK
1709      nprocs = GA_NNODES()
1710      count = 0
1711      next = NXTASK(nprocs, 1)
1712      DO p3b = noab+1,noab+nvab
1713      DO h9b = 1,noab
1714      DO h1b = 1,noab
1715      DO h2b = 1,noab
1716      IF (next.eq.count) THEN
1717      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1
1718     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
1719      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
1720     &1b-1)+int_mb(k_spin+h2b-1)) THEN
1721      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
1722     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
1723     &EN
1724      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra
1725     &nge+h1b-1) * int_mb(k_range+h2b-1)
1726      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1727     & ERRQUIT('ipccsd_x2_1_4',0,MA_ERR)
1728      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1729      DO p5b = noab+1,noab+nvab
1730      DO h6b = 1,noab
1731      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
1732     &1b-1)+int_mb(k_spin+h6b-1)) THEN
1733      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
1734     &k_sym+h1b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_t) THEN
1735      CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h6b,p3b_1,p5b_1,h1b_1,h6b_1)
1736      CALL TCE_RESTRICTED_4(h9b,h6b,h2b,p5b,h9b_2,h6b_2,h2b_2,p5b_2)
1737      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1)
1738      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
1739      dima = dim_common * dima_sort
1740      dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h2b-1)
1741      dimb = dim_common * dimb_sort
1742      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1743      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1744     & ERRQUIT('ipccsd_x2_1_4',1,MA_ERR)
1745      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1746     &ipccsd_x2_1_4',2,MA_ERR)
1747      IF ((p5b .lt. p3b) .and. (h6b .lt. h1b)) THEN
1748      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
1749     & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
1750     &1 - noab - 1)))))
1751      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
1752     &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1)
1753     &,4,2,3,1,1.0d0)
1754      END IF
1755      IF ((p5b .lt. p3b) .and. (h1b .le. h6b)) THEN
1756      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
1757     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
1758     &1 - noab - 1)))))
1759      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
1760     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1)
1761     &,3,2,4,1,-1.0d0)
1762      END IF
1763      IF ((p3b .le. p5b) .and. (h6b .lt. h1b)) THEN
1764      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
1765     & - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
1766     &1 - noab - 1)))))
1767      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
1768     &,int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1)
1769     &,4,1,3,2,-1.0d0)
1770      END IF
1771      IF ((p3b .le. p5b) .and. (h1b .le. h6b)) THEN
1772      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
1773     & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
1774     &1 - noab - 1)))))
1775      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
1776     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1)
1777     &,3,1,4,2,1.0d0)
1778      END IF
1779      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_4',3,MA_ERR)
1780      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1781     & ERRQUIT('ipccsd_x2_1_4',4,MA_ERR)
1782      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1783     &ipccsd_x2_1_4',5,MA_ERR)
1784      IF ((h6b .le. h9b)) THEN
1785      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
1786     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h9b_2 - 1 + noab * (h6b_
1787     &2 - 1)))))
1788      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
1789     &,int_mb(k_range+h9b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1)
1790     &,3,2,1,4,1.0d0)
1791      END IF
1792      IF ((h9b .lt. h6b)) THEN
1793      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
1794     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h6b_2 - 1 + noab * (h9b_
1795     &2 - 1)))))
1796      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
1797     &,int_mb(k_range+h6b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1)
1798     &,3,1,2,4,-1.0d0)
1799      END IF
1800      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_4',6,MA_ERR)
1801      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1802     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1803     &t),dima_sort)
1804      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_4',7,MA
1805     &_ERR)
1806      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_4',8,MA
1807     &_ERR)
1808      END IF
1809      END IF
1810      END IF
1811      END DO
1812      END DO
1813      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1814     &ipccsd_x2_1_4',9,MA_ERR)
1815      IF ((h1b .le. h2b)) THEN
1816      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
1817     &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
1818     &,4,2,3,1,1.0d0)
1819      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
1820     & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1)))
1821     &))
1822      END IF
1823      IF ((h2b .le. h1b)) THEN
1824      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
1825     &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
1826     &,4,2,1,3,-1.0d0)
1827      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
1828     & 1 + noab * (h2b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1)))
1829     &))
1830      END IF
1831      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_4',10,MA_ERR
1832     &)
1833      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_4',11,M
1834     &A_ERR)
1835      END IF
1836      END IF
1837      END IF
1838      next = NXTASK(nprocs, 1)
1839      END IF
1840      count = count + 1
1841      END DO
1842      END DO
1843      END DO
1844      END DO
1845      next = NXTASK(-nprocs, 1)
1846      call GA_SYNC()
1847      RETURN
1848      END
1849      SUBROUTINE ipccsd_x2_1_4_1(d_a,k_a_offset,d_c,k_c_offset)
1850C     $Id$
1851C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1852C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1853C     i2 ( h6 h9 h1 p5 )_v + = 1 * v ( h6 h9 h1 p5 )_v
1854      IMPLICIT NONE
1855#include "global.fh"
1856#include "mafdecls.fh"
1857#include "sym.fh"
1858#include "errquit.fh"
1859#include "tce.fh"
1860      INTEGER d_a
1861      INTEGER k_a_offset
1862      INTEGER d_c
1863      INTEGER k_c_offset
1864      INTEGER NXTASK
1865      INTEGER next
1866      INTEGER nprocs
1867      INTEGER count
1868      INTEGER h6b
1869      INTEGER h9b
1870      INTEGER h1b
1871      INTEGER p5b
1872      INTEGER dimc
1873      INTEGER h6b_1
1874      INTEGER h9b_1
1875      INTEGER h1b_1
1876      INTEGER p5b_1
1877      INTEGER dim_common
1878      INTEGER dima_sort
1879      INTEGER dima
1880      INTEGER l_a_sort
1881      INTEGER k_a_sort
1882      INTEGER l_a
1883      INTEGER k_a
1884      INTEGER l_c
1885      INTEGER k_c
1886      EXTERNAL NXTASK
1887      nprocs = GA_NNODES()
1888      count = 0
1889      next = NXTASK(nprocs, 1)
1890      DO h6b = 1,noab
1891      DO h9b = h6b,noab
1892      DO h1b = 1,noab
1893      DO p5b = noab+1,noab+nvab
1894      IF (next.eq.count) THEN
1895      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1
1896     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
1897      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
1898     &1b-1)+int_mb(k_spin+p5b-1)) THEN
1899      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
1900     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
1901      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra
1902     &nge+h1b-1) * int_mb(k_range+p5b-1)
1903      CALL TCE_RESTRICTED_4(h6b,h9b,h1b,p5b,h6b_1,h9b_1,h1b_1,p5b_1)
1904      dim_common = 1
1905      dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h9b-1) * int_mb
1906     &(k_range+h1b-1) * int_mb(k_range+p5b-1)
1907      dima = dim_common * dima_sort
1908      IF (dima .gt. 0) THEN
1909      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1910     & ERRQUIT('ipccsd_x2_1_4_1',0,MA_ERR)
1911      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1912     &ipccsd_x2_1_4_1',1,MA_ERR)
1913      IF ((h1b .le. p5b)) THEN
1914      if(.not.intorb) then
1915      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
1916     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h9b_1 - 1 + (noab
1917     &+nvab) * (h6b_1 - 1)))))
1918      else
1919      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
1920     &(p5b_1
1921     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h9b_1 - 1 + (noab
1922     &+nvab) * (h6b_1 - 1)))),p5b_1,h1b_1,h9b_1,h6b_1)
1923      end if
1924      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1)
1925     &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1)
1926     &,4,3,2,1,1.0d0)
1927      END IF
1928      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_4_1',2,MA_ER
1929     &R)
1930      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1931     &ipccsd_x2_1_4_1',3,MA_ERR)
1932      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
1933     &,int_mb(k_range+h1b-1),int_mb(k_range+h9b-1),int_mb(k_range+h6b-1)
1934     &,4,3,2,1,1.0d0)
1935      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
1936     & noab - 1 + nvab * (h1b - 1 + noab * (h9b - 1 + noab * (h6b - 1)))
1937     &))
1938      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_4_1',4,MA_ER
1939     &R)
1940      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_4_1',5,
1941     &MA_ERR)
1942      END IF
1943      END IF
1944      END IF
1945      END IF
1946      next = NXTASK(nprocs, 1)
1947      END IF
1948      count = count + 1
1949      END DO
1950      END DO
1951      END DO
1952      END DO
1953      next = NXTASK(-nprocs, 1)
1954      call GA_SYNC()
1955      RETURN
1956      END
1957      SUBROUTINE OFFSET_ipccsd_x2_1_4_1(l_a_offset,k_a_offset,size)
1958C     $Id$
1959C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1960C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1961C     i2 ( h6 h9 h1 p5 )_v
1962      IMPLICIT NONE
1963#include "global.fh"
1964#include "mafdecls.fh"
1965#include "sym.fh"
1966#include "errquit.fh"
1967#include "tce.fh"
1968      INTEGER l_a_offset
1969      INTEGER k_a_offset
1970      INTEGER size
1971      INTEGER length
1972      INTEGER addr
1973      INTEGER h6b
1974      INTEGER h9b
1975      INTEGER h1b
1976      INTEGER p5b
1977      length = 0
1978      DO h6b = 1,noab
1979      DO h9b = h6b,noab
1980      DO h1b = 1,noab
1981      DO p5b = noab+1,noab+nvab
1982      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
1983     &1b-1)+int_mb(k_spin+p5b-1)) THEN
1984      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
1985     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
1986      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1
1987     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
1988      length = length + 1
1989      END IF
1990      END IF
1991      END IF
1992      END DO
1993      END DO
1994      END DO
1995      END DO
1996      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
1997     &set)) CALL ERRQUIT('ipccsd_x2_1_4_1',0,MA_ERR)
1998      int_mb(k_a_offset) = length
1999      addr = 0
2000      size = 0
2001      DO h6b = 1,noab
2002      DO h9b = h6b,noab
2003      DO h1b = 1,noab
2004      DO p5b = noab+1,noab+nvab
2005      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
2006     &1b-1)+int_mb(k_spin+p5b-1)) THEN
2007      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
2008     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
2009      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1
2010     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
2011      addr = addr + 1
2012      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab
2013     &* (h9b - 1 + noab * (h6b - 1)))
2014      int_mb(k_a_offset+length+addr) = size
2015      size = size + int_mb(k_range+h6b-1) * int_mb(k_range+h9b-1) * int_
2016     &mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
2017      END IF
2018      END IF
2019      END IF
2020      END DO
2021      END DO
2022      END DO
2023      END DO
2024      RETURN
2025      END
2026      SUBROUTINE ipccsd_x2_1_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
2027     &ffset)
2028C     $Id$
2029C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2030C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2031C     i2 ( h6 h9 h1 p5 )_vt + = -1 * Sum ( p7 ) * t ( p7 h1 )_t * v ( h6 h9 p5 p7 )_v
2032      IMPLICIT NONE
2033#include "global.fh"
2034#include "mafdecls.fh"
2035#include "sym.fh"
2036#include "errquit.fh"
2037#include "tce.fh"
2038      INTEGER d_a
2039      INTEGER k_a_offset
2040      INTEGER d_b
2041      INTEGER k_b_offset
2042      INTEGER d_c
2043      INTEGER k_c_offset
2044      INTEGER NXTASK
2045      INTEGER next
2046      INTEGER nprocs
2047      INTEGER count
2048      INTEGER h6b
2049      INTEGER h9b
2050      INTEGER h1b
2051      INTEGER p5b
2052      INTEGER dimc
2053      INTEGER l_c_sort
2054      INTEGER k_c_sort
2055      INTEGER p7b
2056      INTEGER p7b_1
2057      INTEGER h1b_1
2058      INTEGER h6b_2
2059      INTEGER h9b_2
2060      INTEGER p5b_2
2061      INTEGER p7b_2
2062      INTEGER dim_common
2063      INTEGER dima_sort
2064      INTEGER dima
2065      INTEGER dimb_sort
2066      INTEGER dimb
2067      INTEGER l_a_sort
2068      INTEGER k_a_sort
2069      INTEGER l_a
2070      INTEGER k_a
2071      INTEGER l_b_sort
2072      INTEGER k_b_sort
2073      INTEGER l_b
2074      INTEGER k_b
2075      INTEGER l_c
2076      INTEGER k_c
2077      EXTERNAL NXTASK
2078      nprocs = GA_NNODES()
2079      count = 0
2080      next = NXTASK(nprocs, 1)
2081      DO h6b = 1,noab
2082      DO h9b = h6b,noab
2083      DO h1b = 1,noab
2084      DO p5b = noab+1,noab+nvab
2085      IF (next.eq.count) THEN
2086      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1
2087     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
2088      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
2089     &1b-1)+int_mb(k_spin+p5b-1)) THEN
2090      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
2091     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
2092     &EN
2093      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra
2094     &nge+h1b-1) * int_mb(k_range+p5b-1)
2095      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
2096     & ERRQUIT('ipccsd_x2_1_4_2',0,MA_ERR)
2097      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
2098      DO p7b = noab+1,noab+nvab
2099      IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2100      IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
2101     &EN
2102      CALL TCE_RESTRICTED_2(p7b,h1b,p7b_1,h1b_1)
2103      CALL TCE_RESTRICTED_4(h6b,h9b,p5b,p7b,h6b_2,h9b_2,p5b_2,p7b_2)
2104      dim_common = int_mb(k_range+p7b-1)
2105      dima_sort = int_mb(k_range+h1b-1)
2106      dima = dim_common * dima_sort
2107      dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+h9b-1) * int_mb
2108     &(k_range+p5b-1)
2109      dimb = dim_common * dimb_sort
2110      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2111      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2112     & ERRQUIT('ipccsd_x2_1_4_2',1,MA_ERR)
2113      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2114     &ipccsd_x2_1_4_2',2,MA_ERR)
2115      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
2116     & - 1 + noab * (p7b_1 - noab - 1)))
2117      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
2118     &,int_mb(k_range+h1b-1),2,1,1.0d0)
2119      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_4_2',3,MA_ER
2120     &R)
2121      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
2122     & ERRQUIT('ipccsd_x2_1_4_2',4,MA_ERR)
2123      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2124     &ipccsd_x2_1_4_2',5,MA_ERR)
2125      IF ((p7b .lt. p5b)) THEN
2126      if(.not.intorb) then
2127      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
2128     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
2129     &+nvab) * (h6b_2 - 1)))))
2130      else
2131      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2132     &(p5b_2
2133     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
2134     &+nvab) * (h6b_2 - 1)))),p5b_2,p7b_2,h9b_2,h6b_2)
2135      end if
2136      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
2137     &,int_mb(k_range+h9b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1)
2138     &,4,2,1,3,-1.0d0)
2139      END IF
2140      IF ((p5b .le. p7b)) THEN
2141      if(.not.intorb) then
2142      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
2143     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
2144     &+nvab) * (h6b_2 - 1)))))
2145      else
2146      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2147     &(p7b_2
2148     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
2149     &+nvab) * (h6b_2 - 1)))),p7b_2,p5b_2,h9b_2,h6b_2)
2150      end if
2151      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
2152     &,int_mb(k_range+h9b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1)
2153     &,3,2,1,4,1.0d0)
2154      END IF
2155      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_4_2',6,MA_ER
2156     &R)
2157      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
2158     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
2159     &t),dima_sort)
2160      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_4_2',7,
2161     &MA_ERR)
2162      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_4_2',8,
2163     &MA_ERR)
2164      END IF
2165      END IF
2166      END IF
2167      END DO
2168      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2169     &ipccsd_x2_1_4_2',9,MA_ERR)
2170      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
2171     &,int_mb(k_range+h9b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1)
2172     &,3,2,4,1,-1.0d0)
2173      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
2174     & noab - 1 + nvab * (h1b - 1 + noab * (h9b - 1 + noab * (h6b - 1)))
2175     &))
2176      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_4_2',10,MA_E
2177     &RR)
2178      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_4_2',11
2179     &,MA_ERR)
2180      END IF
2181      END IF
2182      END IF
2183      next = NXTASK(nprocs, 1)
2184      END IF
2185      count = count + 1
2186      END DO
2187      END DO
2188      END DO
2189      END DO
2190      next = NXTASK(-nprocs, 1)
2191      call GA_SYNC()
2192      RETURN
2193      END
2194      SUBROUTINE ipccsd_x2_1_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
2195     &set)
2196C     $Id$
2197C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2198C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2199C     i1 ( h9 p3 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 p3 p5 p6 )_v
2200      IMPLICIT NONE
2201#include "global.fh"
2202#include "mafdecls.fh"
2203#include "sym.fh"
2204#include "errquit.fh"
2205#include "tce.fh"
2206      INTEGER d_a
2207      INTEGER k_a_offset
2208      INTEGER d_b
2209      INTEGER k_b_offset
2210      INTEGER d_c
2211      INTEGER k_c_offset
2212      INTEGER NXTASK
2213      INTEGER next
2214      INTEGER nprocs
2215      INTEGER count
2216      INTEGER p3b
2217      INTEGER h9b
2218      INTEGER h1b
2219      INTEGER h2b
2220      INTEGER dimc
2221      INTEGER l_c_sort
2222      INTEGER k_c_sort
2223      INTEGER p5b
2224      INTEGER p6b
2225      INTEGER p5b_1
2226      INTEGER p6b_1
2227      INTEGER h1b_1
2228      INTEGER h2b_1
2229      INTEGER p3b_2
2230      INTEGER h9b_2
2231      INTEGER p5b_2
2232      INTEGER p6b_2
2233      INTEGER dim_common
2234      INTEGER dima_sort
2235      INTEGER dima
2236      INTEGER dimb_sort
2237      INTEGER dimb
2238      INTEGER l_a_sort
2239      INTEGER k_a_sort
2240      INTEGER l_a
2241      INTEGER k_a
2242      INTEGER l_b_sort
2243      INTEGER k_b_sort
2244      INTEGER l_b
2245      INTEGER k_b
2246      INTEGER nsuperp(2)
2247      INTEGER isuperp
2248      INTEGER l_c
2249      INTEGER k_c
2250      DOUBLE PRECISION FACTORIAL
2251      EXTERNAL NXTASK
2252      EXTERNAL FACTORIAL
2253      nprocs = GA_NNODES()
2254      count = 0
2255      next = NXTASK(nprocs, 1)
2256      DO p3b = noab+1,noab+nvab
2257      DO h9b = 1,noab
2258      DO h1b = 1,noab
2259      DO h2b = h1b,noab
2260      IF (next.eq.count) THEN
2261      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1
2262     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
2263      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h
2264     &1b-1)+int_mb(k_spin+h2b-1)) THEN
2265      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
2266     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
2267     &EN
2268      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra
2269     &nge+h1b-1) * int_mb(k_range+h2b-1)
2270      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
2271     & ERRQUIT('ipccsd_x2_1_5',0,MA_ERR)
2272      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
2273      DO p5b = noab+1,noab+nvab
2274      DO p6b = p5b,noab+nvab
2275      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h
2276     &1b-1)+int_mb(k_spin+h2b-1)) THEN
2277      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb(
2278     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
2279      CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1)
2280      CALL TCE_RESTRICTED_4(p3b,h9b,p5b,p6b,p3b_2,h9b_2,p5b_2,p6b_2)
2281      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1)
2282      dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
2283      dima = dim_common * dima_sort
2284      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h9b-1)
2285      dimb = dim_common * dimb_sort
2286      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2287      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2288     & ERRQUIT('ipccsd_x2_1_5',1,MA_ERR)
2289      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2290     &ipccsd_x2_1_5',2,MA_ERR)
2291      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
2292     & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_
2293     &1 - noab - 1)))))
2294      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
2295     &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
2296     &,4,3,2,1,1.0d0)
2297      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_1_5',3,MA_ERR)
2298      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
2299     & ERRQUIT('ipccsd_x2_1_5',4,MA_ERR)
2300      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2301     &ipccsd_x2_1_5',5,MA_ERR)
2302      IF ((h9b .le. p3b)) THEN
2303      if(.not.intorb) then
2304      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
2305     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
2306     &+nvab) * (h9b_2 - 1)))))
2307      else
2308      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2309     &(p6b_2
2310     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
2311     &+nvab) * (h9b_2 - 1)))),p6b_2,p5b_2,p3b_2,h9b_2)
2312      end if
2313      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
2314     &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1)
2315     &,1,2,4,3,1.0d0)
2316      END IF
2317      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_1_5',6,MA_ERR)
2318      nsuperp(1) = 1
2319      nsuperp(2) = 1
2320      isuperp = 1
2321      IF (p5b .eq. p6b) THEN
2322      nsuperp(isuperp) = nsuperp(isuperp) + 1
2323      ELSE
2324      isuperp = isuperp + 1
2325      END IF
2326      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
2327     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
2328     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
2329      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_1_5',7,MA
2330     &_ERR)
2331      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_1_5',8,MA
2332     &_ERR)
2333      END IF
2334      END IF
2335      END IF
2336      END DO
2337      END DO
2338      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2339     &ipccsd_x2_1_5',9,MA_ERR)
2340      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h9b-1)
2341     &,int_mb(k_range+p3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1)
2342     &,2,1,4,3,1.0d0/2.0d0)
2343      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
2344     & 1 + noab * (h1b - 1 + noab * (h9b - 1 + noab * (p3b - noab - 1)))
2345     &))
2346      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_1_5',10,MA_ERR
2347     &)
2348      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_1_5',11,M
2349     &A_ERR)
2350      END IF
2351      END IF
2352      END IF
2353      next = NXTASK(nprocs, 1)
2354      END IF
2355      count = count + 1
2356      END DO
2357      END DO
2358      END DO
2359      END DO
2360      next = NXTASK(-nprocs, 1)
2361      call GA_SYNC()
2362      RETURN
2363      END
2364      SUBROUTINE ipccsd_x2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
2365     &t)
2366C     $Id$
2367C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2368C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2369C     i0 ( p3 p4 h1 h2 )_xf + = -1 * P( 2 ) * Sum ( h8 ) * x ( p3 p4 h1 h8 )_x * i1 ( h8 h2 )_f
2370      IMPLICIT NONE
2371#include "global.fh"
2372#include "mafdecls.fh"
2373#include "sym.fh"
2374#include "errquit.fh"
2375#include "tce.fh"
2376      INTEGER d_a
2377      INTEGER k_a_offset
2378      INTEGER d_b
2379      INTEGER k_b_offset
2380      INTEGER d_c
2381      INTEGER k_c_offset
2382      INTEGER NXTASK
2383      INTEGER next
2384      INTEGER nprocs
2385      INTEGER count
2386      INTEGER p3b
2387      INTEGER p4b
2388      INTEGER h1b
2389      INTEGER h2b
2390      INTEGER dimc
2391      INTEGER l_c_sort
2392      INTEGER k_c_sort
2393      INTEGER h8b
2394      INTEGER p3b_1
2395      INTEGER p4b_1
2396      INTEGER h1b_1
2397      INTEGER h8b_1
2398      INTEGER h8b_2
2399      INTEGER h2b_2
2400      INTEGER dim_common
2401      INTEGER dima_sort
2402      INTEGER dima
2403      INTEGER dimb_sort
2404      INTEGER dimb
2405      INTEGER l_a_sort
2406      INTEGER k_a_sort
2407      INTEGER l_a
2408      INTEGER k_a
2409      INTEGER l_b_sort
2410      INTEGER k_b_sort
2411      INTEGER l_b
2412      INTEGER k_b
2413      INTEGER l_c
2414      INTEGER k_c
2415      EXTERNAL NXTASK
2416      nprocs = GA_NNODES()
2417      count = 0
2418      next = NXTASK(nprocs, 1)
2419      DO p3b = noab+1,noab+nvab
2420ckbn      DO p4b = p3b,noab+nvab
2421      DO p4b = 1,1
2422      DO h1b = 1,noab
2423      DO h2b = 1,noab
2424      IF (next.eq.count) THEN
2425ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
2426ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
2427      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ ip_unused_spin
2428     & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
2429ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
2430ckbn     &1b-1)+int_mb(k_spin+h2b-1)) THEN
2431      IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h
2432     &1b-1)+int_mb(k_spin+h2b-1)) THEN
2433ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
2434ckbn     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_f)) TH
2435ckbn     &EN
2436      IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb(
2437     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_f)) TH
2438     &EN
2439ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
2440ckbn     &nge+h1b-1) * int_mb(k_range+h2b-1)
2441      dimc = int_mb(k_range+p3b-1) * 1 * int_mb(k_ra
2442     &nge+h1b-1) * int_mb(k_range+h2b-1)
2443      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
2444     & ERRQUIT('ipccsd_x2_2',0,MA_ERR)
2445      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
2446      DO h8b = 1,noab
2447ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
2448ckbn     &1b-1)+int_mb(k_spin+h8b-1)) THEN
2449      IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h
2450     &1b-1)+int_mb(k_spin+h8b-1)) THEN
2451ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
2452ckbn     &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_x) THEN
2453      IF (ieor(int_mb(k_sym+p3b-1),ieor( ip_unused_sym ,ieor(int_mb(
2454     &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_x) THEN
2455      CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h8b,p3b_1,p4b_1,h1b_1,h8b_1)
2456      CALL TCE_RESTRICTED_2(h8b,h2b,h8b_2,h2b_2)
2457      dim_common = int_mb(k_range+h8b-1)
2458ckbn      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb
2459ckbn     &(k_range+h1b-1)
2460      dima_sort = int_mb(k_range+p3b-1) * 1 * int_mb
2461     &(k_range+h1b-1)
2462      dima = dim_common * dima_sort
2463      dimb_sort = int_mb(k_range+h2b-1)
2464      dimb = dim_common * dimb_sort
2465      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2466      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2467     & ERRQUIT('ipccsd_x2_2',1,MA_ERR)
2468      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2469     &ipccsd_x2_2',2,MA_ERR)
2470      IF ((h8b .lt. h1b)) THEN
2471      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
2472     & - 1 + noab * (h8b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
2473     &1 - noab - 1)))))
2474ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
2475ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1)
2476ckbn     &,4,2,1,3,-1.0d0)
2477      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
2478     &,1,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1)
2479     &,4,2,1,3,-1.0d0)
2480      END IF
2481      IF ((h1b .le. h8b)) THEN
2482      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
2483     & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
2484     &1 - noab - 1)))))
2485ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
2486ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1)
2487ckbn     &,3,2,1,4,1.0d0)
2488      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
2489     &,1,int_mb(k_range+h1b-1),int_mb(k_range+h8b-1)
2490     &,3,2,1,4,1.0d0)
2491      END IF
2492      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2',3,MA_ERR)
2493      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
2494     & ERRQUIT('ipccsd_x2_2',4,MA_ERR)
2495      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2496     &ipccsd_x2_2',5,MA_ERR)
2497      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
2498     & - 1 + noab * (h8b_2 - 1)))
2499      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
2500     &,int_mb(k_range+h2b-1),2,1,1.0d0)
2501      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_2',6,MA_ERR)
2502      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
2503     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
2504     &t),dima_sort)
2505      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_2',7,MA_E
2506     &RR)
2507      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2',8,MA_E
2508     &RR)
2509      END IF
2510      END IF
2511      END IF
2512      END DO
2513      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2514     &ipccsd_x2_2',9,MA_ERR)
2515      IF ((h1b .le. h2b)) THEN
2516ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
2517ckbn     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
2518ckbn     &,4,3,2,1,-1.0d0)
2519      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
2520     &,int_mb(k_range+h1b-1),1,int_mb(k_range+p3b-1)
2521     &,4,3,2,1,-1.0d0)
2522      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
2523     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
2524     & - 1)))))
2525      END IF
2526      IF ((h2b .le. h1b)) THEN
2527ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
2528ckbn     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
2529ckbn     &,4,3,1,2,1.0d0)
2530      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
2531     &,int_mb(k_range+h1b-1),1,int_mb(k_range+p3b-1)
2532     &,4,3,1,2,1.0d0)
2533      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
2534     & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
2535     & - 1)))))
2536      END IF
2537      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2',10,MA_ERR)
2538      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_2',11,MA_
2539     &ERR)
2540      END IF
2541      END IF
2542      END IF
2543      next = NXTASK(nprocs, 1)
2544      END IF
2545      count = count + 1
2546      END DO
2547      END DO
2548      END DO
2549      END DO
2550      next = NXTASK(-nprocs, 1)
2551      call GA_SYNC()
2552      RETURN
2553      END
2554      SUBROUTINE ipccsd_x2_2_1(d_a,k_a_offset,d_c,k_c_offset)
2555C     $Id$
2556C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2557C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2558C     i1 ( h8 h1 )_f + = 1 * f ( h8 h1 )_f
2559      IMPLICIT NONE
2560#include "global.fh"
2561#include "mafdecls.fh"
2562#include "sym.fh"
2563#include "errquit.fh"
2564#include "tce.fh"
2565      INTEGER d_a
2566      INTEGER k_a_offset
2567      INTEGER d_c
2568      INTEGER k_c_offset
2569      INTEGER NXTASK
2570      INTEGER next
2571      INTEGER nprocs
2572      INTEGER count
2573      INTEGER h8b
2574      INTEGER h1b
2575      INTEGER dimc
2576      INTEGER h8b_1
2577      INTEGER h1b_1
2578      INTEGER dim_common
2579      INTEGER dima_sort
2580      INTEGER dima
2581      INTEGER l_a_sort
2582      INTEGER k_a_sort
2583      INTEGER l_a
2584      INTEGER k_a
2585      INTEGER l_c
2586      INTEGER k_c
2587      EXTERNAL NXTASK
2588      nprocs = GA_NNODES()
2589      count = 0
2590      next = NXTASK(nprocs, 1)
2591      DO h8b = 1,noab
2592      DO h1b = 1,noab
2593      IF (next.eq.count) THEN
2594      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
2595     &).ne.4)) THEN
2596      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2597      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
2598     &EN
2599      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
2600      CALL TCE_RESTRICTED_2(h8b,h1b,h8b_1,h1b_1)
2601      dim_common = 1
2602      dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
2603      dima = dim_common * dima_sort
2604      IF (dima .gt. 0) THEN
2605      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2606     & ERRQUIT('ipccsd_x2_2_1',0,MA_ERR)
2607      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2608     &ipccsd_x2_2_1',1,MA_ERR)
2609      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
2610     & - 1 + (noab+nvab) * (h8b_1 - 1)))
2611      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1)
2612     &,int_mb(k_range+h1b-1),2,1,1.0d0)
2613      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_1',2,MA_ERR)
2614      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2615     &ipccsd_x2_2_1',3,MA_ERR)
2616      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
2617     &,int_mb(k_range+h8b-1),2,1,1.0d0)
2618      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
2619     & 1 + noab * (h8b - 1)))
2620      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_1',4,MA_ERR)
2621      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_1',5,MA
2622     &_ERR)
2623      END IF
2624      END IF
2625      END IF
2626      END IF
2627      next = NXTASK(nprocs, 1)
2628      END IF
2629      count = count + 1
2630      END DO
2631      END DO
2632      next = NXTASK(-nprocs, 1)
2633      call GA_SYNC()
2634      RETURN
2635      END
2636      SUBROUTINE OFFSET_ipccsd_x2_2_1(l_a_offset,k_a_offset,size)
2637C     $Id$
2638C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2639C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2640C     i1 ( h8 h1 )_f
2641      IMPLICIT NONE
2642#include "global.fh"
2643#include "mafdecls.fh"
2644#include "sym.fh"
2645#include "errquit.fh"
2646#include "tce.fh"
2647      INTEGER l_a_offset
2648      INTEGER k_a_offset
2649      INTEGER size
2650      INTEGER length
2651      INTEGER addr
2652      INTEGER h8b
2653      INTEGER h1b
2654      length = 0
2655      DO h8b = 1,noab
2656      DO h1b = 1,noab
2657      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2658      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
2659     &EN
2660      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
2661     &).ne.4)) THEN
2662      length = length + 1
2663      END IF
2664      END IF
2665      END IF
2666      END DO
2667      END DO
2668      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
2669     &set)) CALL ERRQUIT('ipccsd_x2_2_1',0,MA_ERR)
2670      int_mb(k_a_offset) = length
2671      addr = 0
2672      size = 0
2673      DO h8b = 1,noab
2674      DO h1b = 1,noab
2675      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2676      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
2677     &EN
2678      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
2679     &).ne.4)) THEN
2680      addr = addr + 1
2681      int_mb(k_a_offset+addr) = h1b - 1 + noab * (h8b - 1)
2682      int_mb(k_a_offset+length+addr) = size
2683      size = size + int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
2684      END IF
2685      END IF
2686      END IF
2687      END DO
2688      END DO
2689      RETURN
2690      END
2691      SUBROUTINE ipccsd_x2_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
2692     &set)
2693C     $Id$
2694C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2695C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2696C     i1 ( h8 h1 )_ft + = 1 * Sum ( p9 ) * t ( p9 h1 )_t * i2 ( h8 p9 )_f
2697      IMPLICIT NONE
2698#include "global.fh"
2699#include "mafdecls.fh"
2700#include "sym.fh"
2701#include "errquit.fh"
2702#include "tce.fh"
2703      INTEGER d_a
2704      INTEGER k_a_offset
2705      INTEGER d_b
2706      INTEGER k_b_offset
2707      INTEGER d_c
2708      INTEGER k_c_offset
2709      INTEGER NXTASK
2710      INTEGER next
2711      INTEGER nprocs
2712      INTEGER count
2713      INTEGER h8b
2714      INTEGER h1b
2715      INTEGER dimc
2716      INTEGER l_c_sort
2717      INTEGER k_c_sort
2718      INTEGER p9b
2719      INTEGER p9b_1
2720      INTEGER h1b_1
2721      INTEGER h8b_2
2722      INTEGER p9b_2
2723      INTEGER dim_common
2724      INTEGER dima_sort
2725      INTEGER dima
2726      INTEGER dimb_sort
2727      INTEGER dimb
2728      INTEGER l_a_sort
2729      INTEGER k_a_sort
2730      INTEGER l_a
2731      INTEGER k_a
2732      INTEGER l_b_sort
2733      INTEGER k_b_sort
2734      INTEGER l_b
2735      INTEGER k_b
2736      INTEGER l_c
2737      INTEGER k_c
2738      EXTERNAL NXTASK
2739      nprocs = GA_NNODES()
2740      count = 0
2741      next = NXTASK(nprocs, 1)
2742      DO h8b = 1,noab
2743      DO h1b = 1,noab
2744      IF (next.eq.count) THEN
2745      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
2746     &).ne.4)) THEN
2747      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2748      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
2749     &f,irrep_t)) THEN
2750      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
2751      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
2752     & ERRQUIT('ipccsd_x2_2_2',0,MA_ERR)
2753      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
2754      DO p9b = noab+1,noab+nvab
2755      IF (int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2756      IF (ieor(int_mb(k_sym+p9b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
2757     &EN
2758      CALL TCE_RESTRICTED_2(p9b,h1b,p9b_1,h1b_1)
2759      CALL TCE_RESTRICTED_2(h8b,p9b,h8b_2,p9b_2)
2760      dim_common = int_mb(k_range+p9b-1)
2761      dima_sort = int_mb(k_range+h1b-1)
2762      dima = dim_common * dima_sort
2763      dimb_sort = int_mb(k_range+h8b-1)
2764      dimb = dim_common * dimb_sort
2765      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2766      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2767     & ERRQUIT('ipccsd_x2_2_2',1,MA_ERR)
2768      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2769     &ipccsd_x2_2_2',2,MA_ERR)
2770      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
2771     & - 1 + noab * (p9b_1 - noab - 1)))
2772      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1)
2773     &,int_mb(k_range+h1b-1),2,1,1.0d0)
2774      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_2',3,MA_ERR)
2775      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
2776     & ERRQUIT('ipccsd_x2_2_2',4,MA_ERR)
2777      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2778     &ipccsd_x2_2_2',5,MA_ERR)
2779      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
2780     & - noab - 1 + nvab * (h8b_2 - 1)))
2781      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
2782     &,int_mb(k_range+p9b-1),1,2,1.0d0)
2783      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_2_2',6,MA_ERR)
2784      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
2785     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
2786     &t),dima_sort)
2787      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_2_2',7,MA
2788     &_ERR)
2789      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_2',8,MA
2790     &_ERR)
2791      END IF
2792      END IF
2793      END IF
2794      END DO
2795      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2796     &ipccsd_x2_2_2',9,MA_ERR)
2797      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1)
2798     &,int_mb(k_range+h1b-1),1,2,1.0d0)
2799      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
2800     & 1 + noab * (h8b - 1)))
2801      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_2',10,MA_ERR
2802     &)
2803      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_2_2',11,M
2804     &A_ERR)
2805      END IF
2806      END IF
2807      END IF
2808      next = NXTASK(nprocs, 1)
2809      END IF
2810      count = count + 1
2811      END DO
2812      END DO
2813      next = NXTASK(-nprocs, 1)
2814      call GA_SYNC()
2815      RETURN
2816      END
2817      SUBROUTINE ipccsd_x2_2_2_1(d_a,k_a_offset,d_c,k_c_offset)
2818C     $Id$
2819C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2820C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2821C     i2 ( h8 p9 )_f + = 1 * f ( h8 p9 )_f
2822      IMPLICIT NONE
2823#include "global.fh"
2824#include "mafdecls.fh"
2825#include "sym.fh"
2826#include "errquit.fh"
2827#include "tce.fh"
2828      INTEGER d_a
2829      INTEGER k_a_offset
2830      INTEGER d_c
2831      INTEGER k_c_offset
2832      INTEGER NXTASK
2833      INTEGER next
2834      INTEGER nprocs
2835      INTEGER count
2836      INTEGER h8b
2837      INTEGER p9b
2838      INTEGER dimc
2839      INTEGER h8b_1
2840      INTEGER p9b_1
2841      INTEGER dim_common
2842      INTEGER dima_sort
2843      INTEGER dima
2844      INTEGER l_a_sort
2845      INTEGER k_a_sort
2846      INTEGER l_a
2847      INTEGER k_a
2848      INTEGER l_c
2849      INTEGER k_c
2850      EXTERNAL NXTASK
2851      nprocs = GA_NNODES()
2852      count = 0
2853      next = NXTASK(nprocs, 1)
2854      DO h8b = 1,noab
2855      DO p9b = noab+1,noab+nvab
2856      IF (next.eq.count) THEN
2857      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p9b-1
2858     &).ne.4)) THEN
2859      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p9b-1)) THEN
2860      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p9b-1)) .eq. irrep_f) TH
2861     &EN
2862      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p9b-1)
2863      CALL TCE_RESTRICTED_2(h8b,p9b,h8b_1,p9b_1)
2864      dim_common = 1
2865      dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p9b-1)
2866      dima = dim_common * dima_sort
2867      IF (dima .gt. 0) THEN
2868      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
2869     & ERRQUIT('ipccsd_x2_2_2_1',0,MA_ERR)
2870      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2871     &ipccsd_x2_2_2_1',1,MA_ERR)
2872      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p9b_1
2873     & - 1 + (noab+nvab) * (h8b_1 - 1)))
2874      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1)
2875     &,int_mb(k_range+p9b-1),2,1,1.0d0)
2876      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_2_1',2,MA_ER
2877     &R)
2878      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2879     &ipccsd_x2_2_2_1',3,MA_ERR)
2880      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p9b-1)
2881     &,int_mb(k_range+h8b-1),2,1,1.0d0)
2882      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b -
2883     & noab - 1 + nvab * (h8b - 1)))
2884      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_2_1',4,MA_ER
2885     &R)
2886      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_2_1',5,
2887     &MA_ERR)
2888      END IF
2889      END IF
2890      END IF
2891      END IF
2892      next = NXTASK(nprocs, 1)
2893      END IF
2894      count = count + 1
2895      END DO
2896      END DO
2897      next = NXTASK(-nprocs, 1)
2898      call GA_SYNC()
2899      RETURN
2900      END
2901      SUBROUTINE OFFSET_ipccsd_x2_2_2_1(l_a_offset,k_a_offset,size)
2902C     $Id$
2903C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2904C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2905C     i2 ( h8 p9 )_f
2906      IMPLICIT NONE
2907#include "global.fh"
2908#include "mafdecls.fh"
2909#include "sym.fh"
2910#include "errquit.fh"
2911#include "tce.fh"
2912      INTEGER l_a_offset
2913      INTEGER k_a_offset
2914      INTEGER size
2915      INTEGER length
2916      INTEGER addr
2917      INTEGER h8b
2918      INTEGER p9b
2919      length = 0
2920      DO h8b = 1,noab
2921      DO p9b = noab+1,noab+nvab
2922      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p9b-1)) THEN
2923      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p9b-1)) .eq. irrep_f) TH
2924     &EN
2925      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p9b-1
2926     &).ne.4)) THEN
2927      length = length + 1
2928      END IF
2929      END IF
2930      END IF
2931      END DO
2932      END DO
2933      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
2934     &set)) CALL ERRQUIT('ipccsd_x2_2_2_1',0,MA_ERR)
2935      int_mb(k_a_offset) = length
2936      addr = 0
2937      size = 0
2938      DO h8b = 1,noab
2939      DO p9b = noab+1,noab+nvab
2940      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p9b-1)) THEN
2941      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p9b-1)) .eq. irrep_f) TH
2942     &EN
2943      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p9b-1
2944     &).ne.4)) THEN
2945      addr = addr + 1
2946      int_mb(k_a_offset+addr) = p9b - noab - 1 + nvab * (h8b - 1)
2947      int_mb(k_a_offset+length+addr) = size
2948      size = size + int_mb(k_range+h8b-1) * int_mb(k_range+p9b-1)
2949      END IF
2950      END IF
2951      END IF
2952      END DO
2953      END DO
2954      RETURN
2955      END
2956      SUBROUTINE ipccsd_x2_2_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
2957     &ffset)
2958C     $Id$
2959C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2960C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2961C     i2 ( h8 p9 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h8 p6 p9 )_v
2962      IMPLICIT NONE
2963#include "global.fh"
2964#include "mafdecls.fh"
2965#include "sym.fh"
2966#include "errquit.fh"
2967#include "tce.fh"
2968      INTEGER d_a
2969      INTEGER k_a_offset
2970      INTEGER d_b
2971      INTEGER k_b_offset
2972      INTEGER d_c
2973      INTEGER k_c_offset
2974      INTEGER NXTASK
2975      INTEGER next
2976      INTEGER nprocs
2977      INTEGER count
2978      INTEGER h8b
2979      INTEGER p9b
2980      INTEGER dimc
2981      INTEGER l_c_sort
2982      INTEGER k_c_sort
2983      INTEGER p6b
2984      INTEGER h7b
2985      INTEGER p6b_1
2986      INTEGER h7b_1
2987      INTEGER h8b_2
2988      INTEGER h7b_2
2989      INTEGER p9b_2
2990      INTEGER p6b_2
2991      INTEGER dim_common
2992      INTEGER dima_sort
2993      INTEGER dima
2994      INTEGER dimb_sort
2995      INTEGER dimb
2996      INTEGER l_a_sort
2997      INTEGER k_a_sort
2998      INTEGER l_a
2999      INTEGER k_a
3000      INTEGER l_b_sort
3001      INTEGER k_b_sort
3002      INTEGER l_b
3003      INTEGER k_b
3004      INTEGER l_c
3005      INTEGER k_c
3006      EXTERNAL NXTASK
3007      nprocs = GA_NNODES()
3008      count = 0
3009      next = NXTASK(nprocs, 1)
3010      DO h8b = 1,noab
3011      DO p9b = noab+1,noab+nvab
3012      IF (next.eq.count) THEN
3013      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p9b-1
3014     &).ne.4)) THEN
3015      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p9b-1)) THEN
3016      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p9b-1)) .eq. ieor(irrep_
3017     &v,irrep_t)) THEN
3018      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p9b-1)
3019      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3020     & ERRQUIT('ipccsd_x2_2_2_2',0,MA_ERR)
3021      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3022      DO p6b = noab+1,noab+nvab
3023      DO h7b = 1,noab
3024      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN
3025      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH
3026     &EN
3027      CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1)
3028      CALL TCE_RESTRICTED_4(h8b,h7b,p9b,p6b,h8b_2,h7b_2,p9b_2,p6b_2)
3029      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1)
3030      dima_sort = 1
3031      dima = dim_common * dima_sort
3032      dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p9b-1)
3033      dimb = dim_common * dimb_sort
3034      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
3035      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3036     & ERRQUIT('ipccsd_x2_2_2_2',1,MA_ERR)
3037      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3038     &ipccsd_x2_2_2_2',2,MA_ERR)
3039      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
3040     & - 1 + noab * (p6b_1 - noab - 1)))
3041      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
3042     &,int_mb(k_range+h7b-1),2,1,1.0d0)
3043      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_2_2',3,MA_ER
3044     &R)
3045      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
3046     & ERRQUIT('ipccsd_x2_2_2_2',4,MA_ERR)
3047      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
3048     &ipccsd_x2_2_2_2',5,MA_ERR)
3049      IF ((h7b .le. h8b) .and. (p6b .le. p9b)) THEN
3050      if(.not.intorb) then
3051      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
3052     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3053     &+nvab) * (h7b_2 - 1)))))
3054      else
3055      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3056     &(p9b_2
3057     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3058     &+nvab) * (h7b_2 - 1)))),p9b_2,p6b_2,h8b_2,h7b_2)
3059      end if
3060      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
3061     &,int_mb(k_range+h8b-1),int_mb(k_range+p6b-1),int_mb(k_range+p9b-1)
3062     &,4,2,1,3,1.0d0)
3063      END IF
3064      IF ((h7b .le. h8b) .and. (p9b .lt. p6b)) THEN
3065      if(.not.intorb) then
3066      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
3067     & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3068     &+nvab) * (h7b_2 - 1)))))
3069      else
3070      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3071     &(p6b_2
3072     & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3073     &+nvab) * (h7b_2 - 1)))),p6b_2,p9b_2,h8b_2,h7b_2)
3074      end if
3075      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
3076     &,int_mb(k_range+h8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p6b-1)
3077     &,3,2,1,4,-1.0d0)
3078      END IF
3079      IF ((h8b .lt. h7b) .and. (p6b .le. p9b)) THEN
3080      if(.not.intorb) then
3081      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
3082     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
3083     &+nvab) * (h8b_2 - 1)))))
3084      else
3085      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3086     &(p9b_2
3087     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
3088     &+nvab) * (h8b_2 - 1)))),p9b_2,p6b_2,h7b_2,h8b_2)
3089      end if
3090      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
3091     &,int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p9b-1)
3092     &,4,1,2,3,-1.0d0)
3093      END IF
3094      IF ((h8b .lt. h7b) .and. (p9b .lt. p6b)) THEN
3095      if(.not.intorb) then
3096      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
3097     & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
3098     &+nvab) * (h8b_2 - 1)))))
3099      else
3100      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3101     &(p6b_2
3102     & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
3103     &+nvab) * (h8b_2 - 1)))),p6b_2,p9b_2,h7b_2,h8b_2)
3104      end if
3105      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
3106     &,int_mb(k_range+h7b-1),int_mb(k_range+p9b-1),int_mb(k_range+p6b-1)
3107     &,3,1,2,4,1.0d0)
3108      END IF
3109      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_2_2_2',6,MA_ER
3110     &R)
3111      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
3112     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
3113     &t),dima_sort)
3114      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_2_2_2',7,
3115     &MA_ERR)
3116      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_2_2',8,
3117     &MA_ERR)
3118      END IF
3119      END IF
3120      END IF
3121      END DO
3122      END DO
3123      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3124     &ipccsd_x2_2_2_2',9,MA_ERR)
3125      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p9b-1)
3126     &,int_mb(k_range+h8b-1),2,1,1.0d0)
3127      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b -
3128     & noab - 1 + nvab * (h8b - 1)))
3129      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_2_2',10,MA_E
3130     &RR)
3131      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_2_2_2',11
3132     &,MA_ERR)
3133      END IF
3134      END IF
3135      END IF
3136      next = NXTASK(nprocs, 1)
3137      END IF
3138      count = count + 1
3139      END DO
3140      END DO
3141      next = NXTASK(-nprocs, 1)
3142      call GA_SYNC()
3143      RETURN
3144      END
3145      SUBROUTINE ipccsd_x2_2_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
3146     &set)
3147C     $Id$
3148C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3149C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3150C     i1 ( h8 h1 )_vt + = -1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 h8 h1 p5 )_v
3151      IMPLICIT NONE
3152#include "global.fh"
3153#include "mafdecls.fh"
3154#include "sym.fh"
3155#include "errquit.fh"
3156#include "tce.fh"
3157      INTEGER d_a
3158      INTEGER k_a_offset
3159      INTEGER d_b
3160      INTEGER k_b_offset
3161      INTEGER d_c
3162      INTEGER k_c_offset
3163      INTEGER NXTASK
3164      INTEGER next
3165      INTEGER nprocs
3166      INTEGER count
3167      INTEGER h8b
3168      INTEGER h1b
3169      INTEGER dimc
3170      INTEGER l_c_sort
3171      INTEGER k_c_sort
3172      INTEGER p5b
3173      INTEGER h6b
3174      INTEGER p5b_1
3175      INTEGER h6b_1
3176      INTEGER h8b_2
3177      INTEGER h6b_2
3178      INTEGER h1b_2
3179      INTEGER p5b_2
3180      INTEGER dim_common
3181      INTEGER dima_sort
3182      INTEGER dima
3183      INTEGER dimb_sort
3184      INTEGER dimb
3185      INTEGER l_a_sort
3186      INTEGER k_a_sort
3187      INTEGER l_a
3188      INTEGER k_a
3189      INTEGER l_b_sort
3190      INTEGER k_b_sort
3191      INTEGER l_b
3192      INTEGER k_b
3193      INTEGER l_c
3194      INTEGER k_c
3195      EXTERNAL NXTASK
3196      nprocs = GA_NNODES()
3197      count = 0
3198      next = NXTASK(nprocs, 1)
3199      DO h8b = 1,noab
3200      DO h1b = 1,noab
3201      IF (next.eq.count) THEN
3202      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
3203     &).ne.4)) THEN
3204      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3205      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
3206     &v,irrep_t)) THEN
3207      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
3208      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3209     & ERRQUIT('ipccsd_x2_2_3',0,MA_ERR)
3210      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3211      DO p5b = noab+1,noab+nvab
3212      DO h6b = 1,noab
3213      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h6b-1)) THEN
3214      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h6b-1)) .eq. irrep_t) TH
3215     &EN
3216      CALL TCE_RESTRICTED_2(p5b,h6b,p5b_1,h6b_1)
3217      CALL TCE_RESTRICTED_4(h8b,h6b,h1b,p5b,h8b_2,h6b_2,h1b_2,p5b_2)
3218      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1)
3219      dima_sort = 1
3220      dima = dim_common * dima_sort
3221      dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
3222      dimb = dim_common * dimb_sort
3223      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
3224      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3225     & ERRQUIT('ipccsd_x2_2_3',1,MA_ERR)
3226      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3227     &ipccsd_x2_2_3',2,MA_ERR)
3228      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
3229     & - 1 + noab * (p5b_1 - noab - 1)))
3230      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
3231     &,int_mb(k_range+h6b-1),2,1,1.0d0)
3232      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_3',3,MA_ERR)
3233      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
3234     & ERRQUIT('ipccsd_x2_2_3',4,MA_ERR)
3235      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
3236     &ipccsd_x2_2_3',5,MA_ERR)
3237      IF ((h6b .le. h8b) .and. (h1b .le. p5b)) THEN
3238      if(.not.intorb) then
3239      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
3240     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3241     &+nvab) * (h6b_2 - 1)))))
3242      else
3243      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3244     &(p5b_2
3245     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3246     &+nvab) * (h6b_2 - 1)))),p5b_2,h1b_2,h8b_2,h6b_2)
3247      end if
3248      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
3249     &,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1)
3250     &,3,2,1,4,1.0d0)
3251      END IF
3252      IF ((h8b .lt. h6b) .and. (h1b .le. p5b)) THEN
3253      if(.not.intorb) then
3254      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
3255     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
3256     &+nvab) * (h8b_2 - 1)))))
3257      else
3258      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3259     &(p5b_2
3260     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
3261     &+nvab) * (h8b_2 - 1)))),p5b_2,h1b_2,h6b_2,h8b_2)
3262      end if
3263      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
3264     &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1)
3265     &,3,1,2,4,-1.0d0)
3266      END IF
3267      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_2_3',6,MA_ERR)
3268      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
3269     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
3270     &t),dima_sort)
3271      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_2_3',7,MA
3272     &_ERR)
3273      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_3',8,MA
3274     &_ERR)
3275      END IF
3276      END IF
3277      END IF
3278      END DO
3279      END DO
3280      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3281     &ipccsd_x2_2_3',9,MA_ERR)
3282      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
3283     &,int_mb(k_range+h8b-1),2,1,-1.0d0)
3284      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
3285     & 1 + noab * (h8b - 1)))
3286      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_3',10,MA_ERR
3287     &)
3288      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_2_3',11,M
3289     &A_ERR)
3290      END IF
3291      END IF
3292      END IF
3293      next = NXTASK(nprocs, 1)
3294      END IF
3295      count = count + 1
3296      END DO
3297      END DO
3298      next = NXTASK(-nprocs, 1)
3299      call GA_SYNC()
3300      RETURN
3301      END
3302      SUBROUTINE ipccsd_x2_2_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
3303     &set)
3304C     $Id$
3305C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3306C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3307C     i1 ( h8 h1 )_vt + = -1/2 * Sum ( h7 p5 p6 ) * t ( p5 p6 h1 h7 )_t * v ( h7 h8 p5 p6 )_v
3308      IMPLICIT NONE
3309#include "global.fh"
3310#include "mafdecls.fh"
3311#include "sym.fh"
3312#include "errquit.fh"
3313#include "tce.fh"
3314      INTEGER d_a
3315      INTEGER k_a_offset
3316      INTEGER d_b
3317      INTEGER k_b_offset
3318      INTEGER d_c
3319      INTEGER k_c_offset
3320      INTEGER NXTASK
3321      INTEGER next
3322      INTEGER nprocs
3323      INTEGER count
3324      INTEGER h8b
3325      INTEGER h1b
3326      INTEGER dimc
3327      INTEGER l_c_sort
3328      INTEGER k_c_sort
3329      INTEGER p5b
3330      INTEGER p6b
3331      INTEGER h7b
3332      INTEGER p5b_1
3333      INTEGER p6b_1
3334      INTEGER h1b_1
3335      INTEGER h7b_1
3336      INTEGER h8b_2
3337      INTEGER h7b_2
3338      INTEGER p5b_2
3339      INTEGER p6b_2
3340      INTEGER dim_common
3341      INTEGER dima_sort
3342      INTEGER dima
3343      INTEGER dimb_sort
3344      INTEGER dimb
3345      INTEGER l_a_sort
3346      INTEGER k_a_sort
3347      INTEGER l_a
3348      INTEGER k_a
3349      INTEGER l_b_sort
3350      INTEGER k_b_sort
3351      INTEGER l_b
3352      INTEGER k_b
3353      INTEGER nsuperp(2)
3354      INTEGER isuperp
3355      INTEGER l_c
3356      INTEGER k_c
3357      DOUBLE PRECISION FACTORIAL
3358      EXTERNAL NXTASK
3359      EXTERNAL FACTORIAL
3360      nprocs = GA_NNODES()
3361      count = 0
3362      next = NXTASK(nprocs, 1)
3363      DO h8b = 1,noab
3364      DO h1b = 1,noab
3365      IF (next.eq.count) THEN
3366      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h1b-1
3367     &).ne.4)) THEN
3368      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
3369      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
3370     &v,irrep_t)) THEN
3371      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h1b-1)
3372      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3373     & ERRQUIT('ipccsd_x2_2_4',0,MA_ERR)
3374      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3375      DO p5b = noab+1,noab+nvab
3376      DO p6b = p5b,noab+nvab
3377      DO h7b = 1,noab
3378      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h
3379     &1b-1)+int_mb(k_spin+h7b-1)) THEN
3380      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb(
3381     &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_t) THEN
3382      CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h7b,p5b_1,p6b_1,h1b_1,h7b_1)
3383      CALL TCE_RESTRICTED_4(h8b,h7b,p5b,p6b,h8b_2,h7b_2,p5b_2,p6b_2)
3384      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_m
3385     &b(k_range+h7b-1)
3386      dima_sort = int_mb(k_range+h1b-1)
3387      dima = dim_common * dima_sort
3388      dimb_sort = int_mb(k_range+h8b-1)
3389      dimb = dim_common * dimb_sort
3390      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
3391      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3392     & ERRQUIT('ipccsd_x2_2_4',1,MA_ERR)
3393      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3394     &ipccsd_x2_2_4',2,MA_ERR)
3395      IF ((h7b .lt. h1b)) THEN
3396      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
3397     & - 1 + noab * (h7b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_
3398     &1 - noab - 1)))))
3399      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
3400     &,int_mb(k_range+p6b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1)
3401     &,4,3,2,1,-1.0d0)
3402      END IF
3403      IF ((h1b .le. h7b)) THEN
3404      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
3405     & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_
3406     &1 - noab - 1)))))
3407      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
3408     &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1)
3409     &,3,4,2,1,1.0d0)
3410      END IF
3411      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_2_4',3,MA_ERR)
3412      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
3413     & ERRQUIT('ipccsd_x2_2_4',4,MA_ERR)
3414      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
3415     &ipccsd_x2_2_4',5,MA_ERR)
3416      IF ((h7b .le. h8b)) THEN
3417      if(.not.intorb) then
3418      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
3419     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3420     &+nvab) * (h7b_2 - 1)))))
3421      else
3422      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3423     &(p6b_2
3424     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
3425     &+nvab) * (h7b_2 - 1)))),p6b_2,p5b_2,h8b_2,h7b_2)
3426      end if
3427      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
3428     &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1)
3429     &,2,1,4,3,1.0d0)
3430      END IF
3431      IF ((h8b .lt. h7b)) THEN
3432      if(.not.intorb) then
3433      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
3434     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
3435     &+nvab) * (h8b_2 - 1)))))
3436      else
3437      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3438     &(p6b_2
3439     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
3440     &+nvab) * (h8b_2 - 1)))),p6b_2,p5b_2,h7b_2,h8b_2)
3441      end if
3442      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
3443     &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1)
3444     &,1,2,4,3,-1.0d0)
3445      END IF
3446      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_2_4',6,MA_ERR)
3447      nsuperp(1) = 1
3448      nsuperp(2) = 1
3449      isuperp = 1
3450      IF (p5b .eq. p6b) THEN
3451      nsuperp(isuperp) = nsuperp(isuperp) + 1
3452      ELSE
3453      isuperp = isuperp + 1
3454      END IF
3455      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
3456     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
3457     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
3458      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_2_4',7,MA
3459     &_ERR)
3460      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_2_4',8,MA
3461     &_ERR)
3462      END IF
3463      END IF
3464      END IF
3465      END DO
3466      END DO
3467      END DO
3468      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3469     &ipccsd_x2_2_4',9,MA_ERR)
3470      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1)
3471     &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0)
3472      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
3473     & 1 + noab * (h8b - 1)))
3474      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_2_4',10,MA_ERR
3475     &)
3476      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_2_4',11,M
3477     &A_ERR)
3478      END IF
3479      END IF
3480      END IF
3481      next = NXTASK(nprocs, 1)
3482      END IF
3483      count = count + 1
3484      END DO
3485      END DO
3486      next = NXTASK(-nprocs, 1)
3487      call GA_SYNC()
3488      RETURN
3489      END
3490      SUBROUTINE ipccsd_x2_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
3491     &t)
3492C     $Id$
3493C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3494C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3495C     i0 ( p3 p4 h1 h2 )_xf + = 1 * P( 2 ) * Sum ( p8 ) * x ( p3 p8 h1 h2 )_x * i1 ( p4 p8 )_f
3496      IMPLICIT NONE
3497#include "global.fh"
3498#include "mafdecls.fh"
3499#include "sym.fh"
3500#include "errquit.fh"
3501#include "tce.fh"
3502      INTEGER d_a
3503      INTEGER k_a_offset
3504      INTEGER d_b
3505      INTEGER k_b_offset
3506      INTEGER d_c
3507      INTEGER k_c_offset
3508      INTEGER NXTASK
3509      INTEGER next
3510      INTEGER nprocs
3511      INTEGER count
3512      INTEGER p3b
3513      INTEGER p4b
3514      INTEGER h1b
3515      INTEGER h2b
3516      INTEGER dimc
3517      INTEGER l_c_sort
3518      INTEGER k_c_sort
3519      INTEGER p8b
3520      INTEGER p3b_1
3521      INTEGER p8b_1
3522      INTEGER h1b_1
3523      INTEGER h2b_1
3524      INTEGER p4b_2
3525      INTEGER p8b_2
3526      INTEGER dim_common
3527      INTEGER dima_sort
3528      INTEGER dima
3529      INTEGER dimb_sort
3530      INTEGER dimb
3531      INTEGER l_a_sort
3532      INTEGER k_a_sort
3533      INTEGER l_a
3534      INTEGER k_a
3535      INTEGER l_b_sort
3536      INTEGER k_b_sort
3537      INTEGER l_b
3538      INTEGER k_b
3539      INTEGER l_c
3540      INTEGER k_c
3541      EXTERNAL NXTASK
3542      nprocs = GA_NNODES()
3543      count = 0
3544      next = NXTASK(nprocs, 1)
3545ckbn      DO p3b = noab+1,noab+nvab
3546      DO p3b = 1,1
3547      DO p4b = noab+1,noab+nvab
3548      DO h1b = 1,noab
3549      DO h2b = h1b,noab
3550      IF (next.eq.count) THEN
3551ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
3552ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
3553      IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p4b-1
3554     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
3555ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
3556ckbn     &1b-1)+int_mb(k_spin+h2b-1)) THEN
3557      IF (ip_unused_spin +int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
3558     &1b-1)+int_mb(k_spin+h2b-1)) THEN
3559ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
3560ckbn     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_f)) TH
3561ckbn     &EN
3562      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
3563     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_f)) TH
3564     &EN
3565ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
3566ckbn     &nge+h1b-1) * int_mb(k_range+h2b-1)
3567      dimc = 1 * int_mb(k_range+p4b-1) * int_mb(k_ra
3568     &nge+h1b-1) * int_mb(k_range+h2b-1)
3569      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3570     & ERRQUIT('ipccsd_x2_3',0,MA_ERR)
3571      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3572      DO p8b = noab+1,noab+nvab
3573ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
3574ckbn     &1b-1)+int_mb(k_spin+h2b-1)) THEN
3575      IF (ip_unused_spin +int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
3576     &1b-1)+int_mb(k_spin+h2b-1)) THEN
3577ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
3578ckbn     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN
3579      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
3580     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN
3581      CALL TCE_RESTRICTED_4(p3b,p8b,h1b,h2b,p3b_1,p8b_1,h1b_1,h2b_1)
3582      CALL TCE_RESTRICTED_2(p4b,p8b,p4b_2,p8b_2)
3583      dim_common = int_mb(k_range+p8b-1)
3584ckbn      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb
3585ckbn     &(k_range+h2b-1)
3586      dima_sort = 1 * int_mb(k_range+h1b-1) * int_mb
3587     &(k_range+h2b-1)
3588      dima = dim_common * dima_sort
3589      dimb_sort = int_mb(k_range+p4b-1)
3590      dimb = dim_common * dimb_sort
3591      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
3592      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3593     & ERRQUIT('ipccsd_x2_3',1,MA_ERR)
3594      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3595     &ipccsd_x2_3',2,MA_ERR)
3596ckbn      IF ((p8b .lt. p3b)) THEN
3597      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
3598     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_
3599     &1 - noab - 1)))))
3600ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
3601ckbn     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
3602ckbn     &,4,3,2,1,-1.0d0)
3603      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
3604     &,1,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
3605     &,4,3,2,1,-1.0d0)
3606ckbn      END IF
3607ckbn      IF ((p3b .le. p8b)) THEN
3608ckbn      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
3609ckbn     & - 1 + noab * (h1b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_
3610ckbn     &1 - noab - 1)))))
3611ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
3612ckbn     &,int_mb(k_range+p8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
3613ckbn     &,4,3,1,2,1.0d0)
3614ckbn      END IF
3615      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_3',3,MA_ERR)
3616      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
3617     & ERRQUIT('ipccsd_x2_3',4,MA_ERR)
3618      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
3619     &ipccsd_x2_3',5,MA_ERR)
3620      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
3621     & - noab - 1 + nvab * (p4b_2 - noab - 1)))
3622      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
3623     &,int_mb(k_range+p8b-1),1,2,1.0d0)
3624      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_3',6,MA_ERR)
3625      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
3626     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
3627     &t),dima_sort)
3628      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_3',7,MA_E
3629     &RR)
3630      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_3',8,MA_E
3631     &RR)
3632      END IF
3633      END IF
3634      END IF
3635      END DO
3636      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3637     &ipccsd_x2_3',9,MA_ERR)
3638ckbn      IF ((p3b .le. p4b)) THEN
3639ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1)
3640ckbn     &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
3641ckbn     &,4,1,3,2,1.0d0)
3642ckbn      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
3643ckbn     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
3644ckbn     & - 1)))))
3645ckbn      END IF
3646ckbn      IF ((p4b .le. p3b)) THEN
3647ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1)
3648ckbn     &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
3649ckbn     &,1,4,3,2,-1.0d0)
3650      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1)
3651     &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),1
3652     &,1,4,3,2,-1.0d0)
3653      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
3654     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
3655     & - 1)))))
3656ckbn      END IF
3657      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_3',10,MA_ERR)
3658      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_3',11,MA_
3659     &ERR)
3660      END IF
3661      END IF
3662      END IF
3663      next = NXTASK(nprocs, 1)
3664      END IF
3665      count = count + 1
3666      END DO
3667      END DO
3668      END DO
3669      END DO
3670      next = NXTASK(-nprocs, 1)
3671      call GA_SYNC()
3672      RETURN
3673      END
3674      SUBROUTINE ipccsd_x2_3_1(d_a,k_a_offset,d_c,k_c_offset)
3675C     $Id$
3676C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3677C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3678C     i1 ( p3 p8 )_f + = 1 * f ( p3 p8 )_f
3679      IMPLICIT NONE
3680#include "global.fh"
3681#include "mafdecls.fh"
3682#include "sym.fh"
3683#include "errquit.fh"
3684#include "tce.fh"
3685      INTEGER d_a
3686      INTEGER k_a_offset
3687      INTEGER d_c
3688      INTEGER k_c_offset
3689      INTEGER NXTASK
3690      INTEGER next
3691      INTEGER nprocs
3692      INTEGER count
3693      INTEGER p3b
3694      INTEGER p8b
3695      INTEGER dimc
3696      INTEGER p3b_1
3697      INTEGER p8b_1
3698      INTEGER dim_common
3699      INTEGER dima_sort
3700      INTEGER dima
3701      INTEGER l_a_sort
3702      INTEGER k_a_sort
3703      INTEGER l_a
3704      INTEGER k_a
3705      INTEGER l_c
3706      INTEGER k_c
3707      EXTERNAL NXTASK
3708      nprocs = GA_NNODES()
3709      count = 0
3710      next = NXTASK(nprocs, 1)
3711      DO p3b = noab+1,noab+nvab
3712      DO p8b = noab+1,noab+nvab
3713      IF (next.eq.count) THEN
3714      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1
3715     &).ne.4)) THEN
3716      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p8b-1)) THEN
3717      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH
3718     &EN
3719      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1)
3720      CALL TCE_RESTRICTED_2(p3b,p8b,p3b_1,p8b_1)
3721      dim_common = 1
3722      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1)
3723      dima = dim_common * dima_sort
3724      IF (dima .gt. 0) THEN
3725      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3726     & ERRQUIT('ipccsd_x2_3_1',0,MA_ERR)
3727      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3728     &ipccsd_x2_3_1',1,MA_ERR)
3729      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1
3730     & - 1 + (noab+nvab) * (p3b_1 - 1)))
3731      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
3732     &,int_mb(k_range+p8b-1),2,1,1.0d0)
3733      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_3_1',2,MA_ERR)
3734      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3735     &ipccsd_x2_3_1',3,MA_ERR)
3736      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
3737     &,int_mb(k_range+p3b-1),2,1,1.0d0)
3738      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
3739     & noab - 1 + nvab * (p3b - noab - 1)))
3740      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_3_1',4,MA_ERR)
3741      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_3_1',5,MA
3742     &_ERR)
3743      END IF
3744      END IF
3745      END IF
3746      END IF
3747      next = NXTASK(nprocs, 1)
3748      END IF
3749      count = count + 1
3750      END DO
3751      END DO
3752      next = NXTASK(-nprocs, 1)
3753      call GA_SYNC()
3754      RETURN
3755      END
3756      SUBROUTINE OFFSET_ipccsd_x2_3_1(l_a_offset,k_a_offset,size)
3757C     $Id$
3758C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3759C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3760C     i1 ( p3 p8 )_f
3761      IMPLICIT NONE
3762#include "global.fh"
3763#include "mafdecls.fh"
3764#include "sym.fh"
3765#include "errquit.fh"
3766#include "tce.fh"
3767      INTEGER l_a_offset
3768      INTEGER k_a_offset
3769      INTEGER size
3770      INTEGER length
3771      INTEGER addr
3772      INTEGER p3b
3773      INTEGER p8b
3774      length = 0
3775      DO p3b = noab+1,noab+nvab
3776      DO p8b = noab+1,noab+nvab
3777      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p8b-1)) THEN
3778      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH
3779     &EN
3780      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1
3781     &).ne.4)) THEN
3782      length = length + 1
3783      END IF
3784      END IF
3785      END IF
3786      END DO
3787      END DO
3788      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
3789     &set)) CALL ERRQUIT('ipccsd_x2_3_1',0,MA_ERR)
3790      int_mb(k_a_offset) = length
3791      addr = 0
3792      size = 0
3793      DO p3b = noab+1,noab+nvab
3794      DO p8b = noab+1,noab+nvab
3795      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p8b-1)) THEN
3796      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH
3797     &EN
3798      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1
3799     &).ne.4)) THEN
3800      addr = addr + 1
3801      int_mb(k_a_offset+addr) = p8b - noab - 1 + nvab * (p3b - noab - 1)
3802      int_mb(k_a_offset+length+addr) = size
3803      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1)
3804      END IF
3805      END IF
3806      END IF
3807      END DO
3808      END DO
3809      RETURN
3810      END
3811      SUBROUTINE ipccsd_x2_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
3812     &set)
3813C     $Id$
3814C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3815C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3816C     i1 ( p3 p8 )_vt + = 1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 p3 p5 p8 )_v
3817      IMPLICIT NONE
3818#include "global.fh"
3819#include "mafdecls.fh"
3820#include "sym.fh"
3821#include "errquit.fh"
3822#include "tce.fh"
3823      INTEGER d_a
3824      INTEGER k_a_offset
3825      INTEGER d_b
3826      INTEGER k_b_offset
3827      INTEGER d_c
3828      INTEGER k_c_offset
3829      INTEGER NXTASK
3830      INTEGER next
3831      INTEGER nprocs
3832      INTEGER count
3833      INTEGER p3b
3834      INTEGER p8b
3835      INTEGER dimc
3836      INTEGER l_c_sort
3837      INTEGER k_c_sort
3838      INTEGER p5b
3839      INTEGER h6b
3840      INTEGER p5b_1
3841      INTEGER h6b_1
3842      INTEGER p3b_2
3843      INTEGER h6b_2
3844      INTEGER p8b_2
3845      INTEGER p5b_2
3846      INTEGER dim_common
3847      INTEGER dima_sort
3848      INTEGER dima
3849      INTEGER dimb_sort
3850      INTEGER dimb
3851      INTEGER l_a_sort
3852      INTEGER k_a_sort
3853      INTEGER l_a
3854      INTEGER k_a
3855      INTEGER l_b_sort
3856      INTEGER k_b_sort
3857      INTEGER l_b
3858      INTEGER k_b
3859      INTEGER l_c
3860      INTEGER k_c
3861      EXTERNAL NXTASK
3862      nprocs = GA_NNODES()
3863      count = 0
3864      next = NXTASK(nprocs, 1)
3865      DO p3b = noab+1,noab+nvab
3866      DO p8b = noab+1,noab+nvab
3867      IF (next.eq.count) THEN
3868      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1
3869     &).ne.4)) THEN
3870      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p8b-1)) THEN
3871      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p8b-1)) .eq. ieor(irrep_
3872     &v,irrep_t)) THEN
3873      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1)
3874      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
3875     & ERRQUIT('ipccsd_x2_3_2',0,MA_ERR)
3876      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
3877      DO p5b = noab+1,noab+nvab
3878      DO h6b = 1,noab
3879      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h6b-1)) THEN
3880      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h6b-1)) .eq. irrep_t) TH
3881     &EN
3882      CALL TCE_RESTRICTED_2(p5b,h6b,p5b_1,h6b_1)
3883      CALL TCE_RESTRICTED_4(p3b,h6b,p8b,p5b,p3b_2,h6b_2,p8b_2,p5b_2)
3884      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1)
3885      dima_sort = 1
3886      dima = dim_common * dima_sort
3887      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1)
3888      dimb = dim_common * dimb_sort
3889      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
3890      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
3891     & ERRQUIT('ipccsd_x2_3_2',1,MA_ERR)
3892      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
3893     &ipccsd_x2_3_2',2,MA_ERR)
3894      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
3895     & - 1 + noab * (p5b_1 - noab - 1)))
3896      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
3897     &,int_mb(k_range+h6b-1),2,1,1.0d0)
3898      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_3_2',3,MA_ERR)
3899      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
3900     & ERRQUIT('ipccsd_x2_3_2',4,MA_ERR)
3901      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
3902     &ipccsd_x2_3_2',5,MA_ERR)
3903      IF ((h6b .le. p3b) .and. (p5b .le. p8b)) THEN
3904      if(.not.intorb) then
3905      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
3906     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
3907     &+nvab) * (h6b_2 - 1)))))
3908      else
3909      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3910     &(p8b_2
3911     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
3912     &+nvab) * (h6b_2 - 1)))),p8b_2,p5b_2,p3b_2,h6b_2)
3913      end if
3914      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
3915     &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1)
3916     &,4,2,1,3,1.0d0)
3917      END IF
3918      IF ((h6b .le. p3b) .and. (p8b .lt. p5b)) THEN
3919      if(.not.intorb) then
3920      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
3921     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
3922     &+nvab) * (h6b_2 - 1)))))
3923      else
3924      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
3925     &(p5b_2
3926     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
3927     &+nvab) * (h6b_2 - 1)))),p5b_2,p8b_2,p3b_2,h6b_2)
3928      end if
3929      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
3930     &,int_mb(k_range+p3b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1)
3931     &,3,2,1,4,-1.0d0)
3932      END IF
3933      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_3_2',6,MA_ERR)
3934      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
3935     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
3936     &t),dima_sort)
3937      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_3_2',7,MA
3938     &_ERR)
3939      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_3_2',8,MA
3940     &_ERR)
3941      END IF
3942      END IF
3943      END IF
3944      END DO
3945      END DO
3946      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
3947     &ipccsd_x2_3_2',9,MA_ERR)
3948      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
3949     &,int_mb(k_range+p3b-1),2,1,1.0d0)
3950      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
3951     & noab - 1 + nvab * (p3b - noab - 1)))
3952      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_3_2',10,MA_ERR
3953     &)
3954      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_3_2',11,M
3955     &A_ERR)
3956      END IF
3957      END IF
3958      END IF
3959      next = NXTASK(nprocs, 1)
3960      END IF
3961      count = count + 1
3962      END DO
3963      END DO
3964      next = NXTASK(-nprocs, 1)
3965      call GA_SYNC()
3966      RETURN
3967      END
3968      SUBROUTINE ipccsd_x2_3_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
3969     &set)
3970C     $Id$
3971C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
3972C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
3973C     i1 ( p3 p8 )_vt + = 1/2 * Sum ( h6 h7 p5 ) * t ( p3 p5 h6 h7 )_t * v ( h6 h7 p5 p8 )_v
3974      IMPLICIT NONE
3975#include "global.fh"
3976#include "mafdecls.fh"
3977#include "sym.fh"
3978#include "errquit.fh"
3979#include "tce.fh"
3980      INTEGER d_a
3981      INTEGER k_a_offset
3982      INTEGER d_b
3983      INTEGER k_b_offset
3984      INTEGER d_c
3985      INTEGER k_c_offset
3986      INTEGER NXTASK
3987      INTEGER next
3988      INTEGER nprocs
3989      INTEGER count
3990      INTEGER p3b
3991      INTEGER p8b
3992      INTEGER dimc
3993      INTEGER l_c_sort
3994      INTEGER k_c_sort
3995      INTEGER p5b
3996      INTEGER h6b
3997      INTEGER h7b
3998      INTEGER p3b_1
3999      INTEGER p5b_1
4000      INTEGER h6b_1
4001      INTEGER h7b_1
4002      INTEGER h6b_2
4003      INTEGER h7b_2
4004      INTEGER p8b_2
4005      INTEGER p5b_2
4006      INTEGER dim_common
4007      INTEGER dima_sort
4008      INTEGER dima
4009      INTEGER dimb_sort
4010      INTEGER dimb
4011      INTEGER l_a_sort
4012      INTEGER k_a_sort
4013      INTEGER l_a
4014      INTEGER k_a
4015      INTEGER l_b_sort
4016      INTEGER k_b_sort
4017      INTEGER l_b
4018      INTEGER k_b
4019      INTEGER nsubh(2)
4020      INTEGER isubh
4021      INTEGER l_c
4022      INTEGER k_c
4023      DOUBLE PRECISION FACTORIAL
4024      EXTERNAL NXTASK
4025      EXTERNAL FACTORIAL
4026      nprocs = GA_NNODES()
4027      count = 0
4028      next = NXTASK(nprocs, 1)
4029      DO p3b = noab+1,noab+nvab
4030      DO p8b = noab+1,noab+nvab
4031      IF (next.eq.count) THEN
4032      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1
4033     &).ne.4)) THEN
4034      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p8b-1)) THEN
4035      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p8b-1)) .eq. ieor(irrep_
4036     &v,irrep_t)) THEN
4037      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p8b-1)
4038      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
4039     & ERRQUIT('ipccsd_x2_3_3',0,MA_ERR)
4040      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
4041      DO p5b = noab+1,noab+nvab
4042      DO h6b = 1,noab
4043      DO h7b = h6b,noab
4044      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
4045     &6b-1)+int_mb(k_spin+h7b-1)) THEN
4046      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
4047     &k_sym+h6b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_t) THEN
4048      CALL TCE_RESTRICTED_4(p3b,p5b,h6b,h7b,p3b_1,p5b_1,h6b_1,h7b_1)
4049      CALL TCE_RESTRICTED_4(h6b,h7b,p8b,p5b,h6b_2,h7b_2,p8b_2,p5b_2)
4050      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) * int_m
4051     &b(k_range+h7b-1)
4052      dima_sort = int_mb(k_range+p3b-1)
4053      dima = dim_common * dima_sort
4054      dimb_sort = int_mb(k_range+p8b-1)
4055      dimb = dim_common * dimb_sort
4056      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
4057      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4058     & ERRQUIT('ipccsd_x2_3_3',1,MA_ERR)
4059      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4060     &ipccsd_x2_3_3',2,MA_ERR)
4061      IF ((p5b .lt. p3b)) THEN
4062      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
4063     & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
4064     &1 - noab - 1)))))
4065      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
4066     &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h7b-1)
4067     &,2,4,3,1,-1.0d0)
4068      END IF
4069      IF ((p3b .le. p5b)) THEN
4070      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
4071     & - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
4072     &1 - noab - 1)))))
4073      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
4074     &,int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h7b-1)
4075     &,1,4,3,2,1.0d0)
4076      END IF
4077      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_3_3',3,MA_ERR)
4078      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
4079     & ERRQUIT('ipccsd_x2_3_3',4,MA_ERR)
4080      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
4081     &ipccsd_x2_3_3',5,MA_ERR)
4082      IF ((p5b .le. p8b)) THEN
4083      if(.not.intorb) then
4084      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
4085     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
4086     &+nvab) * (h6b_2 - 1)))))
4087      else
4088      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4089     &(p8b_2
4090     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
4091     &+nvab) * (h6b_2 - 1)))),p8b_2,p5b_2,h7b_2,h6b_2)
4092      end if
4093      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
4094     &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1)
4095     &,4,2,1,3,1.0d0)
4096      END IF
4097      IF ((p8b .lt. p5b)) THEN
4098      if(.not.intorb) then
4099      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
4100     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
4101     &+nvab) * (h6b_2 - 1)))))
4102      else
4103      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4104     &(p5b_2
4105     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
4106     &+nvab) * (h6b_2 - 1)))),p5b_2,p8b_2,h7b_2,h6b_2)
4107      end if
4108      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
4109     &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1)
4110     &,3,2,1,4,-1.0d0)
4111      END IF
4112      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_3_3',6,MA_ERR)
4113      nsubh(1) = 1
4114      nsubh(2) = 1
4115      isubh = 1
4116      IF (h6b .eq. h7b) THEN
4117      nsubh(isubh) = nsubh(isubh) + 1
4118      ELSE
4119      isubh = isubh + 1
4120      END IF
4121      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
4122     &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k
4123     &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
4124      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_3_3',7,MA
4125     &_ERR)
4126      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_3_3',8,MA
4127     &_ERR)
4128      END IF
4129      END IF
4130      END IF
4131      END DO
4132      END DO
4133      END DO
4134      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4135     &ipccsd_x2_3_3',9,MA_ERR)
4136      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
4137     &,int_mb(k_range+p3b-1),2,1,1.0d0/2.0d0)
4138      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
4139     & noab - 1 + nvab * (p3b - noab - 1)))
4140      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_3_3',10,MA_ERR
4141     &)
4142      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_3_3',11,M
4143     &A_ERR)
4144      END IF
4145      END IF
4146      END IF
4147      next = NXTASK(nprocs, 1)
4148      END IF
4149      count = count + 1
4150      END DO
4151      END DO
4152      next = NXTASK(-nprocs, 1)
4153      call GA_SYNC()
4154      RETURN
4155      END
4156      SUBROUTINE ipccsd_x2_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
4157     &t)
4158C     $Id$
4159C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4160C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4161C     i0 ( p3 p4 h1 h2 )_xv + = 1/2 * Sum ( h9 h10 ) * x ( p3 p4 h9 h10 )_x * i1 ( h9 h10 h1 h2 )_v
4162      IMPLICIT NONE
4163#include "global.fh"
4164#include "mafdecls.fh"
4165#include "sym.fh"
4166#include "errquit.fh"
4167#include "tce.fh"
4168      INTEGER d_a
4169      INTEGER k_a_offset
4170      INTEGER d_b
4171      INTEGER k_b_offset
4172      INTEGER d_c
4173      INTEGER k_c_offset
4174      INTEGER NXTASK
4175      INTEGER next
4176      INTEGER nprocs
4177      INTEGER count
4178      INTEGER p3b
4179      INTEGER p4b
4180      INTEGER h1b
4181      INTEGER h2b
4182      INTEGER dimc
4183      INTEGER l_c_sort
4184      INTEGER k_c_sort
4185      INTEGER h9b
4186      INTEGER h10b
4187      INTEGER p3b_1
4188      INTEGER p4b_1
4189      INTEGER h9b_1
4190      INTEGER h10b_1
4191      INTEGER h9b_2
4192      INTEGER h10b_2
4193      INTEGER h1b_2
4194      INTEGER h2b_2
4195      INTEGER dim_common
4196      INTEGER dima_sort
4197      INTEGER dima
4198      INTEGER dimb_sort
4199      INTEGER dimb
4200      INTEGER l_a_sort
4201      INTEGER k_a_sort
4202      INTEGER l_a
4203      INTEGER k_a
4204      INTEGER l_b_sort
4205      INTEGER k_b_sort
4206      INTEGER l_b
4207      INTEGER k_b
4208      INTEGER nsubh(2)
4209      INTEGER isubh
4210      INTEGER l_c
4211      INTEGER k_c
4212      DOUBLE PRECISION FACTORIAL
4213      EXTERNAL NXTASK
4214      EXTERNAL FACTORIAL
4215      nprocs = GA_NNODES()
4216      count = 0
4217      next = NXTASK(nprocs, 1)
4218      DO p3b = noab+1,noab+nvab
4219ckbn      DO p4b = p3b,noab+nvab
4220      DO p4b = 1,1
4221      DO h1b = 1,noab
4222      DO h2b = h1b,noab
4223      IF (next.eq.count) THEN
4224ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
4225ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
4226      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ ip_unused_spin
4227     & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
4228ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
4229ckbn     &1b-1)+int_mb(k_spin+h2b-1)) THEN
4230      IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h
4231     &1b-1)+int_mb(k_spin+h2b-1)) THEN
4232ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
4233ckbn     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH
4234ckbn     &EN
4235      IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb(
4236     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH
4237     &EN
4238ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
4239ckbn     &nge+h1b-1) * int_mb(k_range+h2b-1)
4240      dimc = int_mb(k_range+p3b-1) * 1 * int_mb(k_ra
4241     &nge+h1b-1) * int_mb(k_range+h2b-1)
4242      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
4243     & ERRQUIT('ipccsd_x2_4',0,MA_ERR)
4244      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
4245      DO h9b = 1,noab
4246      DO h10b = h9b,noab
4247ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
4248ckbn     &9b-1)+int_mb(k_spin+h10b-1)) THEN
4249      IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h
4250     &9b-1)+int_mb(k_spin+h10b-1)) THEN
4251ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
4252ckbn     &k_sym+h9b-1),int_mb(k_sym+h10b-1)))) .eq. irrep_x) THEN
4253      IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb(
4254     &k_sym+h9b-1),int_mb(k_sym+h10b-1)))) .eq. irrep_x) THEN
4255      CALL TCE_RESTRICTED_4(p3b,p4b,h9b,h10b,p3b_1,p4b_1,h9b_1,h10b_1)
4256      CALL TCE_RESTRICTED_4(h9b,h10b,h1b,h2b,h9b_2,h10b_2,h1b_2,h2b_2)
4257      dim_common = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1)
4258ckbn      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1)
4259      dima_sort = int_mb(k_range+p3b-1) * 1
4260      dima = dim_common * dima_sort
4261      dimb_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
4262      dimb = dim_common * dimb_sort
4263      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
4264      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4265     & ERRQUIT('ipccsd_x2_4',1,MA_ERR)
4266      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4267     &ipccsd_x2_4',2,MA_ERR)
4268      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_
4269     &1 - 1 + noab * (h9b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b
4270     &_1 - noab - 1)))))
4271ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
4272ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h9b-1),int_mb(k_range+h10b-1
4273ckbn     &),2,1,4,3,1.0d0)
4274      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
4275     &,1,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1
4276     &),2,1,4,3,1.0d0)
4277      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4',3,MA_ERR)
4278      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
4279     & ERRQUIT('ipccsd_x2_4',4,MA_ERR)
4280      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
4281     &ipccsd_x2_4',5,MA_ERR)
4282      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
4283     & - 1 + noab * (h1b_2 - 1 + noab * (h10b_2 - 1 + noab * (h9b_2 - 1)
4284     &))))
4285      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
4286     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
4287     &),4,3,2,1,1.0d0)
4288      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_4',6,MA_ERR)
4289      nsubh(1) = 1
4290      nsubh(2) = 1
4291      isubh = 1
4292      IF (h9b .eq. h10b) THEN
4293      nsubh(isubh) = nsubh(isubh) + 1
4294      ELSE
4295      isubh = isubh + 1
4296      END IF
4297      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
4298     &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k
4299     &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
4300      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_4',7,MA_E
4301     &RR)
4302      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4',8,MA_E
4303     &RR)
4304      END IF
4305      END IF
4306      END IF
4307      END DO
4308      END DO
4309      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4310     &ipccsd_x2_4',9,MA_ERR)
4311ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
4312ckbn     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
4313ckbn     &,4,3,2,1,1.0d0/2.0d0)
4314      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
4315     &,int_mb(k_range+h1b-1),1,int_mb(k_range+p3b-1)
4316     &,4,3,2,1,1.0d0/2.0d0)
4317      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
4318     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
4319     & - 1)))))
4320      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4',10,MA_ERR)
4321      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_4',11,MA_
4322     &ERR)
4323      END IF
4324      END IF
4325      END IF
4326      next = NXTASK(nprocs, 1)
4327      END IF
4328      count = count + 1
4329      END DO
4330      END DO
4331      END DO
4332      END DO
4333      next = NXTASK(-nprocs, 1)
4334      call GA_SYNC()
4335      RETURN
4336      END
4337      SUBROUTINE ipccsd_x2_4_1(d_a,k_a_offset,d_c,k_c_offset)
4338C     $Id$
4339C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4340C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4341C     i1 ( h9 h10 h1 h2 )_v + = 1 * v ( h9 h10 h1 h2 )_v
4342      IMPLICIT NONE
4343#include "global.fh"
4344#include "mafdecls.fh"
4345#include "sym.fh"
4346#include "errquit.fh"
4347#include "tce.fh"
4348      INTEGER d_a
4349      INTEGER k_a_offset
4350      INTEGER d_c
4351      INTEGER k_c_offset
4352      INTEGER NXTASK
4353      INTEGER next
4354      INTEGER nprocs
4355      INTEGER count
4356      INTEGER h9b
4357      INTEGER h10b
4358      INTEGER h1b
4359      INTEGER h2b
4360      INTEGER dimc
4361      INTEGER h9b_1
4362      INTEGER h10b_1
4363      INTEGER h1b_1
4364      INTEGER h2b_1
4365      INTEGER dim_common
4366      INTEGER dima_sort
4367      INTEGER dima
4368      INTEGER l_a_sort
4369      INTEGER k_a_sort
4370      INTEGER l_a
4371      INTEGER k_a
4372      INTEGER l_c
4373      INTEGER k_c
4374      EXTERNAL NXTASK
4375      nprocs = GA_NNODES()
4376      count = 0
4377      next = NXTASK(nprocs, 1)
4378      DO h9b = 1,noab
4379      DO h10b = h9b,noab
4380      DO h1b = 1,noab
4381      DO h2b = h1b,noab
4382      IF (next.eq.count) THEN
4383      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-
4384     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
4385      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
4386     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
4387      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
4388     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
4389      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
4390     &ange+h1b-1) * int_mb(k_range+h2b-1)
4391      CALL TCE_RESTRICTED_4(h9b,h10b,h1b,h2b,h9b_1,h10b_1,h1b_1,h2b_1)
4392      dim_common = 1
4393      dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_m
4394     &b(k_range+h1b-1) * int_mb(k_range+h2b-1)
4395      dima = dim_common * dima_sort
4396      IF (dima .gt. 0) THEN
4397      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4398     & ERRQUIT('ipccsd_x2_4_1',0,MA_ERR)
4399      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4400     &ipccsd_x2_4_1',1,MA_ERR)
4401      if(.not.intorb) then
4402      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
4403     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
4404     &b+nvab) * (h9b_1 - 1)))))
4405      else
4406      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
4407     &(h2b_1
4408     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
4409     &b+nvab) * (h9b_1 - 1)))),h2b_1,h1b_1,h10b_1,h9b_1)
4410      end if
4411      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1)
4412     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
4413     &),4,3,2,1,1.0d0)
4414      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4_1',2,MA_ERR)
4415      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4416     &ipccsd_x2_4_1',3,MA_ERR)
4417      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
4418     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h9b-1
4419     &),4,3,2,1,1.0d0)
4420      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
4421     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h9b - 1)))))
4422      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4_1',4,MA_ERR)
4423      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4_1',5,MA
4424     &_ERR)
4425      END IF
4426      END IF
4427      END IF
4428      END IF
4429      next = NXTASK(nprocs, 1)
4430      END IF
4431      count = count + 1
4432      END DO
4433      END DO
4434      END DO
4435      END DO
4436      next = NXTASK(-nprocs, 1)
4437      call GA_SYNC()
4438      RETURN
4439      END
4440      SUBROUTINE OFFSET_ipccsd_x2_4_1(l_a_offset,k_a_offset,size)
4441C     $Id$
4442C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4443C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4444C     i1 ( h9 h10 h1 h2 )_v
4445      IMPLICIT NONE
4446#include "global.fh"
4447#include "mafdecls.fh"
4448#include "sym.fh"
4449#include "errquit.fh"
4450#include "tce.fh"
4451      INTEGER l_a_offset
4452      INTEGER k_a_offset
4453      INTEGER size
4454      INTEGER length
4455      INTEGER addr
4456      INTEGER h9b
4457      INTEGER h10b
4458      INTEGER h1b
4459      INTEGER h2b
4460      length = 0
4461      DO h9b = 1,noab
4462      DO h10b = h9b,noab
4463      DO h1b = 1,noab
4464      DO h2b = h1b,noab
4465      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
4466     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
4467      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
4468     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
4469      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-
4470     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
4471      length = length + 1
4472      END IF
4473      END IF
4474      END IF
4475      END DO
4476      END DO
4477      END DO
4478      END DO
4479      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
4480     &set)) CALL ERRQUIT('ipccsd_x2_4_1',0,MA_ERR)
4481      int_mb(k_a_offset) = length
4482      addr = 0
4483      size = 0
4484      DO h9b = 1,noab
4485      DO h10b = h9b,noab
4486      DO h1b = 1,noab
4487      DO h2b = h1b,noab
4488      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
4489     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
4490      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
4491     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
4492      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-
4493     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
4494      addr = addr + 1
4495      int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h10b
4496     & - 1 + noab * (h9b - 1)))
4497      int_mb(k_a_offset+length+addr) = size
4498      size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int
4499     &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
4500      END IF
4501      END IF
4502      END IF
4503      END DO
4504      END DO
4505      END DO
4506      END DO
4507      RETURN
4508      END
4509      SUBROUTINE ipccsd_x2_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
4510     &set)
4511C     $Id$
4512C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4513C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4514C     i1 ( h9 h10 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h9 h10 h2 p5 )_v
4515      IMPLICIT NONE
4516#include "global.fh"
4517#include "mafdecls.fh"
4518#include "sym.fh"
4519#include "errquit.fh"
4520#include "tce.fh"
4521      INTEGER d_a
4522      INTEGER k_a_offset
4523      INTEGER d_b
4524      INTEGER k_b_offset
4525      INTEGER d_c
4526      INTEGER k_c_offset
4527      INTEGER NXTASK
4528      INTEGER next
4529      INTEGER nprocs
4530      INTEGER count
4531      INTEGER h9b
4532      INTEGER h10b
4533      INTEGER h1b
4534      INTEGER h2b
4535      INTEGER dimc
4536      INTEGER l_c_sort
4537      INTEGER k_c_sort
4538      INTEGER p5b
4539      INTEGER p5b_1
4540      INTEGER h1b_1
4541      INTEGER h9b_2
4542      INTEGER h10b_2
4543      INTEGER h2b_2
4544      INTEGER p5b_2
4545      INTEGER dim_common
4546      INTEGER dima_sort
4547      INTEGER dima
4548      INTEGER dimb_sort
4549      INTEGER dimb
4550      INTEGER l_a_sort
4551      INTEGER k_a_sort
4552      INTEGER l_a
4553      INTEGER k_a
4554      INTEGER l_b_sort
4555      INTEGER k_b_sort
4556      INTEGER l_b
4557      INTEGER k_b
4558      INTEGER l_c
4559      INTEGER k_c
4560      EXTERNAL NXTASK
4561      nprocs = GA_NNODES()
4562      count = 0
4563      next = NXTASK(nprocs, 1)
4564      DO h9b = 1,noab
4565      DO h10b = h9b,noab
4566      DO h1b = 1,noab
4567      DO h2b = 1,noab
4568      IF (next.eq.count) THEN
4569      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-
4570     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
4571      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
4572     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
4573      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
4574     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T
4575     &HEN
4576      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
4577     &ange+h1b-1) * int_mb(k_range+h2b-1)
4578      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
4579     & ERRQUIT('ipccsd_x2_4_2',0,MA_ERR)
4580      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
4581      DO p5b = noab+1,noab+nvab
4582      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
4583      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
4584     &EN
4585      CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1)
4586      CALL TCE_RESTRICTED_4(h9b,h10b,h2b,p5b,h9b_2,h10b_2,h2b_2,p5b_2)
4587      dim_common = int_mb(k_range+p5b-1)
4588      dima_sort = int_mb(k_range+h1b-1)
4589      dima = dim_common * dima_sort
4590      dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_m
4591     &b(k_range+h2b-1)
4592      dimb = dim_common * dimb_sort
4593      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
4594      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4595     & ERRQUIT('ipccsd_x2_4_2',1,MA_ERR)
4596      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4597     &ipccsd_x2_4_2',2,MA_ERR)
4598      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
4599     & - 1 + noab * (p5b_1 - noab - 1)))
4600      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
4601     &,int_mb(k_range+h1b-1),2,1,1.0d0)
4602      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4_2',3,MA_ERR)
4603      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
4604     & ERRQUIT('ipccsd_x2_4_2',4,MA_ERR)
4605      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
4606     &ipccsd_x2_4_2',5,MA_ERR)
4607      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
4608     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h10b_2 - 1 + noab * (h9b
4609     &_2 - 1)))))
4610      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
4611     &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1
4612     &),3,2,1,4,1.0d0)
4613      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_4_2',6,MA_ERR)
4614      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
4615     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
4616     &t),dima_sort)
4617      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_4_2',7,MA
4618     &_ERR)
4619      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4_2',8,MA
4620     &_ERR)
4621      END IF
4622      END IF
4623      END IF
4624      END DO
4625      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4626     &ipccsd_x2_4_2',9,MA_ERR)
4627      IF ((h1b .le. h2b)) THEN
4628      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
4629     &,int_mb(k_range+h10b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1
4630     &),3,2,4,1,-1.0d0)
4631      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
4632     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h9b - 1)))))
4633      END IF
4634      IF ((h2b .le. h1b)) THEN
4635      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
4636     &,int_mb(k_range+h10b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1
4637     &),3,2,1,4,1.0d0)
4638      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
4639     & 1 + noab * (h2b - 1 + noab * (h10b - 1 + noab * (h9b - 1)))))
4640      END IF
4641      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4_2',10,MA_ERR
4642     &)
4643      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_4_2',11,M
4644     &A_ERR)
4645      END IF
4646      END IF
4647      END IF
4648      next = NXTASK(nprocs, 1)
4649      END IF
4650      count = count + 1
4651      END DO
4652      END DO
4653      END DO
4654      END DO
4655      next = NXTASK(-nprocs, 1)
4656      call GA_SYNC()
4657      RETURN
4658      END
4659      SUBROUTINE ipccsd_x2_4_2_1(d_a,k_a_offset,d_c,k_c_offset)
4660C     $Id$
4661C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4662C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4663C     i2 ( h9 h10 h1 p5 )_v + = 1 * v ( h9 h10 h1 p5 )_v
4664      IMPLICIT NONE
4665#include "global.fh"
4666#include "mafdecls.fh"
4667#include "sym.fh"
4668#include "errquit.fh"
4669#include "tce.fh"
4670      INTEGER d_a
4671      INTEGER k_a_offset
4672      INTEGER d_c
4673      INTEGER k_c_offset
4674      INTEGER NXTASK
4675      INTEGER next
4676      INTEGER nprocs
4677      INTEGER count
4678      INTEGER h9b
4679      INTEGER h10b
4680      INTEGER h1b
4681      INTEGER p5b
4682      INTEGER dimc
4683      INTEGER h9b_1
4684      INTEGER h10b_1
4685      INTEGER h1b_1
4686      INTEGER p5b_1
4687      INTEGER dim_common
4688      INTEGER dima_sort
4689      INTEGER dima
4690      INTEGER l_a_sort
4691      INTEGER k_a_sort
4692      INTEGER l_a
4693      INTEGER k_a
4694      INTEGER l_c
4695      INTEGER k_c
4696      EXTERNAL NXTASK
4697      nprocs = GA_NNODES()
4698      count = 0
4699      next = NXTASK(nprocs, 1)
4700      DO h9b = 1,noab
4701      DO h10b = h9b,noab
4702      DO h1b = 1,noab
4703      DO p5b = noab+1,noab+nvab
4704      IF (next.eq.count) THEN
4705      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-
4706     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
4707      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
4708     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
4709      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
4710     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
4711      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
4712     &ange+h1b-1) * int_mb(k_range+p5b-1)
4713      CALL TCE_RESTRICTED_4(h9b,h10b,h1b,p5b,h9b_1,h10b_1,h1b_1,p5b_1)
4714      dim_common = 1
4715      dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_m
4716     &b(k_range+h1b-1) * int_mb(k_range+p5b-1)
4717      dima = dim_common * dima_sort
4718      IF (dima .gt. 0) THEN
4719      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4720     & ERRQUIT('ipccsd_x2_4_2_1',0,MA_ERR)
4721      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4722     &ipccsd_x2_4_2_1',1,MA_ERR)
4723      IF ((h1b .le. p5b)) THEN
4724      if(.not.intorb) then
4725      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
4726     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
4727     &b+nvab) * (h9b_1 - 1)))))
4728      else
4729      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
4730     &(p5b_1
4731     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
4732     &b+nvab) * (h9b_1 - 1)))),p5b_1,h1b_1,h10b_1,h9b_1)
4733      end if
4734      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1)
4735     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1
4736     &),4,3,2,1,1.0d0)
4737      END IF
4738      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4_2_1',2,MA_ER
4739     &R)
4740      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4741     &ipccsd_x2_4_2_1',3,MA_ERR)
4742      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
4743     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h9b-1
4744     &),4,3,2,1,1.0d0)
4745      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
4746     & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h9b - 1))
4747     &)))
4748      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4_2_1',4,MA_ER
4749     &R)
4750      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4_2_1',5,
4751     &MA_ERR)
4752      END IF
4753      END IF
4754      END IF
4755      END IF
4756      next = NXTASK(nprocs, 1)
4757      END IF
4758      count = count + 1
4759      END DO
4760      END DO
4761      END DO
4762      END DO
4763      next = NXTASK(-nprocs, 1)
4764      call GA_SYNC()
4765      RETURN
4766      END
4767      SUBROUTINE OFFSET_ipccsd_x2_4_2_1(l_a_offset,k_a_offset,size)
4768C     $Id$
4769C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4770C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4771C     i2 ( h9 h10 h1 p5 )_v
4772      IMPLICIT NONE
4773#include "global.fh"
4774#include "mafdecls.fh"
4775#include "sym.fh"
4776#include "errquit.fh"
4777#include "tce.fh"
4778      INTEGER l_a_offset
4779      INTEGER k_a_offset
4780      INTEGER size
4781      INTEGER length
4782      INTEGER addr
4783      INTEGER h9b
4784      INTEGER h10b
4785      INTEGER h1b
4786      INTEGER p5b
4787      length = 0
4788      DO h9b = 1,noab
4789      DO h10b = h9b,noab
4790      DO h1b = 1,noab
4791      DO p5b = noab+1,noab+nvab
4792      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
4793     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
4794      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
4795     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
4796      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-
4797     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
4798      length = length + 1
4799      END IF
4800      END IF
4801      END IF
4802      END DO
4803      END DO
4804      END DO
4805      END DO
4806      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
4807     &set)) CALL ERRQUIT('ipccsd_x2_4_2_1',0,MA_ERR)
4808      int_mb(k_a_offset) = length
4809      addr = 0
4810      size = 0
4811      DO h9b = 1,noab
4812      DO h10b = h9b,noab
4813      DO h1b = 1,noab
4814      DO p5b = noab+1,noab+nvab
4815      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
4816     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
4817      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
4818     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
4819      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-
4820     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
4821      addr = addr + 1
4822      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab
4823     &* (h10b - 1 + noab * (h9b - 1)))
4824      int_mb(k_a_offset+length+addr) = size
4825      size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int
4826     &_mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
4827      END IF
4828      END IF
4829      END IF
4830      END DO
4831      END DO
4832      END DO
4833      END DO
4834      RETURN
4835      END
4836      SUBROUTINE ipccsd_x2_4_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
4837     &ffset)
4838C     $Id$
4839C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4840C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
4841C     i2 ( h9 h10 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 h10 p5 p6 )_v
4842      IMPLICIT NONE
4843#include "global.fh"
4844#include "mafdecls.fh"
4845#include "sym.fh"
4846#include "errquit.fh"
4847#include "tce.fh"
4848      INTEGER d_a
4849      INTEGER k_a_offset
4850      INTEGER d_b
4851      INTEGER k_b_offset
4852      INTEGER d_c
4853      INTEGER k_c_offset
4854      INTEGER NXTASK
4855      INTEGER next
4856      INTEGER nprocs
4857      INTEGER count
4858      INTEGER h9b
4859      INTEGER h10b
4860      INTEGER h1b
4861      INTEGER p5b
4862      INTEGER dimc
4863      INTEGER l_c_sort
4864      INTEGER k_c_sort
4865      INTEGER p6b
4866      INTEGER p6b_1
4867      INTEGER h1b_1
4868      INTEGER h9b_2
4869      INTEGER h10b_2
4870      INTEGER p5b_2
4871      INTEGER p6b_2
4872      INTEGER dim_common
4873      INTEGER dima_sort
4874      INTEGER dima
4875      INTEGER dimb_sort
4876      INTEGER dimb
4877      INTEGER l_a_sort
4878      INTEGER k_a_sort
4879      INTEGER l_a
4880      INTEGER k_a
4881      INTEGER l_b_sort
4882      INTEGER k_b_sort
4883      INTEGER l_b
4884      INTEGER k_b
4885      INTEGER l_c
4886      INTEGER k_c
4887      EXTERNAL NXTASK
4888      nprocs = GA_NNODES()
4889      count = 0
4890      next = NXTASK(nprocs, 1)
4891      DO h9b = 1,noab
4892      DO h10b = h9b,noab
4893      DO h1b = 1,noab
4894      DO p5b = noab+1,noab+nvab
4895      IF (next.eq.count) THEN
4896      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-
4897     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
4898      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
4899     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
4900      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
4901     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) T
4902     &HEN
4903      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
4904     &ange+h1b-1) * int_mb(k_range+p5b-1)
4905      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
4906     & ERRQUIT('ipccsd_x2_4_2_2',0,MA_ERR)
4907      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
4908      DO p6b = noab+1,noab+nvab
4909      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
4910      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
4911     &EN
4912      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
4913      CALL TCE_RESTRICTED_4(h9b,h10b,p5b,p6b,h9b_2,h10b_2,p5b_2,p6b_2)
4914      dim_common = int_mb(k_range+p6b-1)
4915      dima_sort = int_mb(k_range+h1b-1)
4916      dima = dim_common * dima_sort
4917      dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_m
4918     &b(k_range+p5b-1)
4919      dimb = dim_common * dimb_sort
4920      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
4921      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
4922     & ERRQUIT('ipccsd_x2_4_2_2',1,MA_ERR)
4923      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
4924     &ipccsd_x2_4_2_2',2,MA_ERR)
4925      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
4926     & - 1 + noab * (p6b_1 - noab - 1)))
4927      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
4928     &,int_mb(k_range+h1b-1),2,1,1.0d0)
4929      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4_2_2',3,MA_ER
4930     &R)
4931      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
4932     & ERRQUIT('ipccsd_x2_4_2_2',4,MA_ERR)
4933      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
4934     &ipccsd_x2_4_2_2',5,MA_ERR)
4935      IF ((p6b .lt. p5b)) THEN
4936      if(.not.intorb) then
4937      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
4938     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
4939     &b+nvab) * (h9b_2 - 1)))))
4940      else
4941      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4942     &(p5b_2
4943     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
4944     &b+nvab) * (h9b_2 - 1)))),p5b_2,p6b_2,h10b_2,h9b_2)
4945      end if
4946      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
4947     &,int_mb(k_range+h10b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1
4948     &),4,2,1,3,-1.0d0)
4949      END IF
4950      IF ((p5b .le. p6b)) THEN
4951      if(.not.intorb) then
4952      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
4953     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
4954     &b+nvab) * (h9b_2 - 1)))))
4955      else
4956      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
4957     &(p6b_2
4958     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
4959     &b+nvab) * (h9b_2 - 1)))),p6b_2,p5b_2,h10b_2,h9b_2)
4960      end if
4961      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
4962     &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
4963     &),3,2,1,4,1.0d0)
4964      END IF
4965      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_4_2_2',6,MA_ER
4966     &R)
4967      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
4968     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
4969     &t),dima_sort)
4970      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_4_2_2',7,
4971     &MA_ERR)
4972      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4_2_2',8,
4973     &MA_ERR)
4974      END IF
4975      END IF
4976      END IF
4977      END DO
4978      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
4979     &ipccsd_x2_4_2_2',9,MA_ERR)
4980      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
4981     &,int_mb(k_range+h10b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1
4982     &),3,2,4,1,-1.0d0/2.0d0)
4983      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
4984     & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h9b - 1))
4985     &)))
4986      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4_2_2',10,MA_E
4987     &RR)
4988      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_4_2_2',11
4989     &,MA_ERR)
4990      END IF
4991      END IF
4992      END IF
4993      next = NXTASK(nprocs, 1)
4994      END IF
4995      count = count + 1
4996      END DO
4997      END DO
4998      END DO
4999      END DO
5000      next = NXTASK(-nprocs, 1)
5001      call GA_SYNC()
5002      RETURN
5003      END
5004      SUBROUTINE ipccsd_x2_4_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
5005     &set)
5006C     $Id$
5007C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5008C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5009C     i1 ( h9 h10 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 h10 p5 p6 )_v
5010      IMPLICIT NONE
5011#include "global.fh"
5012#include "mafdecls.fh"
5013#include "sym.fh"
5014#include "errquit.fh"
5015#include "tce.fh"
5016      INTEGER d_a
5017      INTEGER k_a_offset
5018      INTEGER d_b
5019      INTEGER k_b_offset
5020      INTEGER d_c
5021      INTEGER k_c_offset
5022      INTEGER NXTASK
5023      INTEGER next
5024      INTEGER nprocs
5025      INTEGER count
5026      INTEGER h9b
5027      INTEGER h10b
5028      INTEGER h1b
5029      INTEGER h2b
5030      INTEGER dimc
5031      INTEGER l_c_sort
5032      INTEGER k_c_sort
5033      INTEGER p5b
5034      INTEGER p6b
5035      INTEGER p5b_1
5036      INTEGER p6b_1
5037      INTEGER h1b_1
5038      INTEGER h2b_1
5039      INTEGER h9b_2
5040      INTEGER h10b_2
5041      INTEGER p5b_2
5042      INTEGER p6b_2
5043      INTEGER dim_common
5044      INTEGER dima_sort
5045      INTEGER dima
5046      INTEGER dimb_sort
5047      INTEGER dimb
5048      INTEGER l_a_sort
5049      INTEGER k_a_sort
5050      INTEGER l_a
5051      INTEGER k_a
5052      INTEGER l_b_sort
5053      INTEGER k_b_sort
5054      INTEGER l_b
5055      INTEGER k_b
5056      INTEGER nsuperp(2)
5057      INTEGER isuperp
5058      INTEGER l_c
5059      INTEGER k_c
5060      DOUBLE PRECISION FACTORIAL
5061      EXTERNAL NXTASK
5062      EXTERNAL FACTORIAL
5063      nprocs = GA_NNODES()
5064      count = 0
5065      next = NXTASK(nprocs, 1)
5066      DO h9b = 1,noab
5067      DO h10b = h9b,noab
5068      DO h1b = 1,noab
5069      DO h2b = h1b,noab
5070      IF (next.eq.count) THEN
5071      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-
5072     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
5073      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
5074     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
5075      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
5076     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T
5077     &HEN
5078      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
5079     &ange+h1b-1) * int_mb(k_range+h2b-1)
5080      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
5081     & ERRQUIT('ipccsd_x2_4_3',0,MA_ERR)
5082      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
5083      DO p5b = noab+1,noab+nvab
5084      DO p6b = p5b,noab+nvab
5085      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h
5086     &1b-1)+int_mb(k_spin+h2b-1)) THEN
5087      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb(
5088     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
5089      CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1)
5090      CALL TCE_RESTRICTED_4(h9b,h10b,p5b,p6b,h9b_2,h10b_2,p5b_2,p6b_2)
5091      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1)
5092      dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
5093      dima = dim_common * dima_sort
5094      dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1)
5095      dimb = dim_common * dimb_sort
5096      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
5097      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
5098     & ERRQUIT('ipccsd_x2_4_3',1,MA_ERR)
5099      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
5100     &ipccsd_x2_4_3',2,MA_ERR)
5101      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
5102     & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_
5103     &1 - noab - 1)))))
5104      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
5105     &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
5106     &,4,3,2,1,1.0d0)
5107      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_4_3',3,MA_ERR)
5108      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
5109     & ERRQUIT('ipccsd_x2_4_3',4,MA_ERR)
5110      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
5111     &ipccsd_x2_4_3',5,MA_ERR)
5112      if(.not.intorb) then
5113      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
5114     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
5115     &b+nvab) * (h9b_2 - 1)))))
5116      else
5117      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
5118     &(p6b_2
5119     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
5120     &b+nvab) * (h9b_2 - 1)))),p6b_2,p5b_2,h10b_2,h9b_2)
5121      end if
5122      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
5123     &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
5124     &),2,1,4,3,1.0d0)
5125      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_4_3',6,MA_ERR)
5126      nsuperp(1) = 1
5127      nsuperp(2) = 1
5128      isuperp = 1
5129      IF (p5b .eq. p6b) THEN
5130      nsuperp(isuperp) = nsuperp(isuperp) + 1
5131      ELSE
5132      isuperp = isuperp + 1
5133      END IF
5134      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
5135     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
5136     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
5137      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_4_3',7,MA
5138     &_ERR)
5139      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_4_3',8,MA
5140     &_ERR)
5141      END IF
5142      END IF
5143      END IF
5144      END DO
5145      END DO
5146      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
5147     &ipccsd_x2_4_3',9,MA_ERR)
5148      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1
5149     &),int_mb(k_range+h9b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1
5150     &),2,1,4,3,1.0d0/2.0d0)
5151      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
5152     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h9b - 1)))))
5153      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_4_3',10,MA_ERR
5154     &)
5155      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_4_3',11,M
5156     &A_ERR)
5157      END IF
5158      END IF
5159      END IF
5160      next = NXTASK(nprocs, 1)
5161      END IF
5162      count = count + 1
5163      END DO
5164      END DO
5165      END DO
5166      END DO
5167      next = NXTASK(-nprocs, 1)
5168      call GA_SYNC()
5169      RETURN
5170      END
5171      SUBROUTINE ipccsd_x2_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
5172     &t)
5173C     $Id$
5174C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5175C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5176C     i0 ( p3 p4 h1 h2 )_xv + = -1 * P( 4 ) * Sum ( p8 h7 ) * x ( p3 p8 h1 h7 )_x * i1 ( h7 p4 h2 p8 )_v
5177      IMPLICIT NONE
5178#include "global.fh"
5179#include "mafdecls.fh"
5180#include "sym.fh"
5181#include "errquit.fh"
5182#include "tce.fh"
5183#include "stdio.fh"
5184      INTEGER d_a
5185      INTEGER k_a_offset
5186      INTEGER d_b
5187      INTEGER k_b_offset
5188      INTEGER d_c
5189      INTEGER k_c_offset
5190      INTEGER NXTASK
5191      INTEGER next
5192      INTEGER nprocs
5193      INTEGER count
5194      INTEGER p3b
5195      INTEGER p4b
5196      INTEGER h1b
5197      INTEGER h2b
5198      INTEGER dimc
5199      INTEGER l_c_sort
5200      INTEGER k_c_sort
5201      INTEGER p8b
5202      INTEGER h7b
5203      INTEGER p3b_1
5204      INTEGER p8b_1
5205      INTEGER h1b_1
5206      INTEGER h7b_1
5207      INTEGER p4b_2
5208      INTEGER h7b_2
5209      INTEGER h2b_2
5210      INTEGER p8b_2
5211      INTEGER dim_common
5212      INTEGER dima_sort
5213      INTEGER dima
5214      INTEGER dimb_sort
5215      INTEGER dimb
5216      INTEGER l_a_sort
5217      INTEGER k_a_sort
5218      INTEGER l_a
5219      INTEGER k_a
5220      INTEGER l_b_sort
5221      INTEGER k_b_sort
5222      INTEGER l_b
5223      INTEGER k_b
5224      INTEGER l_c
5225      INTEGER k_c
5226      EXTERNAL NXTASK
5227      nprocs = GA_NNODES()
5228      count = 0
5229      next = NXTASK(nprocs, 1)
5230ckbn      DO p3b = noab+1,noab+nvab
5231      DO p3b = 1,1
5232      DO p4b = noab+1,noab+nvab
5233      DO h1b = 1,noab
5234      DO h2b = 1,noab
5235      IF (next.eq.count) THEN
5236ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
5237ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
5238      IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p4b-1
5239     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
5240ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
5241ckbn     &1b-1)+int_mb(k_spin+h2b-1)) THEN
5242      IF (ip_unused_spin +int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
5243     &1b-1)+int_mb(k_spin+h2b-1)) THEN
5244ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
5245ckbn     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH
5246ckbn     &EN
5247      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
5248     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_v)) TH
5249     &EN
5250ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
5251ckbn     &nge+h1b-1) * int_mb(k_range+h2b-1)
5252      dimc = 1 * int_mb(k_range+p4b-1) * int_mb(k_ra
5253     &nge+h1b-1) * int_mb(k_range+h2b-1)
5254      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
5255     & ERRQUIT('ipccsd_x2_5',0,MA_ERR)
5256      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
5257      DO p8b = noab+1,noab+nvab
5258      DO h7b = 1,noab
5259ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
5260ckbn     &1b-1)+int_mb(k_spin+h7b-1)) THEN
5261      IF (ip_unused_spin +int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
5262     &1b-1)+int_mb(k_spin+h7b-1)) THEN
5263ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
5264ckbn     &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN
5265      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
5266     &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN
5267      CALL TCE_RESTRICTED_4(p3b,p8b,h1b,h7b,p3b_1,p8b_1,h1b_1,h7b_1)
5268      CALL TCE_RESTRICTED_4(p4b,h7b,h2b,p8b,p4b_2,h7b_2,h2b_2,p8b_2)
5269      dim_common = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1)
5270ckbn      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
5271      dima_sort = 1 * int_mb(k_range+h1b-1)
5272      dima = dim_common * dima_sort
5273      dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h2b-1)
5274      dimb = dim_common * dimb_sort
5275      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
5276      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
5277     & ERRQUIT('ipccsd_x2_5',1,MA_ERR)
5278      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
5279     &ipccsd_x2_5',2,MA_ERR)
5280c      write(LuOut,*) "I am here 1."
5281c      call util_flush(LuOut)
5282ckbn      IF ((p8b .lt. p3b) .and. (h7b .lt. h1b)) THEN
5283      IF ( (h7b .lt. h1b)) THEN
5284      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
5285     & - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_
5286     &1 - noab - 1)))))
5287ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
5288ckbn     &,int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1)
5289ckbn     &,4,2,3,1,1.0d0)
5290      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
5291     &,1,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1)
5292     &,4,2,3,1,1.0d0)
5293      END IF
5294c      write(LuOut,*) "I am here 2."
5295c      call util_flush(LuOut)
5296ckbn`      IF ((p8b .lt. p3b) .and. (h1b .le. h7b)) THEN
5297      IF ( (h1b .le. h7b)) THEN
5298      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
5299     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_
5300     &1 - noab - 1)))))
5301ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
5302ckbn     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1)
5303ckbn     &,3,2,4,1,-1.0d0)
5304      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
5305     &,1,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1)
5306     &,3,2,4,1,-1.0d0)
5307      END IF
5308c      write(LuOut,*) "I am here 2.1"
5309c      call util_flush(LuOut)
5310ckbn      IF ((p3b .le. p8b) .and. (h7b .lt. h1b)) THEN
5311ckbn      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
5312ckbn     & - 1 + noab * (h7b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_
5313ckbn     &1 - noab - 1)))))
5314ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
5315ckbn     &,int_mb(k_range+p8b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1)
5316ckbn     &,4,1,3,2,-1.0d0)
5317ckbn      END IF
5318ckbn      IF ((p3b .le. p8b) .and. (h1b .le. h7b)) THEN
5319ckbn      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
5320ckbn     & - 1 + noab * (h1b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_
5321ckbn     &1 - noab - 1)))))
5322ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
5323ckbn     &,int_mb(k_range+p8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1)
5324ckbn     &,3,1,4,2,1.0d0)
5325ckbn      END IF
5326      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_5',3,MA_ERR)
5327      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
5328     & ERRQUIT('ipccsd_x2_5',4,MA_ERR)
5329      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
5330     &ipccsd_x2_5',5,MA_ERR)
5331      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
5332     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (p4b_
5333     &2 - noab - 1)))))
5334      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
5335     &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1)
5336     &,3,1,2,4,1.0d0)
5337      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_5',6,MA_ERR)
5338      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
5339     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
5340     &t),dima_sort)
5341      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_5',7,MA_E
5342     &RR)
5343      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_5',8,MA_E
5344     &RR)
5345      END IF
5346      END IF
5347      END IF
5348      END DO
5349      END DO
5350      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
5351     &ipccsd_x2_5',9,MA_ERR)
5352ckbn      IF ((p3b .le. p4b) .and. (h1b .le. h2b)) THEN
5353ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
5354ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
5355ckbn     &,4,2,3,1,-1.0d0)
5356ckbn      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
5357ckbn     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
5358ckbn     & - 1)))))
5359ckbn      END IF
5360ckbn      IF ((p3b .le. p4b) .and. (h2b .le. h1b)) THEN
5361ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
5362ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
5363ckbn     &,4,2,1,3,1.0d0)
5364ckbn      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
5365ckbn     & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
5366ckbn     & - 1)))))
5367ckbn      END IF
5368ckbn      IF ((p4b .le. p3b) .and. (h1b .le. h2b)) THEN
5369c      write(LuOut,*) "I am here 3."
5370c      call util_flush(LuOut)
5371      IF ((h1b .le. h2b)) THEN
5372ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
5373ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
5374ckbn     &,2,4,3,1,1.0d0)
5375      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
5376     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),1
5377     &,2,4,3,1,1.0d0)
5378      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
5379     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
5380     & - 1)))))
5381      END IF
5382ckbn      IF ((p4b .le. p3b) .and. (h2b .le. h1b)) THEN
5383      IF ( (h2b .le. h1b)) THEN
5384ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
5385ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
5386ckbn     &,2,4,1,3,-1.0d0)
5387      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
5388     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),1
5389     &,2,4,1,3,-1.0d0)
5390      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
5391     & 1 + noab * (h2b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
5392     & - 1)))))
5393      END IF
5394c      write(LuOut,*) "I am here 4."
5395c      call util_flush(LuOut)
5396      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_5',10,MA_ERR)
5397      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_5',11,MA_
5398     &ERR)
5399      END IF
5400      END IF
5401      END IF
5402      next = NXTASK(nprocs, 1)
5403      END IF
5404      count = count + 1
5405      END DO
5406      END DO
5407      END DO
5408      END DO
5409      next = NXTASK(-nprocs, 1)
5410      call GA_SYNC()
5411      RETURN
5412      END
5413      SUBROUTINE ipccsd_x2_5_1(d_a,k_a_offset,d_c,k_c_offset)
5414C     $Id$
5415C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5416C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5417C     i1 ( h7 p3 h1 p8 )_v + = 1 * v ( h7 p3 h1 p8 )_v
5418      IMPLICIT NONE
5419#include "global.fh"
5420#include "mafdecls.fh"
5421#include "sym.fh"
5422#include "errquit.fh"
5423#include "tce.fh"
5424      INTEGER d_a
5425      INTEGER k_a_offset
5426      INTEGER d_c
5427      INTEGER k_c_offset
5428      INTEGER NXTASK
5429      INTEGER next
5430      INTEGER nprocs
5431      INTEGER count
5432      INTEGER p3b
5433      INTEGER h7b
5434      INTEGER h1b
5435      INTEGER p8b
5436      INTEGER dimc
5437      INTEGER p3b_1
5438      INTEGER h7b_1
5439      INTEGER h1b_1
5440      INTEGER p8b_1
5441      INTEGER dim_common
5442      INTEGER dima_sort
5443      INTEGER dima
5444      INTEGER l_a_sort
5445      INTEGER k_a_sort
5446      INTEGER l_a
5447      INTEGER k_a
5448      INTEGER l_c
5449      INTEGER k_c
5450      EXTERNAL NXTASK
5451      nprocs = GA_NNODES()
5452      count = 0
5453      next = NXTASK(nprocs, 1)
5454      DO p3b = noab+1,noab+nvab
5455      DO h7b = 1,noab
5456      DO h1b = 1,noab
5457      DO p8b = noab+1,noab+nvab
5458      IF (next.eq.count) THEN
5459      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h7b-1
5460     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN
5461      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h
5462     &1b-1)+int_mb(k_spin+p8b-1)) THEN
5463      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb(
5464     &k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN
5465      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra
5466     &nge+h1b-1) * int_mb(k_range+p8b-1)
5467      CALL TCE_RESTRICTED_4(p3b,h7b,h1b,p8b,p3b_1,h7b_1,h1b_1,p8b_1)
5468      dim_common = 1
5469      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h7b-1) * int_mb
5470     &(k_range+h1b-1) * int_mb(k_range+p8b-1)
5471      dima = dim_common * dima_sort
5472      IF (dima .gt. 0) THEN
5473      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
5474     & ERRQUIT('ipccsd_x2_5_1',0,MA_ERR)
5475      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
5476     &ipccsd_x2_5_1',1,MA_ERR)
5477      IF ((h7b .le. p3b) .and. (h1b .le. p8b)) THEN
5478      if(.not.intorb) then
5479      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1
5480     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
5481     &+nvab) * (h7b_1 - 1)))))
5482      else
5483      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
5484     &(p8b_1
5485     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
5486     &+nvab) * (h7b_1 - 1)))),p8b_1,h1b_1,p3b_1,h7b_1)
5487      end if
5488      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
5489     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+p8b-1)
5490     &,4,3,1,2,1.0d0)
5491      END IF
5492      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_5_1',2,MA_ERR)
5493      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
5494     &ipccsd_x2_5_1',3,MA_ERR)
5495      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
5496     &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1)
5497     &,4,3,2,1,1.0d0)
5498      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
5499     & noab - 1 + nvab * (h1b - 1 + noab * (h7b - 1 + noab * (p3b - noab
5500     & - 1)))))
5501      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_5_1',4,MA_ERR)
5502      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_5_1',5,MA
5503     &_ERR)
5504      END IF
5505      END IF
5506      END IF
5507      END IF
5508      next = NXTASK(nprocs, 1)
5509      END IF
5510      count = count + 1
5511      END DO
5512      END DO
5513      END DO
5514      END DO
5515      next = NXTASK(-nprocs, 1)
5516      call GA_SYNC()
5517      RETURN
5518      END
5519      SUBROUTINE OFFSET_ipccsd_x2_5_1(l_a_offset,k_a_offset,size)
5520C     $Id$
5521C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5522C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5523C     i1 ( h7 p3 h1 p8 )_v
5524      IMPLICIT NONE
5525#include "global.fh"
5526#include "mafdecls.fh"
5527#include "sym.fh"
5528#include "errquit.fh"
5529#include "tce.fh"
5530      INTEGER l_a_offset
5531      INTEGER k_a_offset
5532      INTEGER size
5533      INTEGER length
5534      INTEGER addr
5535      INTEGER p3b
5536      INTEGER h7b
5537      INTEGER h1b
5538      INTEGER p8b
5539      length = 0
5540      DO p3b = noab+1,noab+nvab
5541      DO h7b = 1,noab
5542      DO h1b = 1,noab
5543      DO p8b = noab+1,noab+nvab
5544      IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
5545     &1b-1)+int_mb(k_spin+p8b-1)) THEN
5546      IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
5547     &k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN
5548      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1
5549     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN
5550      length = length + 1
5551      END IF
5552      END IF
5553      END IF
5554      END DO
5555      END DO
5556      END DO
5557      END DO
5558      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
5559     &set)) CALL ERRQUIT('ipccsd_x2_5_1',0,MA_ERR)
5560      int_mb(k_a_offset) = length
5561      addr = 0
5562      size = 0
5563      DO p3b = noab+1,noab+nvab
5564      DO h7b = 1,noab
5565      DO h1b = 1,noab
5566      DO p8b = noab+1,noab+nvab
5567      IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
5568     &1b-1)+int_mb(k_spin+p8b-1)) THEN
5569      IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
5570     &k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN
5571      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1
5572     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN
5573      addr = addr + 1
5574      int_mb(k_a_offset+addr) = p8b - noab - 1 + nvab * (h1b - 1 + noab
5575     &* (h7b - 1 + noab * (p3b - noab - 1)))
5576      int_mb(k_a_offset+length+addr) = size
5577      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h7b-1) * int_
5578     &mb(k_range+h1b-1) * int_mb(k_range+p8b-1)
5579      END IF
5580      END IF
5581      END IF
5582      END DO
5583      END DO
5584      END DO
5585      END DO
5586      RETURN
5587      END
5588      SUBROUTINE ipccsd_x2_5_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
5589     &set)
5590C     $Id$
5591C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5592C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5593C     i1 ( h7 p3 h1 p8 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h7 p3 p5 p8 )_v
5594      IMPLICIT NONE
5595#include "global.fh"
5596#include "mafdecls.fh"
5597#include "sym.fh"
5598#include "errquit.fh"
5599#include "tce.fh"
5600      INTEGER d_a
5601      INTEGER k_a_offset
5602      INTEGER d_b
5603      INTEGER k_b_offset
5604      INTEGER d_c
5605      INTEGER k_c_offset
5606      INTEGER NXTASK
5607      INTEGER next
5608      INTEGER nprocs
5609      INTEGER count
5610      INTEGER p3b
5611      INTEGER h7b
5612      INTEGER h1b
5613      INTEGER p8b
5614      INTEGER dimc
5615      INTEGER l_c_sort
5616      INTEGER k_c_sort
5617      INTEGER p5b
5618      INTEGER p5b_1
5619      INTEGER h1b_1
5620      INTEGER p3b_2
5621      INTEGER h7b_2
5622      INTEGER p8b_2
5623      INTEGER p5b_2
5624      INTEGER dim_common
5625      INTEGER dima_sort
5626      INTEGER dima
5627      INTEGER dimb_sort
5628      INTEGER dimb
5629      INTEGER l_a_sort
5630      INTEGER k_a_sort
5631      INTEGER l_a
5632      INTEGER k_a
5633      INTEGER l_b_sort
5634      INTEGER k_b_sort
5635      INTEGER l_b
5636      INTEGER k_b
5637      INTEGER l_c
5638      INTEGER k_c
5639      EXTERNAL NXTASK
5640      nprocs = GA_NNODES()
5641      count = 0
5642      next = NXTASK(nprocs, 1)
5643      DO p3b = noab+1,noab+nvab
5644      DO h7b = 1,noab
5645      DO h1b = 1,noab
5646      DO p8b = noab+1,noab+nvab
5647      IF (next.eq.count) THEN
5648      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h7b-1
5649     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN
5650      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h
5651     &1b-1)+int_mb(k_spin+p8b-1)) THEN
5652      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb(
5653     &k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
5654     &EN
5655      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra
5656     &nge+h1b-1) * int_mb(k_range+p8b-1)
5657      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
5658     & ERRQUIT('ipccsd_x2_5_2',0,MA_ERR)
5659      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
5660      DO p5b = noab+1,noab+nvab
5661      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
5662      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
5663     &EN
5664      CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1)
5665      CALL TCE_RESTRICTED_4(p3b,h7b,p8b,p5b,p3b_2,h7b_2,p8b_2,p5b_2)
5666      dim_common = int_mb(k_range+p5b-1)
5667      dima_sort = int_mb(k_range+h1b-1)
5668      dima = dim_common * dima_sort
5669      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h7b-1) * int_mb
5670     &(k_range+p8b-1)
5671      dimb = dim_common * dimb_sort
5672      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
5673      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
5674     & ERRQUIT('ipccsd_x2_5_2',1,MA_ERR)
5675      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
5676     &ipccsd_x2_5_2',2,MA_ERR)
5677      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
5678     & - 1 + noab * (p5b_1 - noab - 1)))
5679      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
5680     &,int_mb(k_range+h1b-1),2,1,1.0d0)
5681      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_5_2',3,MA_ERR)
5682      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
5683     & ERRQUIT('ipccsd_x2_5_2',4,MA_ERR)
5684      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
5685     &ipccsd_x2_5_2',5,MA_ERR)
5686      IF ((h7b .le. p3b) .and. (p5b .le. p8b)) THEN
5687      if(.not.intorb) then
5688      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
5689     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
5690     &+nvab) * (h7b_2 - 1)))))
5691      else
5692      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
5693     &(p8b_2
5694     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
5695     &+nvab) * (h7b_2 - 1)))),p8b_2,p5b_2,p3b_2,h7b_2)
5696      end if
5697      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
5698     &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1)
5699     &,4,1,2,3,1.0d0)
5700      END IF
5701      IF ((h7b .le. p3b) .and. (p8b .lt. p5b)) THEN
5702      if(.not.intorb) then
5703      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
5704     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
5705     &+nvab) * (h7b_2 - 1)))))
5706      else
5707      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
5708     &(p5b_2
5709     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
5710     &+nvab) * (h7b_2 - 1)))),p5b_2,p8b_2,p3b_2,h7b_2)
5711      end if
5712      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
5713     &,int_mb(k_range+p3b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1)
5714     &,3,1,2,4,-1.0d0)
5715      END IF
5716      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_5_2',6,MA_ERR)
5717      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
5718     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
5719     &t),dima_sort)
5720      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_5_2',7,MA
5721     &_ERR)
5722      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_5_2',8,MA
5723     &_ERR)
5724      END IF
5725      END IF
5726      END IF
5727      END DO
5728      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
5729     &ipccsd_x2_5_2',9,MA_ERR)
5730      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
5731     &,int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
5732     &,3,2,4,1,1.0d0)
5733      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
5734     & noab - 1 + nvab * (h1b - 1 + noab * (h7b - 1 + noab * (p3b - noab
5735     & - 1)))))
5736      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_5_2',10,MA_ERR
5737     &)
5738      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_5_2',11,M
5739     &A_ERR)
5740      END IF
5741      END IF
5742      END IF
5743      next = NXTASK(nprocs, 1)
5744      END IF
5745      count = count + 1
5746      END DO
5747      END DO
5748      END DO
5749      END DO
5750      next = NXTASK(-nprocs, 1)
5751      call GA_SYNC()
5752      RETURN
5753      END
5754      SUBROUTINE ipccsd_x2_6(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
5755     &t)
5756C     $Id$
5757C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5758C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5759C     i0 ( p3 p4 h1 h2 )_vxt + = 1 * P( 2 ) * Sum ( h10 ) * t ( p3 h10 )_t * i1 ( h10 p4 h1 h2 )_vx
5760      IMPLICIT NONE
5761#include "global.fh"
5762#include "mafdecls.fh"
5763#include "sym.fh"
5764#include "errquit.fh"
5765#include "tce.fh"
5766      INTEGER d_a
5767      INTEGER k_a_offset
5768      INTEGER d_b
5769      INTEGER k_b_offset
5770      INTEGER d_c
5771      INTEGER k_c_offset
5772      INTEGER NXTASK
5773      INTEGER next
5774      INTEGER nprocs
5775      INTEGER count
5776      INTEGER p3b
5777      INTEGER p4b
5778      INTEGER h1b
5779      INTEGER h2b
5780      INTEGER dimc
5781      INTEGER l_c_sort
5782      INTEGER k_c_sort
5783      INTEGER h10b
5784      INTEGER p3b_1
5785      INTEGER h10b_1
5786      INTEGER p4b_2
5787      INTEGER h10b_2
5788      INTEGER h1b_2
5789      INTEGER h2b_2
5790      INTEGER dim_common
5791      INTEGER dima_sort
5792      INTEGER dima
5793      INTEGER dimb_sort
5794      INTEGER dimb
5795      INTEGER l_a_sort
5796      INTEGER k_a_sort
5797      INTEGER l_a
5798      INTEGER k_a
5799      INTEGER l_b_sort
5800      INTEGER k_b_sort
5801      INTEGER l_b
5802      INTEGER k_b
5803      INTEGER l_c
5804      INTEGER k_c
5805      EXTERNAL NXTASK
5806      nprocs = GA_NNODES()
5807      count = 0
5808      next = NXTASK(nprocs, 1)
5809      DO p3b = noab+1,noab+nvab
5810ckbn      DO p4b = noab+1,noab+nvab
5811      DO p4b = 1,1
5812      DO h1b = 1,noab
5813      DO h2b = h1b,noab
5814      IF (next.eq.count) THEN
5815ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
5816ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
5817      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ip_unused_spin
5818     & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
5819ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
5820ckbn     &1b-1)+int_mb(k_spin+h2b-1)) THEN
5821      IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h
5822     &1b-1)+int_mb(k_spin+h2b-1)) THEN
5823ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
5824ckbn     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x
5825ckbn     &,irrep_t))) THEN
5826      IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb(
5827     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x
5828     &,irrep_t))) THEN
5829ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
5830ckbn     &nge+h1b-1) * int_mb(k_range+h2b-1)
5831      dimc = int_mb(k_range+p3b-1) * 1 * int_mb(k_ra
5832     &nge+h1b-1) * int_mb(k_range+h2b-1)
5833      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
5834     & ERRQUIT('ipccsd_x2_6',0,MA_ERR)
5835      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
5836      DO h10b = 1,noab
5837      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h10b-1)) THEN
5838      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h10b-1)) .eq. irrep_t) T
5839     &HEN
5840      CALL TCE_RESTRICTED_2(p3b,h10b,p3b_1,h10b_1)
5841      CALL TCE_RESTRICTED_4(p4b,h10b,h1b,h2b,p4b_2,h10b_2,h1b_2,h2b_2)
5842      dim_common = int_mb(k_range+h10b-1)
5843      dima_sort = int_mb(k_range+p3b-1)
5844      dima = dim_common * dima_sort
5845ckbn      dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1) * int_mb
5846ckbn     &(k_range+h2b-1)
5847      dimb_sort = 1 * int_mb(k_range+h1b-1) * int_mb
5848     &(k_range+h2b-1)
5849      dimb = dim_common * dimb_sort
5850      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
5851      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
5852     & ERRQUIT('ipccsd_x2_6',1,MA_ERR)
5853      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
5854     &ipccsd_x2_6',2,MA_ERR)
5855      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_
5856     &1 - 1 + noab * (p3b_1 - noab - 1)))
5857      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
5858     &,int_mb(k_range+h10b-1),1,2,1.0d0)
5859      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6',3,MA_ERR)
5860      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
5861     & ERRQUIT('ipccsd_x2_6',4,MA_ERR)
5862      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
5863     &ipccsd_x2_6',5,MA_ERR)
5864      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
5865     & - 1 + noab * (h1b_2 - 1 + noab * (h10b_2 - 1 + noab * (p4b_2 - no
5866     &ab - 1)))))
5867ckbn      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
5868ckbn     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
5869ckbn     &),4,3,1,2,1.0d0)
5870      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),1
5871     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
5872     &),4,3,1,2,1.0d0)
5873      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6',6,MA_ERR)
5874      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
5875     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
5876     &t),dima_sort)
5877      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6',7,MA_E
5878     &RR)
5879      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6',8,MA_E
5880     &RR)
5881      END IF
5882      END IF
5883      END IF
5884      END DO
5885      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
5886     &ipccsd_x2_6',9,MA_ERR)
5887ckbn      IF ((p3b .le. p4b)) THEN
5888ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
5889ckbn     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
5890ckbn     &,4,3,2,1,1.0d0)
5891      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
5892     &,int_mb(k_range+h1b-1),1,int_mb(k_range+p3b-1)
5893     &,4,3,2,1,1.0d0)
5894      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
5895     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
5896     & - 1)))))
5897ckbn      END IF
5898ckbn      IF ((p4b .le. p3b)) THEN
5899ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
5900ckbn     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
5901ckbn     &,3,4,2,1,-1.0d0)
5902ckbn      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
5903ckbn     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
5904ckbn     & - 1)))))
5905ckbn      END IF
5906      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6',10,MA_ERR)
5907      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6',11,MA_
5908     &ERR)
5909      END IF
5910      END IF
5911      END IF
5912      next = NXTASK(nprocs, 1)
5913      END IF
5914      count = count + 1
5915      END DO
5916      END DO
5917      END DO
5918      END DO
5919      next = NXTASK(-nprocs, 1)
5920      call GA_SYNC()
5921      RETURN
5922      END
5923      SUBROUTINE ipccsd_x2_6_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
5924     &set)
5925C     $Id$
5926C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5927C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5928C     i1 ( h10 p3 h1 h2 )_vx + = -1 * Sum ( h8 ) * x ( p3 h8 )_x * i2 ( h8 h10 h1 h2 )_v
5929      IMPLICIT NONE
5930#include "global.fh"
5931#include "mafdecls.fh"
5932#include "sym.fh"
5933#include "errquit.fh"
5934#include "tce.fh"
5935      INTEGER d_a
5936      INTEGER k_a_offset
5937      INTEGER d_b
5938      INTEGER k_b_offset
5939      INTEGER d_c
5940      INTEGER k_c_offset
5941      INTEGER NXTASK
5942      INTEGER next
5943      INTEGER nprocs
5944      INTEGER count
5945      INTEGER p3b
5946      INTEGER h10b
5947      INTEGER h1b
5948      INTEGER h2b
5949      INTEGER dimc
5950      INTEGER l_c_sort
5951      INTEGER k_c_sort
5952      INTEGER h8b
5953      INTEGER p3b_1
5954      INTEGER h8b_1
5955      INTEGER h10b_2
5956      INTEGER h8b_2
5957      INTEGER h1b_2
5958      INTEGER h2b_2
5959      INTEGER dim_common
5960      INTEGER dima_sort
5961      INTEGER dima
5962      INTEGER dimb_sort
5963      INTEGER dimb
5964      INTEGER l_a_sort
5965      INTEGER k_a_sort
5966      INTEGER l_a
5967      INTEGER k_a
5968      INTEGER l_b_sort
5969      INTEGER k_b_sort
5970      INTEGER l_b
5971      INTEGER k_b
5972      INTEGER l_c
5973      INTEGER k_c
5974      EXTERNAL NXTASK
5975      nprocs = GA_NNODES()
5976      count = 0
5977      next = NXTASK(nprocs, 1)
5978ckbn      DO p3b = noab+1,noab+nvab
5979      DO p3b = 1,1
5980      DO h10b = 1,noab
5981      DO h1b = 1,noab
5982      DO h2b = h1b,noab
5983      IF (next.eq.count) THEN
5984ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
5985ckbn     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
5986      IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+h10b-
5987     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
5988ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
5989ckbn     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
5990      IF (ip_unused_spin +int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
5991     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
5992ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
5993ckbn     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T
5994ckbn     &HEN
5995      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+h10b-1),ieor(int_mb
5996     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T
5997     &HEN
5998ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
5999ckbn     &ange+h1b-1) * int_mb(k_range+h2b-1)
6000      dimc = 1 * int_mb(k_range+h10b-1) * int_mb(k_r
6001     &ange+h1b-1) * int_mb(k_range+h2b-1)
6002      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
6003     & ERRQUIT('ipccsd_x2_6_1',0,MA_ERR)
6004      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
6005      DO h8b = 1,noab
6006ckbn      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h8b-1)) THEN
6007      IF (ip_unused_spin .eq. int_mb(k_spin+h8b-1)) THEN
6008ckbn      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h8b-1)) .eq. irrep_x) TH
6009ckbn     &EN
6010      IF (ieor(ip_unused_sym ,int_mb(k_sym+h8b-1)) .eq. irrep_x) TH
6011     &EN
6012      CALL TCE_RESTRICTED_2(p3b,h8b,p3b_1,h8b_1)
6013      CALL TCE_RESTRICTED_4(h10b,h8b,h1b,h2b,h10b_2,h8b_2,h1b_2,h2b_2)
6014      dim_common = int_mb(k_range+h8b-1)
6015ckbn      dima_sort = int_mb(k_range+p3b-1)
6016      dima_sort = 1
6017      dima = dim_common * dima_sort
6018      dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h1b-1) * int_m
6019     &b(k_range+h2b-1)
6020      dimb = dim_common * dimb_sort
6021      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
6022      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
6023     & ERRQUIT('ipccsd_x2_6_1',1,MA_ERR)
6024      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
6025     &ipccsd_x2_6_1',2,MA_ERR)
6026      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
6027     & - 1 + noab * (p3b_1 - noab - 1)))
6028ckbn      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
6029ckbn     &,int_mb(k_range+h8b-1),1,2,1.0d0)
6030      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),1
6031     &,int_mb(k_range+h8b-1),1,2,1.0d0)
6032      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1',3,MA_ERR)
6033      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
6034     & ERRQUIT('ipccsd_x2_6_1',4,MA_ERR)
6035      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
6036     &ipccsd_x2_6_1',5,MA_ERR)
6037      IF ((h8b .le. h10b)) THEN
6038      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
6039     & - 1 + noab * (h1b_2 - 1 + noab * (h10b_2 - 1 + noab * (h8b_2 - 1)
6040     &))))
6041      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
6042     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
6043     &),4,3,2,1,1.0d0)
6044      END IF
6045      IF ((h10b .lt. h8b)) THEN
6046      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
6047     & - 1 + noab * (h1b_2 - 1 + noab * (h8b_2 - 1 + noab * (h10b_2 - 1)
6048     &))))
6049      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
6050     &),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
6051     &),4,3,1,2,-1.0d0)
6052      END IF
6053      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_1',6,MA_ERR)
6054      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
6055     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
6056     &t),dima_sort)
6057      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_1',7,MA
6058     &_ERR)
6059      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1',8,MA
6060     &_ERR)
6061      END IF
6062      END IF
6063      END IF
6064      END DO
6065      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
6066     &ipccsd_x2_6_1',9,MA_ERR)
6067ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
6068ckbn     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+p3b-1
6069ckbn     &),4,3,2,1,-1.0d0)
6070      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
6071     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),1
6072     & ,4,3,2,1,-1.0d0)
6073      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
6074     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
6075     &)))
6076      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1',10,MA_ERR
6077     &)
6078      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_1',11,M
6079     &A_ERR)
6080      END IF
6081      END IF
6082      END IF
6083      next = NXTASK(nprocs, 1)
6084      END IF
6085      count = count + 1
6086      END DO
6087      END DO
6088      END DO
6089      END DO
6090      next = NXTASK(-nprocs, 1)
6091      call GA_SYNC()
6092      RETURN
6093      END
6094      SUBROUTINE OFFSET_ipccsd_x2_6_1(l_a_offset,k_a_offset,size)
6095C     $Id$
6096C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
6097C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
6098C     i1 ( h10 p3 h1 h2 )_vx
6099      IMPLICIT NONE
6100#include "global.fh"
6101#include "mafdecls.fh"
6102#include "sym.fh"
6103#include "errquit.fh"
6104#include "tce.fh"
6105      INTEGER l_a_offset
6106      INTEGER k_a_offset
6107      INTEGER size
6108      INTEGER length
6109      INTEGER addr
6110      INTEGER p3b
6111      INTEGER h10b
6112      INTEGER h1b
6113      INTEGER h2b
6114      length = 0
6115ckbn      DO p3b = noab+1,noab+nvab
6116      DO p3b = 1,1
6117      DO h10b = 1,noab
6118      DO h1b = 1,noab
6119      DO h2b = h1b,noab
6120ckbn      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+
6121ckbn     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
6122      IF (int_mb(k_spin+h10b-1)+ ip_unused_spin .eq. int_mb(k_spin+
6123     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
6124ckbn      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb
6125ckbn     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T
6126ckbn     &HEN
6127      IF (ieor(int_mb(k_sym+h10b-1),ieor(ip_unused_sym ,ieor(int_mb
6128     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T
6129     &HEN
6130ckbn      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-
6131ckbn     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
6132      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+ ip_unused_spin
6133     & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
6134      length = length + 1
6135      END IF
6136      END IF
6137      END IF
6138      END DO
6139      END DO
6140      END DO
6141      END DO
6142      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
6143     &set)) CALL ERRQUIT('ipccsd_x2_6_1',0,MA_ERR)
6144      int_mb(k_a_offset) = length
6145      addr = 0
6146      size = 0
6147ckbn      DO p3b = noab+1,noab+nvab
6148      DO p3b = 1,1
6149      DO h10b = 1,noab
6150      DO h1b = 1,noab
6151      DO h2b = h1b,noab
6152ckbn      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+
6153ckbn     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
6154      IF (int_mb(k_spin+h10b-1)+ip_unused_spin .eq. int_mb(k_spin+
6155     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
6156ckbn      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb
6157ckbn     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T
6158ckbn     &HEN
6159      IF (ieor(int_mb(k_sym+h10b-1),ieor(ip_unused_sym ,ieor(int_mb
6160     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T
6161     &HEN
6162ckbn      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-
6163ckbn     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
6164      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+ip_unused_spin
6165     & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
6166      addr = addr + 1
6167      int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h10b
6168     & - 1 + noab * (p3b - noab - 1)))
6169      int_mb(k_a_offset+length+addr) = size
6170ckbn      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int
6171ckbn     &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
6172      size = size + 1 * int_mb(k_range+h10b-1) * int
6173     &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
6174      END IF
6175      END IF
6176      END IF
6177      END DO
6178      END DO
6179      END DO
6180      END DO
6181      RETURN
6182      END
6183      SUBROUTINE ipccsd_x2_6_1_1(d_a,k_a_offset,d_c,k_c_offset)
6184C     $Id$
6185C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
6186C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
6187C     i2 ( h8 h10 h1 h2 )_v + = 1 * v ( h8 h10 h1 h2 )_v
6188      IMPLICIT NONE
6189#include "global.fh"
6190#include "mafdecls.fh"
6191#include "sym.fh"
6192#include "errquit.fh"
6193#include "tce.fh"
6194      INTEGER d_a
6195      INTEGER k_a_offset
6196      INTEGER d_c
6197      INTEGER k_c_offset
6198      INTEGER NXTASK
6199      INTEGER next
6200      INTEGER nprocs
6201      INTEGER count
6202      INTEGER h8b
6203      INTEGER h10b
6204      INTEGER h1b
6205      INTEGER h2b
6206      INTEGER dimc
6207      INTEGER h8b_1
6208      INTEGER h10b_1
6209      INTEGER h1b_1
6210      INTEGER h2b_1
6211      INTEGER dim_common
6212      INTEGER dima_sort
6213      INTEGER dima
6214      INTEGER l_a_sort
6215      INTEGER k_a_sort
6216      INTEGER l_a
6217      INTEGER k_a
6218      INTEGER l_c
6219      INTEGER k_c
6220      EXTERNAL NXTASK
6221      nprocs = GA_NNODES()
6222      count = 0
6223      next = NXTASK(nprocs, 1)
6224      DO h8b = 1,noab
6225      DO h10b = h8b,noab
6226      DO h1b = 1,noab
6227      DO h2b = h1b,noab
6228      IF (next.eq.count) THEN
6229      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
6230     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
6231      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
6232     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
6233      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
6234     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
6235      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
6236     &ange+h1b-1) * int_mb(k_range+h2b-1)
6237      CALL TCE_RESTRICTED_4(h8b,h10b,h1b,h2b,h8b_1,h10b_1,h1b_1,h2b_1)
6238      dim_common = 1
6239      dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m
6240     &b(k_range+h1b-1) * int_mb(k_range+h2b-1)
6241      dima = dim_common * dima_sort
6242      IF (dima .gt. 0) THEN
6243      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
6244     & ERRQUIT('ipccsd_x2_6_1_1',0,MA_ERR)
6245      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
6246     &ipccsd_x2_6_1_1',1,MA_ERR)
6247      if(.not.intorb) then
6248      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
6249     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
6250     &b+nvab) * (h8b_1 - 1)))))
6251      else
6252      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
6253     &(h2b_1
6254     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
6255     &b+nvab) * (h8b_1 - 1)))),h2b_1,h1b_1,h10b_1,h8b_1)
6256      end if
6257      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1)
6258     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
6259     &),4,3,2,1,1.0d0)
6260      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1_1',2,MA_ER
6261     &R)
6262      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
6263     &ipccsd_x2_6_1_1',3,MA_ERR)
6264      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
6265     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h8b-1
6266     &),4,3,2,1,1.0d0)
6267      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
6268     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1)))))
6269      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1_1',4,MA_ER
6270     &R)
6271      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1_1',5,
6272     &MA_ERR)
6273      END IF
6274      END IF
6275      END IF
6276      END IF
6277      next = NXTASK(nprocs, 1)
6278      END IF
6279      count = count + 1
6280      END DO
6281      END DO
6282      END DO
6283      END DO
6284      next = NXTASK(-nprocs, 1)
6285      call GA_SYNC()
6286      RETURN
6287      END
6288      SUBROUTINE OFFSET_ipccsd_x2_6_1_1(l_a_offset,k_a_offset,size)
6289C     $Id$
6290C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
6291C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
6292C     i2 ( h8 h10 h1 h2 )_v
6293      IMPLICIT NONE
6294#include "global.fh"
6295#include "mafdecls.fh"
6296#include "sym.fh"
6297#include "errquit.fh"
6298#include "tce.fh"
6299      INTEGER l_a_offset
6300      INTEGER k_a_offset
6301      INTEGER size
6302      INTEGER length
6303      INTEGER addr
6304      INTEGER h8b
6305      INTEGER h10b
6306      INTEGER h1b
6307      INTEGER h2b
6308      length = 0
6309      DO h8b = 1,noab
6310      DO h10b = h8b,noab
6311      DO h1b = 1,noab
6312      DO h2b = h1b,noab
6313      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
6314     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
6315      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
6316     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
6317      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
6318     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
6319      length = length + 1
6320      END IF
6321      END IF
6322      END IF
6323      END DO
6324      END DO
6325      END DO
6326      END DO
6327      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
6328     &set)) CALL ERRQUIT('ipccsd_x2_6_1_1',0,MA_ERR)
6329      int_mb(k_a_offset) = length
6330      addr = 0
6331      size = 0
6332      DO h8b = 1,noab
6333      DO h10b = h8b,noab
6334      DO h1b = 1,noab
6335      DO h2b = h1b,noab
6336      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
6337     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
6338      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
6339     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
6340      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
6341     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
6342      addr = addr + 1
6343      int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h10b
6344     & - 1 + noab * (h8b - 1)))
6345      int_mb(k_a_offset+length+addr) = size
6346      size = size + int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int
6347     &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
6348      END IF
6349      END IF
6350      END IF
6351      END DO
6352      END DO
6353      END DO
6354      END DO
6355      RETURN
6356      END
6357      SUBROUTINE ipccsd_x2_6_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
6358     &ffset)
6359C     $Id$
6360C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
6361C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
6362C     i2 ( h8 h10 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i3 ( h8 h10 h2 p5 )_v
6363      IMPLICIT NONE
6364#include "global.fh"
6365#include "mafdecls.fh"
6366#include "sym.fh"
6367#include "errquit.fh"
6368#include "tce.fh"
6369      INTEGER d_a
6370      INTEGER k_a_offset
6371      INTEGER d_b
6372      INTEGER k_b_offset
6373      INTEGER d_c
6374      INTEGER k_c_offset
6375      INTEGER NXTASK
6376      INTEGER next
6377      INTEGER nprocs
6378      INTEGER count
6379      INTEGER h8b
6380      INTEGER h10b
6381      INTEGER h1b
6382      INTEGER h2b
6383      INTEGER dimc
6384      INTEGER l_c_sort
6385      INTEGER k_c_sort
6386      INTEGER p5b
6387      INTEGER p5b_1
6388      INTEGER h1b_1
6389      INTEGER h8b_2
6390      INTEGER h10b_2
6391      INTEGER h2b_2
6392      INTEGER p5b_2
6393      INTEGER dim_common
6394      INTEGER dima_sort
6395      INTEGER dima
6396      INTEGER dimb_sort
6397      INTEGER dimb
6398      INTEGER l_a_sort
6399      INTEGER k_a_sort
6400      INTEGER l_a
6401      INTEGER k_a
6402      INTEGER l_b_sort
6403      INTEGER k_b_sort
6404      INTEGER l_b
6405      INTEGER k_b
6406      INTEGER l_c
6407      INTEGER k_c
6408      EXTERNAL NXTASK
6409      nprocs = GA_NNODES()
6410      count = 0
6411      next = NXTASK(nprocs, 1)
6412      DO h8b = 1,noab
6413      DO h10b = h8b,noab
6414      DO h1b = 1,noab
6415      DO h2b = 1,noab
6416      IF (next.eq.count) THEN
6417      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
6418     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
6419      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
6420     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
6421      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
6422     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T
6423     &HEN
6424      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
6425     &ange+h1b-1) * int_mb(k_range+h2b-1)
6426      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
6427     & ERRQUIT('ipccsd_x2_6_1_2',0,MA_ERR)
6428      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
6429      DO p5b = noab+1,noab+nvab
6430      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
6431      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
6432     &EN
6433      CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1)
6434      CALL TCE_RESTRICTED_4(h8b,h10b,h2b,p5b,h8b_2,h10b_2,h2b_2,p5b_2)
6435      dim_common = int_mb(k_range+p5b-1)
6436      dima_sort = int_mb(k_range+h1b-1)
6437      dima = dim_common * dima_sort
6438      dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m
6439     &b(k_range+h2b-1)
6440      dimb = dim_common * dimb_sort
6441      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
6442      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
6443     & ERRQUIT('ipccsd_x2_6_1_2',1,MA_ERR)
6444      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
6445     &ipccsd_x2_6_1_2',2,MA_ERR)
6446      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
6447     & - 1 + noab * (p5b_1 - noab - 1)))
6448      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
6449     &,int_mb(k_range+h1b-1),2,1,1.0d0)
6450      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1_2',3,MA_ER
6451     &R)
6452      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
6453     & ERRQUIT('ipccsd_x2_6_1_2',4,MA_ERR)
6454      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
6455     &ipccsd_x2_6_1_2',5,MA_ERR)
6456      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
6457     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h10b_2 - 1 + noab * (h8b
6458     &_2 - 1)))))
6459      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
6460     &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1
6461     &),3,2,1,4,1.0d0)
6462      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_1_2',6,MA_ER
6463     &R)
6464      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
6465     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
6466     &t),dima_sort)
6467      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2',7,
6468     &MA_ERR)
6469      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2',8,
6470     &MA_ERR)
6471      END IF
6472      END IF
6473      END IF
6474      END DO
6475      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
6476     &ipccsd_x2_6_1_2',9,MA_ERR)
6477      IF ((h1b .le. h2b)) THEN
6478      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
6479     &,int_mb(k_range+h10b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1
6480     &),3,2,4,1,-1.0d0)
6481      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
6482     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1)))))
6483      END IF
6484      IF ((h2b .le. h1b)) THEN
6485      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
6486     &,int_mb(k_range+h10b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1
6487     &),3,2,1,4,1.0d0)
6488      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
6489     & 1 + noab * (h2b - 1 + noab * (h10b - 1 + noab * (h8b - 1)))))
6490      END IF
6491      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1_2',10,MA_E
6492     &RR)
6493      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2',11
6494     &,MA_ERR)
6495      END IF
6496      END IF
6497      END IF
6498      next = NXTASK(nprocs, 1)
6499      END IF
6500      count = count + 1
6501      END DO
6502      END DO
6503      END DO
6504      END DO
6505      next = NXTASK(-nprocs, 1)
6506      call GA_SYNC()
6507      RETURN
6508      END
6509      SUBROUTINE ipccsd_x2_6_1_2_1(d_a,k_a_offset,d_c,k_c_offset)
6510C     $Id$
6511C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
6512C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
6513C     i3 ( h8 h10 h1 p5 )_v + = 1 * v ( h8 h10 h1 p5 )_v
6514      IMPLICIT NONE
6515#include "global.fh"
6516#include "mafdecls.fh"
6517#include "sym.fh"
6518#include "errquit.fh"
6519#include "tce.fh"
6520      INTEGER d_a
6521      INTEGER k_a_offset
6522      INTEGER d_c
6523      INTEGER k_c_offset
6524      INTEGER NXTASK
6525      INTEGER next
6526      INTEGER nprocs
6527      INTEGER count
6528      INTEGER h8b
6529      INTEGER h10b
6530      INTEGER h1b
6531      INTEGER p5b
6532      INTEGER dimc
6533      INTEGER h8b_1
6534      INTEGER h10b_1
6535      INTEGER h1b_1
6536      INTEGER p5b_1
6537      INTEGER dim_common
6538      INTEGER dima_sort
6539      INTEGER dima
6540      INTEGER l_a_sort
6541      INTEGER k_a_sort
6542      INTEGER l_a
6543      INTEGER k_a
6544      INTEGER l_c
6545      INTEGER k_c
6546      EXTERNAL NXTASK
6547      nprocs = GA_NNODES()
6548      count = 0
6549      next = NXTASK(nprocs, 1)
6550      DO h8b = 1,noab
6551      DO h10b = h8b,noab
6552      DO h1b = 1,noab
6553      DO p5b = noab+1,noab+nvab
6554      IF (next.eq.count) THEN
6555      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
6556     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
6557      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
6558     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
6559      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
6560     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
6561      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
6562     &ange+h1b-1) * int_mb(k_range+p5b-1)
6563      CALL TCE_RESTRICTED_4(h8b,h10b,h1b,p5b,h8b_1,h10b_1,h1b_1,p5b_1)
6564      dim_common = 1
6565      dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m
6566     &b(k_range+h1b-1) * int_mb(k_range+p5b-1)
6567      dima = dim_common * dima_sort
6568      IF (dima .gt. 0) THEN
6569      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
6570     & ERRQUIT('ipccsd_x2_6_1_2_1',0,MA_ERR)
6571      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
6572     &ipccsd_x2_6_1_2_1',1,MA_ERR)
6573      IF ((h1b .le. p5b)) THEN
6574      if(.not.intorb) then
6575      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
6576     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
6577     &b+nvab) * (h8b_1 - 1)))))
6578      else
6579      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
6580     &(p5b_1
6581     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
6582     &b+nvab) * (h8b_1 - 1)))),p5b_1,h1b_1,h10b_1,h8b_1)
6583      end if
6584      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1)
6585     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1
6586     &),4,3,2,1,1.0d0)
6587      END IF
6588      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1_2_1',2,MA_
6589     &ERR)
6590      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
6591     &ipccsd_x2_6_1_2_1',3,MA_ERR)
6592      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
6593     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h8b-1
6594     &),4,3,2,1,1.0d0)
6595      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
6596     & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1))
6597     &)))
6598      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1_2_1',4,MA_
6599     &ERR)
6600      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2_1',
6601     &5,MA_ERR)
6602      END IF
6603      END IF
6604      END IF
6605      END IF
6606      next = NXTASK(nprocs, 1)
6607      END IF
6608      count = count + 1
6609      END DO
6610      END DO
6611      END DO
6612      END DO
6613      next = NXTASK(-nprocs, 1)
6614      call GA_SYNC()
6615      RETURN
6616      END
6617      SUBROUTINE OFFSET_ipccsd_x2_6_1_2_1(l_a_offset,k_a_offset,size)
6618C     $Id$
6619C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
6620C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
6621C     i3 ( h8 h10 h1 p5 )_v
6622      IMPLICIT NONE
6623#include "global.fh"
6624#include "mafdecls.fh"
6625#include "sym.fh"
6626#include "errquit.fh"
6627#include "tce.fh"
6628      INTEGER l_a_offset
6629      INTEGER k_a_offset
6630      INTEGER size
6631      INTEGER length
6632      INTEGER addr
6633      INTEGER h8b
6634      INTEGER h10b
6635      INTEGER h1b
6636      INTEGER p5b
6637      length = 0
6638      DO h8b = 1,noab
6639      DO h10b = h8b,noab
6640      DO h1b = 1,noab
6641      DO p5b = noab+1,noab+nvab
6642      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
6643     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
6644      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
6645     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
6646      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
6647     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
6648      length = length + 1
6649      END IF
6650      END IF
6651      END IF
6652      END DO
6653      END DO
6654      END DO
6655      END DO
6656      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
6657     &set)) CALL ERRQUIT('ipccsd_x2_6_1_2_1',0,MA_ERR)
6658      int_mb(k_a_offset) = length
6659      addr = 0
6660      size = 0
6661      DO h8b = 1,noab
6662      DO h10b = h8b,noab
6663      DO h1b = 1,noab
6664      DO p5b = noab+1,noab+nvab
6665      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
6666     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
6667      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
6668     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
6669      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
6670     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
6671      addr = addr + 1
6672      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab
6673     &* (h10b - 1 + noab * (h8b - 1)))
6674      int_mb(k_a_offset+length+addr) = size
6675      size = size + int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int
6676     &_mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
6677      END IF
6678      END IF
6679      END IF
6680      END DO
6681      END DO
6682      END DO
6683      END DO
6684      RETURN
6685      END
6686      SUBROUTINE ipccsd_x2_6_1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c
6687     &_offset)
6688C     $Id$
6689C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
6690C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
6691C     i3 ( h8 h10 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h8 h10 p5 p6 )_v
6692      IMPLICIT NONE
6693#include "global.fh"
6694#include "mafdecls.fh"
6695#include "sym.fh"
6696#include "errquit.fh"
6697#include "tce.fh"
6698      INTEGER d_a
6699      INTEGER k_a_offset
6700      INTEGER d_b
6701      INTEGER k_b_offset
6702      INTEGER d_c
6703      INTEGER k_c_offset
6704      INTEGER NXTASK
6705      INTEGER next
6706      INTEGER nprocs
6707      INTEGER count
6708      INTEGER h8b
6709      INTEGER h10b
6710      INTEGER h1b
6711      INTEGER p5b
6712      INTEGER dimc
6713      INTEGER l_c_sort
6714      INTEGER k_c_sort
6715      INTEGER p6b
6716      INTEGER p6b_1
6717      INTEGER h1b_1
6718      INTEGER h8b_2
6719      INTEGER h10b_2
6720      INTEGER p5b_2
6721      INTEGER p6b_2
6722      INTEGER dim_common
6723      INTEGER dima_sort
6724      INTEGER dima
6725      INTEGER dimb_sort
6726      INTEGER dimb
6727      INTEGER l_a_sort
6728      INTEGER k_a_sort
6729      INTEGER l_a
6730      INTEGER k_a
6731      INTEGER l_b_sort
6732      INTEGER k_b_sort
6733      INTEGER l_b
6734      INTEGER k_b
6735      INTEGER l_c
6736      INTEGER k_c
6737      EXTERNAL NXTASK
6738      nprocs = GA_NNODES()
6739      count = 0
6740      next = NXTASK(nprocs, 1)
6741      DO h8b = 1,noab
6742      DO h10b = h8b,noab
6743      DO h1b = 1,noab
6744      DO p5b = noab+1,noab+nvab
6745      IF (next.eq.count) THEN
6746      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
6747     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
6748      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
6749     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
6750      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
6751     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) T
6752     &HEN
6753      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
6754     &ange+h1b-1) * int_mb(k_range+p5b-1)
6755      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
6756     & ERRQUIT('ipccsd_x2_6_1_2_2',0,MA_ERR)
6757      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
6758      DO p6b = noab+1,noab+nvab
6759      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
6760      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
6761     &EN
6762      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
6763      CALL TCE_RESTRICTED_4(h8b,h10b,p5b,p6b,h8b_2,h10b_2,p5b_2,p6b_2)
6764      dim_common = int_mb(k_range+p6b-1)
6765      dima_sort = int_mb(k_range+h1b-1)
6766      dima = dim_common * dima_sort
6767      dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m
6768     &b(k_range+p5b-1)
6769      dimb = dim_common * dimb_sort
6770      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
6771      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
6772     & ERRQUIT('ipccsd_x2_6_1_2_2',1,MA_ERR)
6773      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
6774     &ipccsd_x2_6_1_2_2',2,MA_ERR)
6775      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
6776     & - 1 + noab * (p6b_1 - noab - 1)))
6777      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
6778     &,int_mb(k_range+h1b-1),2,1,1.0d0)
6779      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1_2_2',3,MA_
6780     &ERR)
6781      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
6782     & ERRQUIT('ipccsd_x2_6_1_2_2',4,MA_ERR)
6783      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
6784     &ipccsd_x2_6_1_2_2',5,MA_ERR)
6785      IF ((p6b .lt. p5b)) THEN
6786      if(.not.intorb) then
6787      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
6788     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
6789     &b+nvab) * (h8b_2 - 1)))))
6790      else
6791      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
6792     &(p5b_2
6793     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
6794     &b+nvab) * (h8b_2 - 1)))),p5b_2,p6b_2,h10b_2,h8b_2)
6795      end if
6796      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
6797     &,int_mb(k_range+h10b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1
6798     &),4,2,1,3,-1.0d0)
6799      END IF
6800      IF ((p5b .le. p6b)) THEN
6801      if(.not.intorb) then
6802      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
6803     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
6804     &b+nvab) * (h8b_2 - 1)))))
6805      else
6806      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
6807     &(p6b_2
6808     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
6809     &b+nvab) * (h8b_2 - 1)))),p6b_2,p5b_2,h10b_2,h8b_2)
6810      end if
6811      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
6812     &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
6813     &),3,2,1,4,1.0d0)
6814      END IF
6815      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_1_2_2',6,MA_
6816     &ERR)
6817      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
6818     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
6819     &t),dima_sort)
6820      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2_2',
6821     &7,MA_ERR)
6822      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2_2',
6823     &8,MA_ERR)
6824      END IF
6825      END IF
6826      END IF
6827      END DO
6828      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
6829     &ipccsd_x2_6_1_2_2',9,MA_ERR)
6830      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
6831     &,int_mb(k_range+h10b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1
6832     &),3,2,4,1,-1.0d0/2.0d0)
6833      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
6834     & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1))
6835     &)))
6836      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1_2_2',10,MA
6837     &_ERR)
6838      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_1_2_2',
6839     &11,MA_ERR)
6840      END IF
6841      END IF
6842      END IF
6843      next = NXTASK(nprocs, 1)
6844      END IF
6845      count = count + 1
6846      END DO
6847      END DO
6848      END DO
6849      END DO
6850      next = NXTASK(-nprocs, 1)
6851      call GA_SYNC()
6852      RETURN
6853      END
6854      SUBROUTINE ipccsd_x2_6_1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
6855     &ffset)
6856C     $Id$
6857C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
6858C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
6859C     i2 ( h8 h10 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h8 h10 p5 p6 )_v
6860      IMPLICIT NONE
6861#include "global.fh"
6862#include "mafdecls.fh"
6863#include "sym.fh"
6864#include "errquit.fh"
6865#include "tce.fh"
6866      INTEGER d_a
6867      INTEGER k_a_offset
6868      INTEGER d_b
6869      INTEGER k_b_offset
6870      INTEGER d_c
6871      INTEGER k_c_offset
6872      INTEGER NXTASK
6873      INTEGER next
6874      INTEGER nprocs
6875      INTEGER count
6876      INTEGER h8b
6877      INTEGER h10b
6878      INTEGER h1b
6879      INTEGER h2b
6880      INTEGER dimc
6881      INTEGER l_c_sort
6882      INTEGER k_c_sort
6883      INTEGER p5b
6884      INTEGER p6b
6885      INTEGER p5b_1
6886      INTEGER p6b_1
6887      INTEGER h1b_1
6888      INTEGER h2b_1
6889      INTEGER h8b_2
6890      INTEGER h10b_2
6891      INTEGER p5b_2
6892      INTEGER p6b_2
6893      INTEGER dim_common
6894      INTEGER dima_sort
6895      INTEGER dima
6896      INTEGER dimb_sort
6897      INTEGER dimb
6898      INTEGER l_a_sort
6899      INTEGER k_a_sort
6900      INTEGER l_a
6901      INTEGER k_a
6902      INTEGER l_b_sort
6903      INTEGER k_b_sort
6904      INTEGER l_b
6905      INTEGER k_b
6906      INTEGER nsuperp(2)
6907      INTEGER isuperp
6908      INTEGER l_c
6909      INTEGER k_c
6910      DOUBLE PRECISION FACTORIAL
6911      EXTERNAL NXTASK
6912      EXTERNAL FACTORIAL
6913      nprocs = GA_NNODES()
6914      count = 0
6915      next = NXTASK(nprocs, 1)
6916      DO h8b = 1,noab
6917      DO h10b = h8b,noab
6918      DO h1b = 1,noab
6919      DO h2b = h1b,noab
6920      IF (next.eq.count) THEN
6921      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
6922     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
6923      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
6924     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
6925      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
6926     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T
6927     &HEN
6928      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
6929     &ange+h1b-1) * int_mb(k_range+h2b-1)
6930      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
6931     & ERRQUIT('ipccsd_x2_6_1_3',0,MA_ERR)
6932      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
6933      DO p5b = noab+1,noab+nvab
6934      DO p6b = p5b,noab+nvab
6935      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h
6936     &1b-1)+int_mb(k_spin+h2b-1)) THEN
6937      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb(
6938     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
6939      CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1)
6940      CALL TCE_RESTRICTED_4(h8b,h10b,p5b,p6b,h8b_2,h10b_2,p5b_2,p6b_2)
6941      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1)
6942      dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
6943      dima = dim_common * dima_sort
6944      dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1)
6945      dimb = dim_common * dimb_sort
6946      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
6947      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
6948     & ERRQUIT('ipccsd_x2_6_1_3',1,MA_ERR)
6949      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
6950     &ipccsd_x2_6_1_3',2,MA_ERR)
6951      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
6952     & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_
6953     &1 - noab - 1)))))
6954      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
6955     &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
6956     &,4,3,2,1,1.0d0)
6957      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_1_3',3,MA_ER
6958     &R)
6959      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
6960     & ERRQUIT('ipccsd_x2_6_1_3',4,MA_ERR)
6961      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
6962     &ipccsd_x2_6_1_3',5,MA_ERR)
6963      if(.not.intorb) then
6964      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
6965     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
6966     &b+nvab) * (h8b_2 - 1)))))
6967      else
6968      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
6969     &(p6b_2
6970     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
6971     &b+nvab) * (h8b_2 - 1)))),p6b_2,p5b_2,h10b_2,h8b_2)
6972      end if
6973      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
6974     &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
6975     &),2,1,4,3,1.0d0)
6976      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_1_3',6,MA_ER
6977     &R)
6978      nsuperp(1) = 1
6979      nsuperp(2) = 1
6980      isuperp = 1
6981      IF (p5b .eq. p6b) THEN
6982      nsuperp(isuperp) = nsuperp(isuperp) + 1
6983      ELSE
6984      isuperp = isuperp + 1
6985      END IF
6986      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
6987     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
6988     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
6989      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_1_3',7,
6990     &MA_ERR)
6991      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_1_3',8,
6992     &MA_ERR)
6993      END IF
6994      END IF
6995      END IF
6996      END DO
6997      END DO
6998      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
6999     &ipccsd_x2_6_1_3',9,MA_ERR)
7000      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1
7001     &),int_mb(k_range+h8b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1
7002     &),2,1,4,3,1.0d0/2.0d0)
7003      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
7004     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1)))))
7005      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_1_3',10,MA_E
7006     &RR)
7007      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_1_3',11
7008     &,MA_ERR)
7009      END IF
7010      END IF
7011      END IF
7012      next = NXTASK(nprocs, 1)
7013      END IF
7014      count = count + 1
7015      END DO
7016      END DO
7017      END DO
7018      END DO
7019      next = NXTASK(-nprocs, 1)
7020      call GA_SYNC()
7021      RETURN
7022      END
7023      SUBROUTINE ipccsd_x2_6_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
7024     &set)
7025C     $Id$
7026C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
7027C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
7028C     i1 ( h10 p3 h1 h2 )_fx + = 1 * Sum ( p5 ) * x ( p3 p5 h1 h2 )_x * i2 ( h10 p5 )_f
7029      IMPLICIT NONE
7030#include "global.fh"
7031#include "mafdecls.fh"
7032#include "sym.fh"
7033#include "errquit.fh"
7034#include "tce.fh"
7035#include "stdio.fh"
7036      INTEGER d_a
7037      INTEGER k_a_offset
7038      INTEGER d_b
7039      INTEGER k_b_offset
7040      INTEGER d_c
7041      INTEGER k_c_offset
7042      INTEGER NXTASK
7043      INTEGER next
7044      INTEGER nprocs
7045      INTEGER count
7046      INTEGER p3b
7047      INTEGER h10b
7048      INTEGER h1b
7049      INTEGER h2b
7050      INTEGER dimc
7051      INTEGER l_c_sort
7052      INTEGER k_c_sort
7053      INTEGER p5b
7054      INTEGER p3b_1
7055      INTEGER p5b_1
7056      INTEGER h1b_1
7057      INTEGER h2b_1
7058      INTEGER h10b_2
7059      INTEGER p5b_2
7060      INTEGER dim_common
7061      INTEGER dima_sort
7062      INTEGER dima
7063      INTEGER dimb_sort
7064      INTEGER dimb
7065      INTEGER l_a_sort
7066      INTEGER k_a_sort
7067      INTEGER l_a
7068      INTEGER k_a
7069      INTEGER l_b_sort
7070      INTEGER k_b_sort
7071      INTEGER l_b
7072      INTEGER k_b
7073      INTEGER l_c
7074      INTEGER k_c
7075      EXTERNAL NXTASK
7076      nprocs = GA_NNODES()
7077      count = 0
7078      next = NXTASK(nprocs, 1)
7079ckbn      DO p3b = noab+1,noab+nvab
7080      DO p3b = 1,1
7081      DO h10b = 1,noab
7082      DO h1b = 1,noab
7083      DO h2b = h1b,noab
7084      IF (next.eq.count) THEN
7085ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
7086ckbn     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
7087      IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+h10b-
7088     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
7089ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
7090ckbn     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
7091      IF (ip_unused_spin +int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
7092     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
7093ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
7094ckbn     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_f,irrep_x)) T
7095ckbn     &HEN
7096      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+h10b-1),ieor(int_mb
7097     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_f,irrep_x)) T
7098     &HEN
7099ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
7100ckbn     &ange+h1b-1) * int_mb(k_range+h2b-1)
7101      dimc = 1 * int_mb(k_range+h10b-1) * int_mb(k_r
7102     &ange+h1b-1) * int_mb(k_range+h2b-1)
7103      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
7104     & ERRQUIT('ipccsd_x2_6_2',0,MA_ERR)
7105      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
7106      DO p5b = noab+1,noab+nvab
7107ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
7108ckbn     &1b-1)+int_mb(k_spin+h2b-1)) THEN
7109      IF (ip_unused_spin +int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
7110     &1b-1)+int_mb(k_spin+h2b-1)) THEN
7111ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
7112ckbn     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN
7113      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
7114     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN
7115      CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h2b,p3b_1,p5b_1,h1b_1,h2b_1)
7116      CALL TCE_RESTRICTED_2(h10b,p5b,h10b_2,p5b_2)
7117      dim_common = int_mb(k_range+p5b-1)
7118ckbn      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb
7119ckbn     &(k_range+h2b-1)
7120      dima_sort = 1 * int_mb(k_range+h1b-1) * int_mb
7121     &(k_range+h2b-1)
7122      dima = dim_common * dima_sort
7123      dimb_sort = int_mb(k_range+h10b-1)
7124      dimb = dim_common * dimb_sort
7125      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
7126      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
7127     & ERRQUIT('ipccsd_x2_6_2',1,MA_ERR)
7128      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
7129     &ipccsd_x2_6_2',2,MA_ERR)
7130c      write(LuOut,*) "I am here 1."
7131c      call util_flush(LuOut)
7132ckbn      IF ((p5b .lt. p3b)) THEN
7133      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
7134     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
7135     &1 - noab - 1)))))
7136ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
7137ckbn     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
7138ckbn     &,4,3,2,1,-1.0d0)
7139      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
7140     &,1,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
7141     &,4,3,2,1,-1.0d0)
7142c      write(LuOut,*) "I am here 2."
7143c      call util_flush(LuOut)
7144ckbn      END IF
7145ckbn      IF ((p3b .le. p5b)) THEN
7146ckbn      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
7147ckbn     & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
7148ckbn     &1 - noab - 1)))))
7149ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
7150ckbn     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
7151ckbn     &,4,3,1,2,1.0d0)
7152ckbn      END IF
7153      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_2',3,MA_ERR)
7154      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
7155     & ERRQUIT('ipccsd_x2_6_2',4,MA_ERR)
7156      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
7157     &ipccsd_x2_6_2',5,MA_ERR)
7158      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
7159     & - noab - 1 + nvab * (h10b_2 - 1)))
7160      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
7161     &),int_mb(k_range+p5b-1),1,2,1.0d0)
7162      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_2',6,MA_ERR)
7163      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
7164     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
7165     &t),dima_sort)
7166      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_2',7,MA
7167     &_ERR)
7168      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_2',8,MA
7169     &_ERR)
7170      END IF
7171      END IF
7172      END IF
7173      END DO
7174      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
7175     &ipccsd_x2_6_2',9,MA_ERR)
7176c      write(LuOut,*) "I am here 3."
7177c      call util_flush(LuOut)
7178ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1
7179ckbn     &),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1
7180ckbn     &),4,1,3,2,1.0d0)
7181      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1
7182     &),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),1
7183     &,4,1,3,2,1.0d0)
7184c      write(LuOut,*) "I am here 3.1"
7185c      call util_flush(LuOut)
7186      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
7187     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
7188     &)))
7189c      write(LuOut,*) "I am here 4."
7190c      call util_flush(LuOut)
7191      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_2',10,MA_ERR
7192     &)
7193      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_2',11,M
7194     &A_ERR)
7195      END IF
7196      END IF
7197      END IF
7198      next = NXTASK(nprocs, 1)
7199      END IF
7200      count = count + 1
7201      END DO
7202      END DO
7203      END DO
7204      END DO
7205      next = NXTASK(-nprocs, 1)
7206      call GA_SYNC()
7207      RETURN
7208      END
7209      SUBROUTINE ipccsd_x2_6_2_1(d_a,k_a_offset,d_c,k_c_offset)
7210C     $Id$
7211C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
7212C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
7213C     i2 ( h10 p5 )_f + = 1 * f ( h10 p5 )_f
7214      IMPLICIT NONE
7215#include "global.fh"
7216#include "mafdecls.fh"
7217#include "sym.fh"
7218#include "errquit.fh"
7219#include "tce.fh"
7220      INTEGER d_a
7221      INTEGER k_a_offset
7222      INTEGER d_c
7223      INTEGER k_c_offset
7224      INTEGER NXTASK
7225      INTEGER next
7226      INTEGER nprocs
7227      INTEGER count
7228      INTEGER h10b
7229      INTEGER p5b
7230      INTEGER dimc
7231      INTEGER h10b_1
7232      INTEGER p5b_1
7233      INTEGER dim_common
7234      INTEGER dima_sort
7235      INTEGER dima
7236      INTEGER l_a_sort
7237      INTEGER k_a_sort
7238      INTEGER l_a
7239      INTEGER k_a
7240      INTEGER l_c
7241      INTEGER k_c
7242      EXTERNAL NXTASK
7243      nprocs = GA_NNODES()
7244      count = 0
7245      next = NXTASK(nprocs, 1)
7246      DO h10b = 1,noab
7247      DO p5b = noab+1,noab+nvab
7248      IF (next.eq.count) THEN
7249      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b-
7250     &1).ne.4)) THEN
7251      IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN
7252      IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T
7253     &HEN
7254      dimc = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1)
7255      CALL TCE_RESTRICTED_2(h10b,p5b,h10b_1,p5b_1)
7256      dim_common = 1
7257      dima_sort = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1)
7258      dima = dim_common * dima_sort
7259      IF (dima .gt. 0) THEN
7260      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
7261     & ERRQUIT('ipccsd_x2_6_2_1',0,MA_ERR)
7262      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
7263     &ipccsd_x2_6_2_1',1,MA_ERR)
7264      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
7265     & - 1 + (noab+nvab) * (h10b_1 - 1)))
7266      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1
7267     &),int_mb(k_range+p5b-1),2,1,1.0d0)
7268      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_2_1',2,MA_ER
7269     &R)
7270      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
7271     &ipccsd_x2_6_2_1',3,MA_ERR)
7272      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
7273     &,int_mb(k_range+h10b-1),2,1,1.0d0)
7274      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
7275     & noab - 1 + nvab * (h10b - 1)))
7276      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_2_1',4,MA_ER
7277     &R)
7278      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_2_1',5,
7279     &MA_ERR)
7280      END IF
7281      END IF
7282      END IF
7283      END IF
7284      next = NXTASK(nprocs, 1)
7285      END IF
7286      count = count + 1
7287      END DO
7288      END DO
7289      next = NXTASK(-nprocs, 1)
7290      call GA_SYNC()
7291      RETURN
7292      END
7293      SUBROUTINE OFFSET_ipccsd_x2_6_2_1(l_a_offset,k_a_offset,size)
7294C     $Id$
7295C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
7296C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
7297C     i2 ( h10 p5 )_f
7298      IMPLICIT NONE
7299#include "global.fh"
7300#include "mafdecls.fh"
7301#include "sym.fh"
7302#include "errquit.fh"
7303#include "tce.fh"
7304      INTEGER l_a_offset
7305      INTEGER k_a_offset
7306      INTEGER size
7307      INTEGER length
7308      INTEGER addr
7309      INTEGER h10b
7310      INTEGER p5b
7311      length = 0
7312      DO h10b = 1,noab
7313      DO p5b = noab+1,noab+nvab
7314      IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN
7315      IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T
7316     &HEN
7317      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b-
7318     &1).ne.4)) THEN
7319      length = length + 1
7320      END IF
7321      END IF
7322      END IF
7323      END DO
7324      END DO
7325      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
7326     &set)) CALL ERRQUIT('ipccsd_x2_6_2_1',0,MA_ERR)
7327      int_mb(k_a_offset) = length
7328      addr = 0
7329      size = 0
7330      DO h10b = 1,noab
7331      DO p5b = noab+1,noab+nvab
7332      IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN
7333      IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T
7334     &HEN
7335      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b-
7336     &1).ne.4)) THEN
7337      addr = addr + 1
7338      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h10b - 1)
7339      int_mb(k_a_offset+length+addr) = size
7340      size = size + int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1)
7341      END IF
7342      END IF
7343      END IF
7344      END DO
7345      END DO
7346      RETURN
7347      END
7348      SUBROUTINE ipccsd_x2_6_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
7349     &ffset)
7350C     $Id$
7351C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
7352C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
7353C     i2 ( h10 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h10 p5 p6 )_v
7354      IMPLICIT NONE
7355#include "global.fh"
7356#include "mafdecls.fh"
7357#include "sym.fh"
7358#include "errquit.fh"
7359#include "tce.fh"
7360      INTEGER d_a
7361      INTEGER k_a_offset
7362      INTEGER d_b
7363      INTEGER k_b_offset
7364      INTEGER d_c
7365      INTEGER k_c_offset
7366      INTEGER NXTASK
7367      INTEGER next
7368      INTEGER nprocs
7369      INTEGER count
7370      INTEGER h10b
7371      INTEGER p5b
7372      INTEGER dimc
7373      INTEGER l_c_sort
7374      INTEGER k_c_sort
7375      INTEGER p6b
7376      INTEGER h7b
7377      INTEGER p6b_1
7378      INTEGER h7b_1
7379      INTEGER h10b_2
7380      INTEGER h7b_2
7381      INTEGER p5b_2
7382      INTEGER p6b_2
7383      INTEGER dim_common
7384      INTEGER dima_sort
7385      INTEGER dima
7386      INTEGER dimb_sort
7387      INTEGER dimb
7388      INTEGER l_a_sort
7389      INTEGER k_a_sort
7390      INTEGER l_a
7391      INTEGER k_a
7392      INTEGER l_b_sort
7393      INTEGER k_b_sort
7394      INTEGER l_b
7395      INTEGER k_b
7396      INTEGER l_c
7397      INTEGER k_c
7398      EXTERNAL NXTASK
7399      nprocs = GA_NNODES()
7400      count = 0
7401      next = NXTASK(nprocs, 1)
7402      DO h10b = 1,noab
7403      DO p5b = noab+1,noab+nvab
7404      IF (next.eq.count) THEN
7405      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b-
7406     &1).ne.4)) THEN
7407      IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN
7408      IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep
7409     &_v,irrep_t)) THEN
7410      dimc = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1)
7411      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
7412     & ERRQUIT('ipccsd_x2_6_2_2',0,MA_ERR)
7413      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
7414      DO p6b = noab+1,noab+nvab
7415      DO h7b = 1,noab
7416      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN
7417      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH
7418     &EN
7419      CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1)
7420      CALL TCE_RESTRICTED_4(h10b,h7b,p5b,p6b,h10b_2,h7b_2,p5b_2,p6b_2)
7421      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1)
7422      dima_sort = 1
7423      dima = dim_common * dima_sort
7424      dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1)
7425      dimb = dim_common * dimb_sort
7426      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
7427      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
7428     & ERRQUIT('ipccsd_x2_6_2_2',1,MA_ERR)
7429      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
7430     &ipccsd_x2_6_2_2',2,MA_ERR)
7431      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
7432     & - 1 + noab * (p6b_1 - noab - 1)))
7433      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
7434     &,int_mb(k_range+h7b-1),2,1,1.0d0)
7435      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_2_2',3,MA_ER
7436     &R)
7437      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
7438     & ERRQUIT('ipccsd_x2_6_2_2',4,MA_ERR)
7439      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
7440     &ipccsd_x2_6_2_2',5,MA_ERR)
7441      IF ((h7b .le. h10b) .and. (p6b .lt. p5b)) THEN
7442      if(.not.intorb) then
7443      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
7444     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
7445     &b+nvab) * (h7b_2 - 1)))))
7446      else
7447      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
7448     &(p5b_2
7449     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
7450     &b+nvab) * (h7b_2 - 1)))),p5b_2,p6b_2,h10b_2,h7b_2)
7451      end if
7452      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
7453     &,int_mb(k_range+h10b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1
7454     &),4,2,1,3,-1.0d0)
7455      END IF
7456      IF ((h7b .le. h10b) .and. (p5b .le. p6b)) THEN
7457      if(.not.intorb) then
7458      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
7459     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
7460     &b+nvab) * (h7b_2 - 1)))))
7461      else
7462      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
7463     &(p6b_2
7464     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
7465     &b+nvab) * (h7b_2 - 1)))),p6b_2,p5b_2,h10b_2,h7b_2)
7466      end if
7467      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
7468     &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
7469     &),3,2,1,4,1.0d0)
7470      END IF
7471      IF ((h10b .lt. h7b) .and. (p6b .lt. p5b)) THEN
7472      if(.not.intorb) then
7473      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
7474     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
7475     &+nvab) * (h10b_2 - 1)))))
7476      else
7477      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
7478     &(p5b_2
7479     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
7480     &+nvab) * (h10b_2 - 1)))),p5b_2,p6b_2,h7b_2,h10b_2)
7481      end if
7482      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
7483     &),int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1
7484     &),4,1,2,3,1.0d0)
7485      END IF
7486      IF ((h10b .lt. h7b) .and. (p5b .le. p6b)) THEN
7487      if(.not.intorb) then
7488      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
7489     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
7490     &+nvab) * (h10b_2 - 1)))))
7491      else
7492      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
7493     &(p6b_2
7494     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
7495     &+nvab) * (h10b_2 - 1)))),p6b_2,p5b_2,h7b_2,h10b_2)
7496      end if
7497      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
7498     &),int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
7499     &),3,1,2,4,-1.0d0)
7500      END IF
7501      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_2_2',6,MA_ER
7502     &R)
7503      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
7504     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
7505     &t),dima_sort)
7506      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_2_2',7,
7507     &MA_ERR)
7508      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_2_2',8,
7509     &MA_ERR)
7510      END IF
7511      END IF
7512      END IF
7513      END DO
7514      END DO
7515      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
7516     &ipccsd_x2_6_2_2',9,MA_ERR)
7517      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
7518     &,int_mb(k_range+h10b-1),2,1,-1.0d0)
7519      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
7520     & noab - 1 + nvab * (h10b - 1)))
7521      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_2_2',10,MA_E
7522     &RR)
7523      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_2_2',11
7524     &,MA_ERR)
7525      END IF
7526      END IF
7527      END IF
7528      next = NXTASK(nprocs, 1)
7529      END IF
7530      count = count + 1
7531      END DO
7532      END DO
7533      next = NXTASK(-nprocs, 1)
7534      call GA_SYNC()
7535      RETURN
7536      END
7537      SUBROUTINE ipccsd_x2_6_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
7538     &set)
7539C     $Id$
7540C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
7541C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
7542C     i1 ( h10 p3 h1 h2 )_vx + = -1 * P( 2 ) * Sum ( h8 p9 ) * x ( p3 p9 h1 h8 )_x * i2 ( h8 h10 h2 p9 )_v
7543      IMPLICIT NONE
7544#include "global.fh"
7545#include "mafdecls.fh"
7546#include "sym.fh"
7547#include "errquit.fh"
7548#include "tce.fh"
7549#include "stdio.fh"
7550      INTEGER d_a
7551      INTEGER k_a_offset
7552      INTEGER d_b
7553      INTEGER k_b_offset
7554      INTEGER d_c
7555      INTEGER k_c_offset
7556      INTEGER NXTASK
7557      INTEGER next
7558      INTEGER nprocs
7559      INTEGER count
7560      INTEGER p3b
7561      INTEGER h10b
7562      INTEGER h1b
7563      INTEGER h2b
7564      INTEGER dimc
7565      INTEGER l_c_sort
7566      INTEGER k_c_sort
7567      INTEGER p9b
7568      INTEGER h8b
7569      INTEGER p3b_1
7570      INTEGER p9b_1
7571      INTEGER h1b_1
7572      INTEGER h8b_1
7573      INTEGER h10b_2
7574      INTEGER h8b_2
7575      INTEGER h2b_2
7576      INTEGER p9b_2
7577      INTEGER dim_common
7578      INTEGER dima_sort
7579      INTEGER dima
7580      INTEGER dimb_sort
7581      INTEGER dimb
7582      INTEGER l_a_sort
7583      INTEGER k_a_sort
7584      INTEGER l_a
7585      INTEGER k_a
7586      INTEGER l_b_sort
7587      INTEGER k_b_sort
7588      INTEGER l_b
7589      INTEGER k_b
7590      INTEGER l_c
7591      INTEGER k_c
7592      EXTERNAL NXTASK
7593      nprocs = GA_NNODES()
7594      count = 0
7595      next = NXTASK(nprocs, 1)
7596ckbn      DO p3b = noab+1,noab+nvab
7597      DO p3b = 1,1
7598      DO h10b = 1,noab
7599      DO h1b = 1,noab
7600      DO h2b = 1,noab
7601      IF (next.eq.count) THEN
7602ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
7603ckbn     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
7604      IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+h10b-
7605     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
7606ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
7607ckbn     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
7608      IF (ip_unused_spin +int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
7609     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
7610ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
7611ckbn     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T
7612ckbn     &HEN
7613      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+h10b-1),ieor(int_mb
7614     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_x)) T
7615     &HEN
7616ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
7617ckbn     &ange+h1b-1) * int_mb(k_range+h2b-1)
7618      dimc = 1 * int_mb(k_range+h10b-1) * int_mb(k_r
7619     &ange+h1b-1) * int_mb(k_range+h2b-1)
7620      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
7621     & ERRQUIT('ipccsd_x2_6_3',0,MA_ERR)
7622      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
7623      DO p9b = noab+1,noab+nvab
7624      DO h8b = 1,noab
7625ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h
7626ckbn     &1b-1)+int_mb(k_spin+h8b-1)) THEN
7627      IF (ip_unused_spin +int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h
7628     &1b-1)+int_mb(k_spin+h8b-1)) THEN
7629ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p9b-1),ieor(int_mb(
7630ckbn     &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_x) THEN
7631      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p9b-1),ieor(int_mb(
7632     &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_x) THEN
7633      CALL TCE_RESTRICTED_4(p3b,p9b,h1b,h8b,p3b_1,p9b_1,h1b_1,h8b_1)
7634      CALL TCE_RESTRICTED_4(h10b,h8b,h2b,p9b,h10b_2,h8b_2,h2b_2,p9b_2)
7635      dim_common = int_mb(k_range+p9b-1) * int_mb(k_range+h8b-1)
7636ckbn      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
7637      dima_sort = 1 * int_mb(k_range+h1b-1)
7638      dima = dim_common * dima_sort
7639      dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h2b-1)
7640      dimb = dim_common * dimb_sort
7641      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
7642      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
7643     & ERRQUIT('ipccsd_x2_6_3',1,MA_ERR)
7644      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
7645     &ipccsd_x2_6_3',2,MA_ERR)
7646c      write(LuOut,*) "I am here 1."
7647c      call util_flush(LuOut)
7648ckbn      IF ((p9b .lt. p3b) .and. (h8b .lt. h1b)) THEN
7649      IF ( (h8b .lt. h1b)) THEN
7650      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
7651     & - 1 + noab * (h8b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p9b_
7652     &1 - noab - 1)))))
7653ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1)
7654ckbn     &,int_mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1)
7655ckbn     &,4,2,3,1,1.0d0)
7656      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1)
7657     &,1,int_mb(k_range+h8b-1),int_mb(k_range+h1b-1)
7658     &,4,2,3,1,1.0d0)
7659      END IF
7660c      write(LuOut,*) "I am here 1.1"
7661c      call util_flush(LuOut)
7662ckbn      IF ((p9b .lt. p3b) .and. (h1b .le. h8b)) THEN
7663      IF ( (h1b .le. h8b)) THEN
7664      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
7665     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p9b_
7666     &1 - noab - 1)))))
7667ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1)
7668ckbn     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1)
7669ckbn     &,3,2,4,1,-1.0d0)
7670      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1)
7671     &,1,int_mb(k_range+h1b-1),int_mb(k_range+h8b-1)
7672     &,3,2,4,1,-1.0d0)
7673      END IF
7674ckbn      IF ((p3b .le. p9b) .and. (h8b .lt. h1b)) THEN
7675ckbn      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
7676ckbn     & - 1 + noab * (h8b_1 - 1 + noab * (p9b_1 - noab - 1 + nvab * (p3b_
7677ckbn     &1 - noab - 1)))))
7678ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
7679ckbn     &,int_mb(k_range+p9b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1)
7680ckbn     &,4,1,3,2,-1.0d0)
7681ckbn      END IF
7682ckbn      IF ((p3b .le. p9b) .and. (h1b .le. h8b)) THEN
7683ckbn      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
7684ckbn     & - 1 + noab * (h1b_1 - 1 + noab * (p9b_1 - noab - 1 + nvab * (p3b_
7685ckbn     &1 - noab - 1)))))
7686ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
7687ckbn     &,int_mb(k_range+p9b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1)
7688ckbn     &,3,1,4,2,1.0d0)
7689ckbn      END IF
7690c      write(LuOut,*) "I am here 2."
7691c      call util_flush(LuOut)
7692      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_3',3,MA_ERR)
7693      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
7694     & ERRQUIT('ipccsd_x2_6_3',4,MA_ERR)
7695      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
7696     &ipccsd_x2_6_3',5,MA_ERR)
7697      IF ((h8b .le. h10b)) THEN
7698      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
7699     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h10b_2 - 1 + noab * (h8b
7700     &_2 - 1)))))
7701      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
7702     &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+p9b-1
7703     &),3,2,1,4,1.0d0)
7704      END IF
7705      IF ((h10b .lt. h8b)) THEN
7706      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
7707     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h8b_2 - 1 + noab * (h10b
7708     &_2 - 1)))))
7709      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
7710     &),int_mb(k_range+h8b-1),int_mb(k_range+h2b-1),int_mb(k_range+p9b-1
7711     &),3,1,2,4,-1.0d0)
7712      END IF
7713      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_3',6,MA_ERR)
7714      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
7715     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
7716     &t),dima_sort)
7717      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_3',7,MA
7718     &_ERR)
7719      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_3',8,MA
7720     &_ERR)
7721      END IF
7722      END IF
7723      END IF
7724      END DO
7725      END DO
7726      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
7727     &ipccsd_x2_6_3',9,MA_ERR)
7728c      write(LuOut,*) "I am here 3."
7729c      call util_flush(LuOut)
7730      IF ((h1b .le. h2b)) THEN
7731ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
7732ckbn     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1
7733ckbn     &),4,2,3,1,-1.0d0)
7734      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
7735     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),1
7736     &,4,2,3,1,-1.0d0)
7737      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
7738     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
7739     &)))
7740      END IF
7741      IF ((h2b .le. h1b)) THEN
7742ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
7743ckbn     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1
7744ckbn     &),4,2,1,3,1.0d0)
7745      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
7746     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),1
7747     & ,4,2,1,3,1.0d0)
7748      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
7749     & 1 + noab * (h2b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
7750     &)))
7751      END IF
7752c      write(LuOut,*) "I am here 4."
7753c      call util_flush(LuOut)
7754      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_3',10,MA_ERR
7755     &)
7756      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_3',11,M
7757     &A_ERR)
7758      END IF
7759      END IF
7760      END IF
7761      next = NXTASK(nprocs, 1)
7762      END IF
7763      count = count + 1
7764      END DO
7765      END DO
7766      END DO
7767      END DO
7768      next = NXTASK(-nprocs, 1)
7769      call GA_SYNC()
7770      RETURN
7771      END
7772      SUBROUTINE ipccsd_x2_6_3_1(d_a,k_a_offset,d_c,k_c_offset)
7773C     $Id$
7774C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
7775C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
7776C     i2 ( h8 h10 h1 p9 )_v + = 1 * v ( h8 h10 h1 p9 )_v
7777      IMPLICIT NONE
7778#include "global.fh"
7779#include "mafdecls.fh"
7780#include "sym.fh"
7781#include "errquit.fh"
7782#include "tce.fh"
7783      INTEGER d_a
7784      INTEGER k_a_offset
7785      INTEGER d_c
7786      INTEGER k_c_offset
7787      INTEGER NXTASK
7788      INTEGER next
7789      INTEGER nprocs
7790      INTEGER count
7791      INTEGER h8b
7792      INTEGER h10b
7793      INTEGER h1b
7794      INTEGER p9b
7795      INTEGER dimc
7796      INTEGER h8b_1
7797      INTEGER h10b_1
7798      INTEGER h1b_1
7799      INTEGER p9b_1
7800      INTEGER dim_common
7801      INTEGER dima_sort
7802      INTEGER dima
7803      INTEGER l_a_sort
7804      INTEGER k_a_sort
7805      INTEGER l_a
7806      INTEGER k_a
7807      INTEGER l_c
7808      INTEGER k_c
7809      EXTERNAL NXTASK
7810      nprocs = GA_NNODES()
7811      count = 0
7812      next = NXTASK(nprocs, 1)
7813      DO h8b = 1,noab
7814      DO h10b = h8b,noab
7815      DO h1b = 1,noab
7816      DO p9b = noab+1,noab+nvab
7817      IF (next.eq.count) THEN
7818      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
7819     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN
7820      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
7821     &h1b-1)+int_mb(k_spin+p9b-1)) THEN
7822      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
7823     &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN
7824      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
7825     &ange+h1b-1) * int_mb(k_range+p9b-1)
7826      CALL TCE_RESTRICTED_4(h8b,h10b,h1b,p9b,h8b_1,h10b_1,h1b_1,p9b_1)
7827      dim_common = 1
7828      dima_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m
7829     &b(k_range+h1b-1) * int_mb(k_range+p9b-1)
7830      dima = dim_common * dima_sort
7831      IF (dima .gt. 0) THEN
7832      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
7833     & ERRQUIT('ipccsd_x2_6_3_1',0,MA_ERR)
7834      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
7835     &ipccsd_x2_6_3_1',1,MA_ERR)
7836      IF ((h1b .le. p9b)) THEN
7837      if(.not.intorb) then
7838      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p9b_1
7839     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
7840     &b+nvab) * (h8b_1 - 1)))))
7841      else
7842      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
7843     &(p9b_1
7844     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
7845     &b+nvab) * (h8b_1 - 1)))),p9b_1,h1b_1,h10b_1,h8b_1)
7846      end if
7847      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h8b-1)
7848     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p9b-1
7849     &),4,3,2,1,1.0d0)
7850      END IF
7851      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_3_1',2,MA_ER
7852     &R)
7853      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
7854     &ipccsd_x2_6_3_1',3,MA_ERR)
7855      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p9b-1)
7856     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h8b-1
7857     &),4,3,2,1,1.0d0)
7858      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b -
7859     & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1))
7860     &)))
7861      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_3_1',4,MA_ER
7862     &R)
7863      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_3_1',5,
7864     &MA_ERR)
7865      END IF
7866      END IF
7867      END IF
7868      END IF
7869      next = NXTASK(nprocs, 1)
7870      END IF
7871      count = count + 1
7872      END DO
7873      END DO
7874      END DO
7875      END DO
7876      next = NXTASK(-nprocs, 1)
7877      call GA_SYNC()
7878      RETURN
7879      END
7880      SUBROUTINE OFFSET_ipccsd_x2_6_3_1(l_a_offset,k_a_offset,size)
7881C     $Id$
7882C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
7883C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
7884C     i2 ( h8 h10 h1 p9 )_v
7885      IMPLICIT NONE
7886#include "global.fh"
7887#include "mafdecls.fh"
7888#include "sym.fh"
7889#include "errquit.fh"
7890#include "tce.fh"
7891      INTEGER l_a_offset
7892      INTEGER k_a_offset
7893      INTEGER size
7894      INTEGER length
7895      INTEGER addr
7896      INTEGER h8b
7897      INTEGER h10b
7898      INTEGER h1b
7899      INTEGER p9b
7900      length = 0
7901      DO h8b = 1,noab
7902      DO h10b = h8b,noab
7903      DO h1b = 1,noab
7904      DO p9b = noab+1,noab+nvab
7905      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
7906     &h1b-1)+int_mb(k_spin+p9b-1)) THEN
7907      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
7908     &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN
7909      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
7910     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN
7911      length = length + 1
7912      END IF
7913      END IF
7914      END IF
7915      END DO
7916      END DO
7917      END DO
7918      END DO
7919      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
7920     &set)) CALL ERRQUIT('ipccsd_x2_6_3_1',0,MA_ERR)
7921      int_mb(k_a_offset) = length
7922      addr = 0
7923      size = 0
7924      DO h8b = 1,noab
7925      DO h10b = h8b,noab
7926      DO h1b = 1,noab
7927      DO p9b = noab+1,noab+nvab
7928      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
7929     &h1b-1)+int_mb(k_spin+p9b-1)) THEN
7930      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
7931     &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN
7932      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
7933     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN
7934      addr = addr + 1
7935      int_mb(k_a_offset+addr) = p9b - noab - 1 + nvab * (h1b - 1 + noab
7936     &* (h10b - 1 + noab * (h8b - 1)))
7937      int_mb(k_a_offset+length+addr) = size
7938      size = size + int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int
7939     &_mb(k_range+h1b-1) * int_mb(k_range+p9b-1)
7940      END IF
7941      END IF
7942      END IF
7943      END DO
7944      END DO
7945      END DO
7946      END DO
7947      RETURN
7948      END
7949      SUBROUTINE ipccsd_x2_6_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
7950     &ffset)
7951C     $Id$
7952C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
7953C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
7954C     i2 ( h8 h10 h1 p9 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h8 h10 p5 p9 )_v
7955      IMPLICIT NONE
7956#include "global.fh"
7957#include "mafdecls.fh"
7958#include "sym.fh"
7959#include "errquit.fh"
7960#include "tce.fh"
7961      INTEGER d_a
7962      INTEGER k_a_offset
7963      INTEGER d_b
7964      INTEGER k_b_offset
7965      INTEGER d_c
7966      INTEGER k_c_offset
7967      INTEGER NXTASK
7968      INTEGER next
7969      INTEGER nprocs
7970      INTEGER count
7971      INTEGER h8b
7972      INTEGER h10b
7973      INTEGER h1b
7974      INTEGER p9b
7975      INTEGER dimc
7976      INTEGER l_c_sort
7977      INTEGER k_c_sort
7978      INTEGER p5b
7979      INTEGER p5b_1
7980      INTEGER h1b_1
7981      INTEGER h8b_2
7982      INTEGER h10b_2
7983      INTEGER p9b_2
7984      INTEGER p5b_2
7985      INTEGER dim_common
7986      INTEGER dima_sort
7987      INTEGER dima
7988      INTEGER dimb_sort
7989      INTEGER dimb
7990      INTEGER l_a_sort
7991      INTEGER k_a_sort
7992      INTEGER l_a
7993      INTEGER k_a
7994      INTEGER l_b_sort
7995      INTEGER k_b_sort
7996      INTEGER l_b
7997      INTEGER k_b
7998      INTEGER l_c
7999      INTEGER k_c
8000      EXTERNAL NXTASK
8001      nprocs = GA_NNODES()
8002      count = 0
8003      next = NXTASK(nprocs, 1)
8004      DO h8b = 1,noab
8005      DO h10b = h8b,noab
8006      DO h1b = 1,noab
8007      DO p9b = noab+1,noab+nvab
8008      IF (next.eq.count) THEN
8009      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-
8010     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN
8011      IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
8012     &h1b-1)+int_mb(k_spin+p9b-1)) THEN
8013      IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
8014     &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. ieor(irrep_v,irrep_t)) T
8015     &HEN
8016      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
8017     &ange+h1b-1) * int_mb(k_range+p9b-1)
8018      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
8019     & ERRQUIT('ipccsd_x2_6_3_2',0,MA_ERR)
8020      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
8021      DO p5b = noab+1,noab+nvab
8022      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
8023      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
8024     &EN
8025      CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1)
8026      CALL TCE_RESTRICTED_4(h8b,h10b,p9b,p5b,h8b_2,h10b_2,p9b_2,p5b_2)
8027      dim_common = int_mb(k_range+p5b-1)
8028      dima_sort = int_mb(k_range+h1b-1)
8029      dima = dim_common * dima_sort
8030      dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h10b-1) * int_m
8031     &b(k_range+p9b-1)
8032      dimb = dim_common * dimb_sort
8033      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
8034      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
8035     & ERRQUIT('ipccsd_x2_6_3_2',1,MA_ERR)
8036      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
8037     &ipccsd_x2_6_3_2',2,MA_ERR)
8038      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
8039     & - 1 + noab * (p5b_1 - noab - 1)))
8040      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
8041     &,int_mb(k_range+h1b-1),2,1,1.0d0)
8042      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_6_3_2',3,MA_ER
8043     &R)
8044      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
8045     & ERRQUIT('ipccsd_x2_6_3_2',4,MA_ERR)
8046      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
8047     &ipccsd_x2_6_3_2',5,MA_ERR)
8048      IF ((p5b .le. p9b)) THEN
8049      if(.not.intorb) then
8050      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
8051     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
8052     &b+nvab) * (h8b_2 - 1)))))
8053      else
8054      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
8055     &(p9b_2
8056     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
8057     &b+nvab) * (h8b_2 - 1)))),p9b_2,p5b_2,h10b_2,h8b_2)
8058      end if
8059      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
8060     &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1
8061     &),4,2,1,3,1.0d0)
8062      END IF
8063      IF ((p9b .lt. p5b)) THEN
8064      if(.not.intorb) then
8065      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
8066     & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
8067     &b+nvab) * (h8b_2 - 1)))))
8068      else
8069      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
8070     &(p5b_2
8071     & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
8072     &b+nvab) * (h8b_2 - 1)))),p5b_2,p9b_2,h10b_2,h8b_2)
8073      end if
8074      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
8075     &,int_mb(k_range+h10b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1
8076     &),3,2,1,4,-1.0d0)
8077      END IF
8078      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_6_3_2',6,MA_ER
8079     &R)
8080      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
8081     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
8082     &t),dima_sort)
8083      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_6_3_2',7,
8084     &MA_ERR)
8085      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_6_3_2',8,
8086     &MA_ERR)
8087      END IF
8088      END IF
8089      END IF
8090      END DO
8091      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
8092     &ipccsd_x2_6_3_2',9,MA_ERR)
8093      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p9b-1)
8094     &,int_mb(k_range+h10b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1
8095     &),3,2,4,1,1.0d0)
8096      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b -
8097     & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h8b - 1))
8098     &)))
8099      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_6_3_2',10,MA_E
8100     &RR)
8101      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_6_3_2',11
8102     &,MA_ERR)
8103      END IF
8104      END IF
8105      END IF
8106      next = NXTASK(nprocs, 1)
8107      END IF
8108      count = count + 1
8109      END DO
8110      END DO
8111      END DO
8112      END DO
8113      next = NXTASK(-nprocs, 1)
8114      call GA_SYNC()
8115      RETURN
8116      END
8117      SUBROUTINE ipccsd_x2_7(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
8118     &t)
8119C     $Id$
8120C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
8121C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
8122C     i0 ( p3 p4 h1 h2 )_vxt + = 1/2 * P( 2 ) * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i1 ( p4 p5 )_vx
8123      IMPLICIT NONE
8124#include "global.fh"
8125#include "mafdecls.fh"
8126#include "sym.fh"
8127#include "errquit.fh"
8128#include "tce.fh"
8129      INTEGER d_a
8130      INTEGER k_a_offset
8131      INTEGER d_b
8132      INTEGER k_b_offset
8133      INTEGER d_c
8134      INTEGER k_c_offset
8135      INTEGER NXTASK
8136      INTEGER next
8137      INTEGER nprocs
8138      INTEGER count
8139      INTEGER p3b
8140      INTEGER p4b
8141      INTEGER h1b
8142      INTEGER h2b
8143      INTEGER dimc
8144      INTEGER l_c_sort
8145      INTEGER k_c_sort
8146      INTEGER p5b
8147      INTEGER p3b_1
8148      INTEGER p5b_1
8149      INTEGER h1b_1
8150      INTEGER h2b_1
8151      INTEGER p4b_2
8152      INTEGER p5b_2
8153      INTEGER dim_common
8154      INTEGER dima_sort
8155      INTEGER dima
8156      INTEGER dimb_sort
8157      INTEGER dimb
8158      INTEGER l_a_sort
8159      INTEGER k_a_sort
8160      INTEGER l_a
8161      INTEGER k_a
8162      INTEGER l_b_sort
8163      INTEGER k_b_sort
8164      INTEGER l_b
8165      INTEGER k_b
8166      INTEGER l_c
8167      INTEGER k_c
8168      EXTERNAL NXTASK
8169      nprocs = GA_NNODES()
8170      count = 0
8171      next = NXTASK(nprocs, 1)
8172      DO p3b = noab+1,noab+nvab
8173ckbn      DO p4b = noab+1,noab+nvab
8174      DO p4b = 1,1
8175      DO h1b = 1,noab
8176      DO h2b = h1b,noab
8177      IF (next.eq.count) THEN
8178ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
8179ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
8180      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ ip_unused_spin
8181     & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
8182ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
8183ckbn     &1b-1)+int_mb(k_spin+h2b-1)) THEN
8184      IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h
8185     &1b-1)+int_mb(k_spin+h2b-1)) THEN
8186ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
8187ckbn     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x
8188ckbn     &,irrep_t))) THEN
8189      IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb(
8190     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x
8191     &,irrep_t))) THEN
8192ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
8193ckbn     &nge+h1b-1) * int_mb(k_range+h2b-1)
8194      dimc = int_mb(k_range+p3b-1) * 1 * int_mb(k_ra
8195     &nge+h1b-1) * int_mb(k_range+h2b-1)
8196      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
8197     & ERRQUIT('ipccsd_x2_7',0,MA_ERR)
8198      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
8199      DO p5b = noab+1,noab+nvab
8200      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
8201     &1b-1)+int_mb(k_spin+h2b-1)) THEN
8202      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
8203     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
8204      CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h2b,p3b_1,p5b_1,h1b_1,h2b_1)
8205      CALL TCE_RESTRICTED_2(p4b,p5b,p4b_2,p5b_2)
8206      dim_common = int_mb(k_range+p5b-1)
8207      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb
8208     &(k_range+h2b-1)
8209      dima = dim_common * dima_sort
8210ckbn      dimb_sort = int_mb(k_range+p4b-1)
8211      dimb_sort = 1
8212      dimb = dim_common * dimb_sort
8213      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
8214      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
8215     & ERRQUIT('ipccsd_x2_7',1,MA_ERR)
8216      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
8217     &ipccsd_x2_7',2,MA_ERR)
8218      IF ((p5b .lt. p3b)) THEN
8219      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
8220     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
8221     &1 - noab - 1)))))
8222      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
8223     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
8224     &,4,3,2,1,-1.0d0)
8225      END IF
8226      IF ((p3b .le. p5b)) THEN
8227      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
8228     & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
8229     &1 - noab - 1)))))
8230      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
8231     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
8232     &,4,3,1,2,1.0d0)
8233      END IF
8234      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_7',3,MA_ERR)
8235      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
8236     & ERRQUIT('ipccsd_x2_7',4,MA_ERR)
8237      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
8238     &ipccsd_x2_7',5,MA_ERR)
8239      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
8240     & - noab - 1 + nvab * (p4b_2 - noab - 1)))
8241ckbn      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
8242ckbn     &,int_mb(k_range+p5b-1),1,2,1.0d0)
8243      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),1
8244     &,int_mb(k_range+p5b-1),1,2,1.0d0)
8245      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_7',6,MA_ERR)
8246      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
8247     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
8248     &t),dima_sort)
8249      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_7',7,MA_E
8250     &RR)
8251      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_7',8,MA_E
8252     &RR)
8253      END IF
8254      END IF
8255      END IF
8256      END DO
8257      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
8258     &ipccsd_x2_7',9,MA_ERR)
8259ckbn      IF ((p3b .le. p4b)) THEN
8260ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1)
8261ckbn     &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
8262ckbn     &,4,1,3,2,1.0d0/2.0d0)
8263      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),1
8264     &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
8265     &,4,1,3,2,1.0d0/2.0d0)
8266      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
8267     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
8268     & - 1)))))
8269ckbn      END IF
8270ckbn      IF ((p4b .le. p3b)) THEN
8271ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1)
8272ckbn     &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
8273ckbn     &,1,4,3,2,-1.0d0/2.0d0)
8274ckbn      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
8275ckbn     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
8276ckbn     & - 1)))))
8277ckbn      END IF
8278      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_7',10,MA_ERR)
8279      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_7',11,MA_
8280     &ERR)
8281      END IF
8282      END IF
8283      END IF
8284      next = NXTASK(nprocs, 1)
8285      END IF
8286      count = count + 1
8287      END DO
8288      END DO
8289      END DO
8290      END DO
8291      next = NXTASK(-nprocs, 1)
8292      call GA_SYNC()
8293      RETURN
8294      END
8295      SUBROUTINE ipccsd_x2_7_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
8296     &set)
8297C     $Id$
8298C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
8299C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
8300C     i1 ( p3 p5 )_vx + = -1 * Sum ( h6 h7 p8 ) * x ( p3 p8 h6 h7 )_x * v ( h6 h7 p5 p8 )_v
8301      IMPLICIT NONE
8302#include "global.fh"
8303#include "mafdecls.fh"
8304#include "sym.fh"
8305#include "errquit.fh"
8306#include "tce.fh"
8307#include "stdio.fh"
8308      INTEGER d_a
8309      INTEGER k_a_offset
8310      INTEGER d_b
8311      INTEGER k_b_offset
8312      INTEGER d_c
8313      INTEGER k_c_offset
8314      INTEGER NXTASK
8315      INTEGER next
8316      INTEGER nprocs
8317      INTEGER count
8318      INTEGER p3b
8319      INTEGER p5b
8320      INTEGER dimc
8321      INTEGER l_c_sort
8322      INTEGER k_c_sort
8323      INTEGER p8b
8324      INTEGER h6b
8325      INTEGER h7b
8326      INTEGER p3b_1
8327      INTEGER p8b_1
8328      INTEGER h6b_1
8329      INTEGER h7b_1
8330      INTEGER h6b_2
8331      INTEGER h7b_2
8332      INTEGER p5b_2
8333      INTEGER p8b_2
8334      INTEGER dim_common
8335      INTEGER dima_sort
8336      INTEGER dima
8337      INTEGER dimb_sort
8338      INTEGER dimb
8339      INTEGER l_a_sort
8340      INTEGER k_a_sort
8341      INTEGER l_a
8342      INTEGER k_a
8343      INTEGER l_b_sort
8344      INTEGER k_b_sort
8345      INTEGER l_b
8346      INTEGER k_b
8347      INTEGER nsubh(2)
8348      INTEGER isubh
8349      INTEGER l_c
8350      INTEGER k_c
8351      DOUBLE PRECISION FACTORIAL
8352      EXTERNAL NXTASK
8353      EXTERNAL FACTORIAL
8354      nprocs = GA_NNODES()
8355      count = 0
8356      next = NXTASK(nprocs, 1)
8357ckbn      DO p3b = noab+1,noab+nvab
8358      DO p3b = 1,1
8359      DO p5b = noab+1,noab+nvab
8360      IF (next.eq.count) THEN
8361ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
8362ckbn     &).ne.4)) THEN
8363      IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p5b-1
8364     &).ne.4)) THEN
8365ckbn      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
8366      IF (ip_unused_spin .eq. int_mb(k_spin+p5b-1)) THEN
8367ckbn      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
8368ckbn     &v,irrep_x)) THEN
8369      IF (ieor(ip_unused_sym ,int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
8370     &v,irrep_x)) THEN
8371ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1)
8372      dimc = 1 * int_mb(k_range+p5b-1)
8373      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
8374     & ERRQUIT('ipccsd_x2_7_1',0,MA_ERR)
8375      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
8376      DO p8b = noab+1,noab+nvab
8377      DO h6b = 1,noab
8378      DO h7b = h6b,noab
8379ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
8380ckbn     &6b-1)+int_mb(k_spin+h7b-1)) THEN
8381      IF (ip_unused_spin +int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
8382     &6b-1)+int_mb(k_spin+h7b-1)) THEN
8383ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
8384ckbn     &k_sym+h6b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN
8385      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
8386     &k_sym+h6b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN
8387      CALL TCE_RESTRICTED_4(p3b,p8b,h6b,h7b,p3b_1,p8b_1,h6b_1,h7b_1)
8388      CALL TCE_RESTRICTED_4(h6b,h7b,p5b,p8b,h6b_2,h7b_2,p5b_2,p8b_2)
8389      dim_common = int_mb(k_range+p8b-1) * int_mb(k_range+h6b-1) * int_m
8390     &b(k_range+h7b-1)
8391ckbn      dima_sort = int_mb(k_range+p3b-1)
8392      dima_sort = 1
8393      dima = dim_common * dima_sort
8394      dimb_sort = int_mb(k_range+p5b-1)
8395      dimb = dim_common * dimb_sort
8396      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
8397      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
8398     & ERRQUIT('ipccsd_x2_7_1',1,MA_ERR)
8399      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
8400     &ipccsd_x2_7_1',2,MA_ERR)
8401c      write(LuOut,*) "I am here 1."
8402c      call util_flush(LuOut)
8403ckbn      IF ((p8b .lt. p3b)) THEN
8404      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
8405     & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_
8406     &1 - noab - 1)))))
8407ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
8408ckbn     &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h7b-1)
8409ckbn     &,2,4,3,1,-1.0d0)
8410      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
8411     &,1,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1)
8412     &,2,4,3,1,-1.0d0)
8413ckbn      END IF
8414ckbn      IF ((p3b .le. p8b)) THEN
8415ckbn      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
8416ckbn     & - 1 + noab * (h6b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_
8417ckbn     &1 - noab - 1)))))
8418ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
8419ckbn     &,int_mb(k_range+p8b-1),int_mb(k_range+h6b-1),int_mb(k_range+h7b-1)
8420ckbn     &,1,4,3,2,1.0d0)
8421ckbn      END IF
8422c      write(LuOut,*) "I am here 2."
8423c      call util_flush(LuOut)
8424      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_7_1',3,MA_ERR)
8425      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
8426     & ERRQUIT('ipccsd_x2_7_1',4,MA_ERR)
8427      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
8428     &ipccsd_x2_7_1',5,MA_ERR)
8429      IF ((p8b .lt. p5b)) THEN
8430      if(.not.intorb) then
8431      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
8432     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
8433     &+nvab) * (h6b_2 - 1)))))
8434      else
8435      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
8436     &(p5b_2
8437     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
8438     &+nvab) * (h6b_2 - 1)))),p5b_2,p8b_2,h7b_2,h6b_2)
8439      end if
8440      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
8441     &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1)
8442     &,4,2,1,3,-1.0d0)
8443      END IF
8444      IF ((p5b .le. p8b)) THEN
8445      if(.not.intorb) then
8446      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
8447     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
8448     &+nvab) * (h6b_2 - 1)))))
8449      else
8450      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
8451     &(p8b_2
8452     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
8453     &+nvab) * (h6b_2 - 1)))),p8b_2,p5b_2,h7b_2,h6b_2)
8454      end if
8455      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
8456     &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1)
8457     &,3,2,1,4,1.0d0)
8458      END IF
8459      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_7_1',6,MA_ERR)
8460      nsubh(1) = 1
8461      nsubh(2) = 1
8462      isubh = 1
8463      IF (h6b .eq. h7b) THEN
8464      nsubh(isubh) = nsubh(isubh) + 1
8465      ELSE
8466      isubh = isubh + 1
8467      END IF
8468      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
8469     &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k
8470     &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
8471      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_7_1',7,MA
8472     &_ERR)
8473      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_7_1',8,MA
8474     &_ERR)
8475      END IF
8476      END IF
8477      END IF
8478      END DO
8479      END DO
8480      END DO
8481      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
8482     &ipccsd_x2_7_1',9,MA_ERR)
8483c      write(LuOut,*) "I am here 3."
8484c      call util_flush(LuOut)
8485ckbn      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
8486ckbn     &,int_mb(k_range+p3b-1),2,1,-1.0d0)
8487      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
8488     &,1,2,1,-1.0d0)
8489      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
8490     & noab - 1 + nvab * (p3b - noab - 1)))
8491c      write(LuOut,*) "I am here 4."
8492c      call util_flush(LuOut)
8493      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_7_1',10,MA_ERR
8494     &)
8495      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_7_1',11,M
8496     &A_ERR)
8497      END IF
8498      END IF
8499      END IF
8500      next = NXTASK(nprocs, 1)
8501      END IF
8502      count = count + 1
8503      END DO
8504      END DO
8505      next = NXTASK(-nprocs, 1)
8506      call GA_SYNC()
8507      RETURN
8508      END
8509
8510ckbn      SUBROUTINE OFFSET_ipccsd_x2_7_1(l_a_offset,k_a_offset,size)
8511ckbnC     $Id$
8512ckbnC     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
8513ckbnC     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
8514ckbnC     i1 ( p3 p5 )_vx
8515ckbn      IMPLICIT NONE
8516ckbn#include "global.fh"
8517ckbn#include "mafdecls.fh"
8518ckbn#include "sym.fh"
8519ckbn#include "errquit.fh"
8520ckbn#include "tce.fh"
8521ckbn      INTEGER l_a_offset
8522ckbn      INTEGER k_a_offset
8523ckbn      INTEGER size
8524ckbn      INTEGER length
8525ckbn      INTEGER addr
8526ckbn      INTEGER p3b
8527ckbn      INTEGER p5b
8528ckbn      length = 0
8529ckbn      DO p3b = noab+1,noab+nvab
8530ckbn      DO p5b = noab+1,noab+nvab
8531ckbn      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
8532ckbn      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
8533ckbn     &v,irrep_x)) THEN
8534ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
8535ckbn     &).ne.4)) THEN
8536ckbn      length = length + 1
8537ckbn      END IF
8538ckbn      END IF
8539ckbn      END IF
8540ckbn      END DO
8541ckbn      END DO
8542ckbn      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
8543ckbn     &set)) CALL ERRQUIT('ipccsd_x2_7_1',0,MA_ERR)
8544ckbn      int_mb(k_a_offset) = length
8545ckbn      addr = 0
8546ckbn      size = 0
8547ckbn      DO p3b = noab+1,noab+nvab
8548ckbn      DO p5b = noab+1,noab+nvab
8549ckbn      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
8550ckbn      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
8551ckbn     &v,irrep_x)) THEN
8552ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
8553ckbn     &).ne.4)) THEN
8554ckbn      addr = addr + 1
8555ckbn      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (p3b - noab - 1)
8556ckbn      int_mb(k_a_offset+length+addr) = size
8557ckbn      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1)
8558ckbn      END IF
8559ckbn      END IF
8560ckbn      END IF
8561ckbn      END DO
8562ckbn      END DO
8563ckbn      RETURN
8564ckbn      END
8565
8566      SUBROUTINE OFFSET_ipccsd_x2_7_1(l_a_offset,k_a_offset,size)
8567C     $Id$
8568C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
8569C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
8570C     i1 ( p3 p5 )_vx
8571      IMPLICIT NONE
8572#include "global.fh"
8573#include "mafdecls.fh"
8574#include "sym.fh"
8575#include "errquit.fh"
8576#include "tce.fh"
8577      INTEGER l_a_offset
8578      INTEGER k_a_offset
8579      INTEGER size
8580      INTEGER length
8581      INTEGER addr
8582      INTEGER p3b
8583      INTEGER p5b
8584      length = 0
8585ckbn      DO p3b = noab+1,noab+nvab
8586      DO p3b =1,1
8587      DO p5b = noab+1,noab+nvab
8588ckbn      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
8589      IF (ip_unused_spin .eq. int_mb(k_spin+p5b-1)) THEN
8590ckbn      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
8591ckbn     &v,irrep_x)) THEN
8592      IF (ieor(ip_unused_sym,int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
8593     &v,irrep_x)) THEN
8594ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
8595ckbn     &).ne.4)) THEN
8596      IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p5b-1
8597     &).ne.4)) THEN
8598      length = length + 1
8599      END IF
8600      END IF
8601      END IF
8602      END DO
8603      END DO
8604      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
8605     &set)) CALL ERRQUIT('ipccsd_x2_7_1',0,MA_ERR)
8606      int_mb(k_a_offset) = length
8607      addr = 0
8608      size = 0
8609ckbn      DO p3b = noab+1,noab+nvab
8610      DO p3b = 1,1
8611      DO p5b = noab+1,noab+nvab
8612ckbn      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
8613      IF (ip_unused_spin .eq. int_mb(k_spin+p5b-1)) THEN
8614ckbn      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
8615ckbn     &v,irrep_x)) THEN
8616      IF (ieor(ip_unused_sym,int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
8617     &v,irrep_x)) THEN
8618ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
8619ckbn     &).ne.4)) THEN
8620      IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+p5b-1
8621     &).ne.4)) THEN
8622      addr = addr + 1
8623      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (p3b - noab - 1)
8624      int_mb(k_a_offset+length+addr) = size
8625ckbn      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1)
8626      size = size + 1 * int_mb(k_range+p5b-1)
8627      END IF
8628      END IF
8629      END IF
8630      END DO
8631      END DO
8632      RETURN
8633      END
8634
8635
8636ckbn      SUBROUTINE OFFSET_ipccsd_x2_7_1(l_a_offset,k_a_offset,size)
8637ckbnC     $Id$
8638ckbnC     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
8639ckbnC     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
8640ckbnC     i1 ( p3 p5 )_vx
8641ckbn      IMPLICIT NONE
8642ckbn#include "global.fh"
8643ckbn#include "mafdecls.fh"
8644ckbn#include "sym.fh"
8645ckbn#include "errquit.fh"
8646ckbn#include "tce.fh"
8647ckbn      INTEGER l_a_offset
8648ckbn      INTEGER k_a_offset
8649ckbn      INTEGER size
8650ckbn      INTEGER length
8651ckbn      INTEGER addr
8652ckbn      INTEGER p3b
8653ckbn      INTEGER p5b
8654ckbn      length = 0
8655ckbn      DO p3b = noab+1,noab+nvab
8656ckbnckbn      DO p5b = noab+1,noab+nvab
8657ckbn      DO p5b = 1,1
8658ckbnckbn      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
8659ckbn      IF (int_mb(k_spin+p3b-1) .eq. ip_unused_spin) THEN
8660ckbnckbn      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
8661ckbnckbn     &v,irrep_x)) THEN
8662ckbn      IF (ieor(int_mb(k_sym+p3b-1),ip_unused_sym ) .eq. ieor(irrep_
8663ckbn     &v,irrep_x)) THEN
8664ckbnckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
8665ckbnckbn     &).ne.4)) THEN
8666ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ip_unused_spin
8667ckbn     & .ne.4)) THEN
8668ckbn      length = length + 1
8669ckbn      END IF
8670ckbn      END IF
8671ckbn      END IF
8672ckbn      END DO
8673ckbn      END DO
8674ckbn      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
8675ckbn     &set)) CALL ERRQUIT('ipccsd_x2_7_1',0,MA_ERR)
8676ckbn      int_mb(k_a_offset) = length
8677ckbn      addr = 0
8678ckbn      size = 0
8679ckbn      DO p3b = noab+1,noab+nvab
8680ckbnckbn      DO p5b = noab+1,noab+nvab
8681ckbn      DO p5b = 1,1
8682ckbnckbn      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
8683ckbn      IF (int_mb(k_spin+p3b-1) .eq. ip_unused_spin ) THEN
8684ckbnckbn      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
8685ckbnckbn     &v,irrep_x)) THEN
8686ckbn      IF (ieor(int_mb(k_sym+p3b-1),ip_unused_sym) .eq. ieor(irrep_
8687ckbn     &v,irrep_x)) THEN
8688ckbnckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
8689ckbnckbn     &).ne.4)) THEN
8690ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ ip_unused_spin
8691ckbn     & .ne.4)) THEN
8692ckbn      addr = addr + 1
8693ckbn      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (p3b - noab - 1)
8694ckbn      int_mb(k_a_offset+length+addr) = size
8695ckbnckbn      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1)
8696ckbn      size = size + int_mb(k_range+p3b-1) * 1
8697ckbn      END IF
8698ckbn      END IF
8699ckbn      END IF
8700ckbn      END DO
8701ckbn      END DO
8702ckbn      RETURN
8703ckbn      END
8704      SUBROUTINE ipccsd_x2_8(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
8705     &t)
8706C     $Id$
8707C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
8708C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
8709C     i0 ( p3 p4 h1 h2 )_vxt + = 1 * P( 4 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i1 ( h6 p4 h2 p5 )_vx
8710      IMPLICIT NONE
8711#include "global.fh"
8712#include "mafdecls.fh"
8713#include "sym.fh"
8714#include "errquit.fh"
8715#include "tce.fh"
8716      INTEGER d_a
8717      INTEGER k_a_offset
8718      INTEGER d_b
8719      INTEGER k_b_offset
8720      INTEGER d_c
8721      INTEGER k_c_offset
8722      INTEGER NXTASK
8723      INTEGER next
8724      INTEGER nprocs
8725      INTEGER count
8726      INTEGER p3b
8727      INTEGER p4b
8728      INTEGER h1b
8729      INTEGER h2b
8730      INTEGER dimc
8731      INTEGER l_c_sort
8732      INTEGER k_c_sort
8733      INTEGER p5b
8734      INTEGER h6b
8735      INTEGER p3b_1
8736      INTEGER p5b_1
8737      INTEGER h1b_1
8738      INTEGER h6b_1
8739      INTEGER p4b_2
8740      INTEGER h6b_2
8741      INTEGER h2b_2
8742      INTEGER p5b_2
8743      INTEGER dim_common
8744      INTEGER dima_sort
8745      INTEGER dima
8746      INTEGER dimb_sort
8747      INTEGER dimb
8748      INTEGER l_a_sort
8749      INTEGER k_a_sort
8750      INTEGER l_a
8751      INTEGER k_a
8752      INTEGER l_b_sort
8753      INTEGER k_b_sort
8754      INTEGER l_b
8755      INTEGER k_b
8756      INTEGER l_c
8757      INTEGER k_c
8758      EXTERNAL NXTASK
8759      nprocs = GA_NNODES()
8760      count = 0
8761      next = NXTASK(nprocs, 1)
8762      DO p3b = noab+1,noab+nvab
8763ckbn      DO p4b = noab+1,noab+nvab
8764      DO p4b = 1,1
8765      DO h1b = 1,noab
8766      DO h2b = 1,noab
8767      IF (next.eq.count) THEN
8768ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
8769ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
8770      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+ip_unused_spin
8771     & +int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
8772ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
8773ckbn     &1b-1)+int_mb(k_spin+h2b-1)) THEN
8774      IF (int_mb(k_spin+p3b-1)+ ip_unused_spin .eq. int_mb(k_spin+h
8775     &1b-1)+int_mb(k_spin+h2b-1)) THEN
8776ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
8777ckbn     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x
8778ckbn     &,irrep_t))) THEN
8779      IF (ieor(int_mb(k_sym+p3b-1),ieor(ip_unused_sym ,ieor(int_mb(
8780     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_x
8781     &,irrep_t))) THEN
8782ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
8783ckbn     &nge+h1b-1) * int_mb(k_range+h2b-1)
8784      dimc = int_mb(k_range+p3b-1) * 1 * int_mb(k_ra
8785     &nge+h1b-1) * int_mb(k_range+h2b-1)
8786      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
8787     & ERRQUIT('ipccsd_x2_8',0,MA_ERR)
8788      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
8789      DO p5b = noab+1,noab+nvab
8790      DO h6b = 1,noab
8791      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
8792     &1b-1)+int_mb(k_spin+h6b-1)) THEN
8793      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
8794     &k_sym+h1b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_t) THEN
8795      CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h6b,p3b_1,p5b_1,h1b_1,h6b_1)
8796      CALL TCE_RESTRICTED_4(p4b,h6b,h2b,p5b,p4b_2,h6b_2,h2b_2,p5b_2)
8797      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1)
8798      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
8799      dima = dim_common * dima_sort
8800ckbn      dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h2b-1)
8801      dimb_sort = 1 * int_mb(k_range+h2b-1)
8802      dimb = dim_common * dimb_sort
8803      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
8804      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
8805     & ERRQUIT('ipccsd_x2_8',1,MA_ERR)
8806      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
8807     &ipccsd_x2_8',2,MA_ERR)
8808      IF ((p5b .lt. p3b) .and. (h6b .lt. h1b)) THEN
8809      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
8810     & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
8811     &1 - noab - 1)))))
8812      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
8813     &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1)
8814     &,4,2,3,1,1.0d0)
8815      END IF
8816      IF ((p5b .lt. p3b) .and. (h1b .le. h6b)) THEN
8817      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
8818     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
8819     &1 - noab - 1)))))
8820      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
8821     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1)
8822     &,3,2,4,1,-1.0d0)
8823      END IF
8824      IF ((p3b .le. p5b) .and. (h6b .lt. h1b)) THEN
8825      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
8826     & - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
8827     &1 - noab - 1)))))
8828      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
8829     &,int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1)
8830     &,4,1,3,2,-1.0d0)
8831      END IF
8832      IF ((p3b .le. p5b) .and. (h1b .le. h6b)) THEN
8833      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
8834     & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
8835     &1 - noab - 1)))))
8836      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
8837     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1)
8838     &,3,1,4,2,1.0d0)
8839      END IF
8840      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_8',3,MA_ERR)
8841      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
8842     & ERRQUIT('ipccsd_x2_8',4,MA_ERR)
8843      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
8844     &ipccsd_x2_8',5,MA_ERR)
8845      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
8846     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h6b_2 - 1 + noab * (p4b_
8847     &2 - noab - 1)))))
8848ckbn      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
8849ckbn     &,int_mb(k_range+h6b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1)
8850ckbn     &,3,1,2,4,1.0d0)
8851      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),1
8852     &,int_mb(k_range+h6b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1)
8853     &,3,1,2,4,1.0d0)
8854      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_8',6,MA_ERR)
8855      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
8856     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
8857     &t),dima_sort)
8858      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_8',7,MA_E
8859     &RR)
8860      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_8',8,MA_E
8861     &RR)
8862      END IF
8863      END IF
8864      END IF
8865      END DO
8866      END DO
8867      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
8868     &ipccsd_x2_8',9,MA_ERR)
8869ckbn      IF ((p3b .le. p4b) .and. (h1b .le. h2b)) THEN
8870      IF ( (h1b .le. h2b)) THEN
8871ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
8872ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
8873ckbn     &,4,2,3,1,1.0d0)
8874      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
8875     &,1,int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
8876     &,4,2,3,1,1.0d0)
8877      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
8878     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
8879     & - 1)))))
8880      END IF
8881ckbn      IF ((p3b .le. p4b) .and. (h2b .le. h1b)) THEN
8882      IF ( (h2b .le. h1b)) THEN
8883ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
8884ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
8885ckbn     &,4,2,1,3,-1.0d0)
8886      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
8887     &,1,int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
8888     &,4,2,1,3,-1.0d0)
8889      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
8890     & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
8891     & - 1)))))
8892      END IF
8893ckbn      IF ((p4b .le. p3b) .and. (h1b .le. h2b)) THEN
8894ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
8895ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
8896ckbn     &,2,4,3,1,-1.0d0)
8897ckbn      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
8898ckbn     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
8899ckbn     & - 1)))))
8900ckbn      END IF
8901ckbn      IF ((p4b .le. p3b) .and. (h2b .le. h1b)) THEN
8902ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
8903ckbn     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
8904ckbn     &,2,4,1,3,1.0d0)
8905ckbn      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
8906ckbn     & 1 + noab * (h2b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
8907ckbn     & - 1)))))
8908ckbn      END IF
8909      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_8',10,MA_ERR)
8910      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_8',11,MA_
8911     &ERR)
8912      END IF
8913      END IF
8914      END IF
8915      next = NXTASK(nprocs, 1)
8916      END IF
8917      count = count + 1
8918      END DO
8919      END DO
8920      END DO
8921      END DO
8922      next = NXTASK(-nprocs, 1)
8923      call GA_SYNC()
8924      RETURN
8925      END
8926      SUBROUTINE ipccsd_x2_8_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
8927     &set)
8928C     $Id$
8929C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
8930C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
8931C     i1 ( h6 p3 h1 p5 )_vx + = 1 * Sum ( h7 p8 ) * x ( p3 p8 h1 h7 )_x * v ( h6 h7 p5 p8 )_v
8932      IMPLICIT NONE
8933#include "global.fh"
8934#include "mafdecls.fh"
8935#include "sym.fh"
8936#include "errquit.fh"
8937#include "tce.fh"
8938#include "stdio.fh"
8939      INTEGER d_a
8940      INTEGER k_a_offset
8941      INTEGER d_b
8942      INTEGER k_b_offset
8943      INTEGER d_c
8944      INTEGER k_c_offset
8945      INTEGER NXTASK
8946      INTEGER next
8947      INTEGER nprocs
8948      INTEGER count
8949      INTEGER p3b
8950      INTEGER h6b
8951      INTEGER h1b
8952      INTEGER p5b
8953      INTEGER dimc
8954      INTEGER l_c_sort
8955      INTEGER k_c_sort
8956      INTEGER p8b
8957      INTEGER h7b
8958      INTEGER p3b_1
8959      INTEGER p8b_1
8960      INTEGER h1b_1
8961      INTEGER h7b_1
8962      INTEGER h6b_2
8963      INTEGER h7b_2
8964      INTEGER p5b_2
8965      INTEGER p8b_2
8966      INTEGER dim_common
8967      INTEGER dima_sort
8968      INTEGER dima
8969      INTEGER dimb_sort
8970      INTEGER dimb
8971      INTEGER l_a_sort
8972      INTEGER k_a_sort
8973      INTEGER l_a
8974      INTEGER k_a
8975      INTEGER l_b_sort
8976      INTEGER k_b_sort
8977      INTEGER l_b
8978      INTEGER k_b
8979      INTEGER l_c
8980      INTEGER k_c
8981      EXTERNAL NXTASK
8982      nprocs = GA_NNODES()
8983      count = 0
8984      next = NXTASK(nprocs, 1)
8985ckbn      DO p3b = noab+1,noab+nvab
8986      DO p3b = 1,1
8987      DO h6b = 1,noab
8988      DO h1b = 1,noab
8989      DO p5b = noab+1,noab+nvab
8990      IF (next.eq.count) THEN
8991ckbn      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1
8992ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
8993      IF ((.not.restricted).or.(ip_unused_spin +int_mb(k_spin+h6b-1
8994     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
8995ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h
8996ckbn     &1b-1)+int_mb(k_spin+p5b-1)) THEN
8997      IF (ip_unused_spin +int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h
8998     &1b-1)+int_mb(k_spin+p5b-1)) THEN
8999ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb(
9000ckbn     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
9001ckbn     &EN
9002      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+h6b-1),ieor(int_mb(
9003     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
9004     &EN
9005ckbn      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra
9006ckbn     &nge+h1b-1) * int_mb(k_range+p5b-1)
9007      dimc = 1 * int_mb(k_range+h6b-1) * int_mb(k_ra
9008     &nge+h1b-1) * int_mb(k_range+p5b-1)
9009      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
9010     & ERRQUIT('ipccsd_x2_8_1',0,MA_ERR)
9011      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
9012      DO p8b = noab+1,noab+nvab
9013      DO h7b = 1,noab
9014ckbn      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
9015ckbn     &1b-1)+int_mb(k_spin+h7b-1)) THEN
9016      IF (ip_unused_spin +int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
9017     &1b-1)+int_mb(k_spin+h7b-1)) THEN
9018ckbn      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
9019ckbn     &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN
9020      IF (ieor(ip_unused_sym ,ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
9021     &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_x) THEN
9022      CALL TCE_RESTRICTED_4(p3b,p8b,h1b,h7b,p3b_1,p8b_1,h1b_1,h7b_1)
9023      CALL TCE_RESTRICTED_4(h6b,h7b,p5b,p8b,h6b_2,h7b_2,p5b_2,p8b_2)
9024      dim_common = int_mb(k_range+p8b-1) * int_mb(k_range+h7b-1)
9025ckbn      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
9026      dima_sort = 1 * int_mb(k_range+h1b-1)
9027      dima = dim_common * dima_sort
9028      dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1)
9029      dimb = dim_common * dimb_sort
9030      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
9031      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
9032     & ERRQUIT('ipccsd_x2_8_1',1,MA_ERR)
9033      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
9034     &ipccsd_x2_8_1',2,MA_ERR)
9035c      write(LuOut,*) "I am here 1."
9036c      call util_flush(LuOut)
9037ckbn      IF ((p8b .lt. p3b) .and. (h7b .lt. h1b)) THEN
9038      IF ((h7b .lt. h1b)) THEN
9039      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
9040     & - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_
9041     &1 - noab - 1)))))
9042ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
9043ckbn     &,int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1)
9044ckbn     &,4,2,3,1,1.0d0)
9045      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
9046     &,1,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1)
9047     &,4,2,3,1,1.0d0)
9048      END IF
9049      IF ((h1b .le. h7b)) THEN
9050      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
9051     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p8b_
9052     &1 - noab - 1)))))
9053ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
9054ckbn     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1)
9055ckbn     &,3,2,4,1,-1.0d0)
9056      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
9057     &,1,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1)
9058     &,3,2,4,1,-1.0d0)
9059      END IF
9060c      write(LuOut,*) "I am here 2."
9061c      call util_flush(LuOut)
9062ckbn      IF ((p3b .le. p8b) .and. (h7b .lt. h1b)) THEN
9063ckbn      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
9064ckbn     & - 1 + noab * (h7b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_
9065ckbn     &1 - noab - 1)))))
9066ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
9067ckbn     &,int_mb(k_range+p8b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1)
9068ckbn     &,4,1,3,2,-1.0d0)
9069ckbn      END IF
9070ckbn      IF ((p3b .le. p8b) .and. (h1b .le. h7b)) THEN
9071ckbn      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
9072ckbn     & - 1 + noab * (h1b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p3b_
9073ckbn     &1 - noab - 1)))))
9074ckbn      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
9075ckbn     &,int_mb(k_range+p8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1)
9076ckbn     &,3,1,4,2,1.0d0)
9077ckbn      END IF
9078      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ipccsd_x2_8_1',3,MA_ERR)
9079      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
9080     & ERRQUIT('ipccsd_x2_8_1',4,MA_ERR)
9081      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
9082     &ipccsd_x2_8_1',5,MA_ERR)
9083      IF ((h7b .lt. h6b) .and. (p8b .lt. p5b)) THEN
9084c      write(LuOut,*) "I am here 3."
9085c      call util_flush(LuOut)
9086      if(.not.intorb) then
9087      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
9088     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
9089     &+nvab) * (h7b_2 - 1)))))
9090      else
9091      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
9092     &(p5b_2
9093     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
9094     &+nvab) * (h7b_2 - 1)))),p5b_2,p8b_2,h6b_2,h7b_2)
9095      end if
9096      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
9097     &,int_mb(k_range+h6b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1)
9098     &,4,2,1,3,1.0d0)
9099      END IF
9100      IF ((h7b .lt. h6b) .and. (p5b .le. p8b)) THEN
9101c      write(LuOut,*) "I am here 3.1"
9102c      call util_flush(LuOut)
9103      if(.not.intorb) then
9104      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
9105     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
9106     &+nvab) * (h7b_2 - 1)))))
9107      else
9108      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
9109     &(p8b_2
9110     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
9111     &+nvab) * (h7b_2 - 1)))),p8b_2,p5b_2,h6b_2,h7b_2)
9112      end if
9113      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
9114     &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1)
9115     &,3,2,1,4,-1.0d0)
9116      END IF
9117      IF ((h6b .le. h7b) .and. (p8b .lt. p5b)) THEN
9118c      write(LuOut,*) "I am here 3.2"
9119c      call util_flush(LuOut)
9120      if(.not.intorb) then
9121      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
9122     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
9123     &+nvab) * (h6b_2 - 1)))))
9124      else
9125      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
9126     &(p5b_2
9127     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
9128     &+nvab) * (h6b_2 - 1)))),p5b_2,p8b_2,h7b_2,h6b_2)
9129      end if
9130      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
9131     &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p5b-1)
9132     &,4,1,2,3,-1.0d0)
9133      END IF
9134      IF ((h6b .le. h7b) .and. (p5b .le. p8b)) THEN
9135      if(.not.intorb) then
9136      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
9137     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
9138     &+nvab) * (h6b_2 - 1)))))
9139      else
9140      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
9141     &(p8b_2
9142     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
9143     &+nvab) * (h6b_2 - 1)))),p8b_2,p5b_2,h7b_2,h6b_2)
9144      end if
9145      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
9146     &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p8b-1)
9147     &,3,1,2,4,1.0d0)
9148      END IF
9149      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ipccsd_x2_8_1',6,MA_ERR)
9150      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
9151     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
9152     &t),dima_sort)
9153      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ipccsd_x2_8_1',7,MA
9154     &_ERR)
9155      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ipccsd_x2_8_1',8,MA
9156     &_ERR)
9157      END IF
9158      END IF
9159      END IF
9160      END DO
9161      END DO
9162      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
9163     &ipccsd_x2_8_1',9,MA_ERR)
9164ckbn      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
9165ckbn     &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
9166ckbn     &,4,2,3,1,1.0d0)
9167c      write(LuOut,*) "I am here 3.3"
9168c      call util_flush(LuOut)
9169      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
9170     &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),1
9171     &,4,2,3,1,1.0d0)
9172c      write(LuOut,*) "I am here 3.4"
9173c      call util_flush(LuOut)
9174      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
9175     & noab - 1 + nvab * (h1b - 1 + noab * (h6b - 1 + noab * (p3b - noab
9176     & - 1)))))
9177c      write(LuOut,*) "I am here 4."
9178c      call util_flush(LuOut)
9179      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ipccsd_x2_8_1',10,MA_ERR
9180     &)
9181      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ipccsd_x2_8_1',11,M
9182     &A_ERR)
9183      END IF
9184      END IF
9185      END IF
9186      next = NXTASK(nprocs, 1)
9187      END IF
9188      count = count + 1
9189      END DO
9190      END DO
9191      END DO
9192      END DO
9193      next = NXTASK(-nprocs, 1)
9194      call GA_SYNC()
9195      RETURN
9196      END
9197ckbn      SUBROUTINE OFFSET_ipccsd_x2_8_1(l_a_offset,k_a_offset,size)
9198ckbnC     $Id$
9199ckbnC     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
9200ckbnC     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
9201ckbnC     i1 ( h6 p3 h1 p5 )_vx
9202ckbn      IMPLICIT NONE
9203ckbn#include "global.fh"
9204ckbn#include "mafdecls.fh"
9205ckbn#include "sym.fh"
9206ckbn#include "errquit.fh"
9207ckbn#include "tce.fh"
9208ckbn      INTEGER l_a_offset
9209ckbn      INTEGER k_a_offset
9210ckbn      INTEGER size
9211ckbn      INTEGER length
9212ckbn      INTEGER addr
9213ckbn      INTEGER p3b
9214ckbn      INTEGER h6b
9215ckbn      INTEGER h1b
9216ckbn      INTEGER p5b
9217ckbn      length = 0
9218ckbn      DO p3b = noab+1,noab+nvab
9219ckbn      DO h6b = 1,noab
9220ckbn      DO h1b = 1,noab
9221ckbnckbn      DO p5b = noab+1,noab+nvab
9222ckbn      DO p5b = 1,1
9223ckbnckbn      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
9224ckbnckbn     &1b-1)+int_mb(k_spin+p5b-1)) THEN
9225ckbn      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
9226ckbn     &1b-1)+ip_unused_spin ) THEN
9227ckbnckbn      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
9228ckbnckbn     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
9229ckbnckbn     &EN
9230ckbn      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
9231ckbn     &k_sym+h1b-1),ip_unused_sym))) .eq. ieor(irrep_v,irrep_x)) TH
9232ckbn     &EN
9233ckbnckbn      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1
9234ckbnckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
9235ckbn      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1
9236ckbn     &)+int_mb(k_spin+h1b-1)+ip_unused_spin .ne.8)) THEN
9237ckbn      length = length + 1
9238ckbn      END IF
9239ckbn      END IF
9240ckbn      END IF
9241ckbn      END DO
9242ckbn      END DO
9243ckbn      END DO
9244ckbn      END DO
9245ckbn      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
9246ckbn     &set)) CALL ERRQUIT('ipccsd_x2_8_1',0,MA_ERR)
9247ckbn      int_mb(k_a_offset) = length
9248ckbn      addr = 0
9249ckbn      size = 0
9250ckbn      DO p3b = noab+1,noab+nvab
9251ckbn      DO h6b = 1,noab
9252ckbn      DO h1b = 1,noab
9253ckbnckbn      DO p5b = noab+1,noab+nvab
9254ckbn      DO p5b = 1,1
9255ckbnckbn      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
9256ckbnckbn     &1b-1)+int_mb(k_spin+p5b-1)) THEN
9257ckbn      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
9258ckbn     &1b-1)+ip_unused_spin) THEN
9259ckbnckbn      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
9260ckbnckbn     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
9261ckbnckbn     &EN
9262ckbn      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
9263ckbn     &k_sym+h1b-1),ip_unused_sym))) .eq. ieor(irrep_v,irrep_x)) TH
9264ckbn     &EN
9265ckbnckbn      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1
9266ckbnckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
9267ckbn      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1
9268ckbn     &)+int_mb(k_spin+h1b-1)+ip_unused_spin .ne.8)) THEN
9269ckbn      addr = addr + 1
9270ckbn      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab
9271ckbn     &* (h6b - 1 + noab * (p3b - noab - 1)))
9272ckbn      int_mb(k_a_offset+length+addr) = size
9273ckbnckbn      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_
9274ckbnckbn     &mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
9275ckbn      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_
9276ckbn     &mb(k_range+h1b-1) * 1
9277ckbn      END IF
9278ckbn      END IF
9279ckbn      END IF
9280ckbn      END DO
9281ckbn      END DO
9282ckbn      END DO
9283ckbn      END DO
9284ckbn      RETURN
9285ckbn      END
9286      SUBROUTINE OFFSET_ipccsd_x2_8_1(l_a_offset,k_a_offset,size)
9287C     $Id$
9288C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
9289C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
9290C     i1 ( h6 p3 h1 p5 )_vx
9291      IMPLICIT NONE
9292#include "global.fh"
9293#include "mafdecls.fh"
9294#include "sym.fh"
9295#include "errquit.fh"
9296#include "tce.fh"
9297      INTEGER l_a_offset
9298      INTEGER k_a_offset
9299      INTEGER size
9300      INTEGER length
9301      INTEGER addr
9302      INTEGER p3b
9303      INTEGER h6b
9304      INTEGER h1b
9305      INTEGER p5b
9306      length = 0
9307ckbn      DO p3b = noab+1,noab+nvab
9308      DO p3b = 1,1
9309      DO h6b = 1,noab
9310      DO h1b = 1,noab
9311      DO p5b = noab+1,noab+nvab
9312ckbn      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
9313ckbn     &1b-1)+int_mb(k_spin+p5b-1)) THEN
9314      IF (int_mb(k_spin+h6b-1)+ip_unused_spin .eq. int_mb(k_spin+h
9315     &1b-1)+int_mb(k_spin+p5b-1)) THEN
9316ckbn      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
9317ckbn     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
9318ckbn     &EN
9319      IF (ieor(int_mb(k_sym+h6b-1),ieor(ip_unused_sym ,ieor(int_mb(
9320     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
9321     &EN
9322ckbn      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1
9323ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
9324      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+ ip_unused_spin
9325     & +int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
9326      length = length + 1
9327      END IF
9328      END IF
9329      END IF
9330      END DO
9331      END DO
9332      END DO
9333      END DO
9334      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
9335     &set)) CALL ERRQUIT('ipccsd_x2_8_1',0,MA_ERR)
9336      int_mb(k_a_offset) = length
9337      addr = 0
9338      size = 0
9339ckbn      DO p3b = noab+1,noab+nvab
9340      DO p3b = 1,1
9341      DO h6b = 1,noab
9342      DO h1b = 1,noab
9343      DO p5b = noab+1,noab+nvab
9344ckbn      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
9345ckbn     &1b-1)+int_mb(k_spin+p5b-1)) THEN
9346      IF (int_mb(k_spin+h6b-1)+ip_unused_spin  .eq. int_mb(k_spin+h
9347     &1b-1)+int_mb(k_spin+p5b-1)) THEN
9348ckbn      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
9349ckbn     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
9350ckbn     &EN
9351      IF (ieor(int_mb(k_sym+h6b-1),ieor(ip_unused_sym ,ieor(int_mb(
9352     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
9353     &EN
9354ckbn      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1
9355ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
9356      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+ ip_unused_spin
9357     & +int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
9358      addr = addr + 1
9359      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab
9360     &* (h6b - 1 + noab * (p3b - noab - 1)))
9361      int_mb(k_a_offset+length+addr) = size
9362ckbn      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_
9363ckbn     &mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
9364      size = size + 1 * int_mb(k_range+h6b-1) * int_
9365     &mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
9366      END IF
9367      END IF
9368      END IF
9369      END DO
9370      END DO
9371      END DO
9372      END DO
9373      RETURN
9374      END
9375ckbn      SUBROUTINE OFFSET_ipccsd_x2_8_1(l_a_offset,k_a_offset,size)
9376ckbnC     $Id$
9377ckbnC     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
9378ckbnC     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
9379ckbnC     i1 ( h6 p3 h1 p5 )_vx
9380ckbn      IMPLICIT NONE
9381ckbn#include "global.fh"
9382ckbn#include "mafdecls.fh"
9383ckbn#include "sym.fh"
9384ckbn#include "errquit.fh"
9385ckbn#include "tce.fh"
9386ckbn      INTEGER l_a_offset
9387ckbn      INTEGER k_a_offset
9388ckbn      INTEGER size
9389ckbn      INTEGER length
9390ckbn      INTEGER addr
9391ckbn      INTEGER p3b
9392ckbn      INTEGER h6b
9393ckbn      INTEGER h1b
9394ckbn      INTEGER p5b
9395ckbn      length = 0
9396ckbn      DO p3b = noab+1,noab+nvab
9397ckbn      DO h6b = 1,noab
9398ckbn      DO h1b = 1,noab
9399ckbn      DO p5b = noab+1,noab+nvab
9400ckbn      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
9401ckbn     &1b-1)+int_mb(k_spin+p5b-1)) THEN
9402ckbn      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
9403ckbn     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
9404ckbn     &EN
9405ckbn      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1
9406ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
9407ckbn      length = length + 1
9408ckbn      END IF
9409ckbn      END IF
9410ckbn      END IF
9411ckbn      END DO
9412ckbn      END DO
9413ckbn      END DO
9414ckbn      END DO
9415ckbn      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
9416ckbn     &set)) CALL ERRQUIT('ipccsd_x2_8_1',0,MA_ERR)
9417ckbn      int_mb(k_a_offset) = length
9418ckbn      addr = 0
9419ckbn      size = 0
9420ckbn      DO p3b = noab+1,noab+nvab
9421ckbn      DO h6b = 1,noab
9422ckbn      DO h1b = 1,noab
9423ckbn      DO p5b = noab+1,noab+nvab
9424ckbn      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
9425ckbn     &1b-1)+int_mb(k_spin+p5b-1)) THEN
9426ckbn      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
9427ckbn     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_x)) TH
9428ckbn     &EN
9429ckbn      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1
9430ckbn     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
9431ckbn      addr = addr + 1
9432ckbn      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab
9433ckbn     &* (h6b - 1 + noab * (p3b - noab - 1)))
9434ckbn      int_mb(k_a_offset+length+addr) = size
9435ckbn      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_
9436ckbn     &mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
9437ckbn      END IF
9438ckbn      END IF
9439ckbn      END IF
9440ckbn      END DO
9441ckbn      END DO
9442ckbn      END DO
9443ckbn      END DO
9444ckbn      RETURN
9445ckbn      END
9446