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