1      SUBROUTINE ccsdtq_o1(d_i0,d_o1,d_t1,d_t2,k_i0_offset,k_o1_offset,k
2     &_t1_offset,k_t2_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 )_o + = 1 * o ( p2 h1 )_o
7C     i0 ( p2 h1 )_to + = -1 * Sum ( h5 ) * t ( p2 h5 )_t * i1 ( h5 h1 )_o
8C         i1 ( h5 h1 )_o + = 1 * o ( h5 h1 )_o
9C         i1 ( h5 h1 )_ot + = 1 * Sum ( p3 ) * o ( h5 p3 )_o * t ( p3 h1 )_t
10C     i0 ( p2 h1 )_to + = 1 * Sum ( p3 ) * o ( p2 p3 )_o * t ( p3 h1 )_t
11C     i0 ( p2 h1 )_to + = 1 * Sum ( p4 h3 ) * o ( h3 p4 )_o * t ( p2 p4 h1 h3 )_t
12      IMPLICIT NONE
13#include "global.fh"
14#include "mafdecls.fh"
15#include "util.fh"
16#include "errquit.fh"
17#include "tce.fh"
18      INTEGER d_i0
19      INTEGER k_i0_offset
20      INTEGER d_o1
21      INTEGER k_o1_offset
22      INTEGER d_t1
23      INTEGER k_t1_offset
24      INTEGER d_i1
25      INTEGER k_i1_offset
26      INTEGER d_t2
27      INTEGER k_t2_offset
28      INTEGER l_i1_offset
29      INTEGER size_i1
30      CHARACTER*255 filename
31      CALL ccsdtq_o1_1(d_o1,k_o1_offset,d_i0,k_i0_offset)
32      CALL OFFSET_ccsdtq_o1_2_1(l_i1_offset,k_i1_offset,size_i1)
33      CALL TCE_FILENAME('ccsdtq_o1_2_1_i1',filename)
34      CALL CREATEFILE(filename,d_i1,size_i1)
35      CALL ccsdtq_o1_2_1(d_o1,k_o1_offset,d_i1,k_i1_offset)
36      CALL ccsdtq_o1_2_2(d_o1,k_o1_offset,d_t1,k_t1_offset,d_i1,k_i1_off
37     &set)
38      CALL RECONCILEFILE(d_i1,size_i1)
39      CALL ccsdtq_o1_2(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offse
40     &t)
41      CALL DELETEFILE(d_i1)
42      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsdtq_o1',-1,MA
43     &_ERR)
44      CALL ccsdtq_o1_3(d_o1,k_o1_offset,d_t1,k_t1_offset,d_i0,k_i0_offse
45     &t)
46      CALL ccsdtq_o1_4(d_o1,k_o1_offset,d_t2,k_t2_offset,d_i0,k_i0_offse
47     &t)
48      RETURN
49      END
50      SUBROUTINE ccsdtq_o1_1(d_a,k_a_offset,d_c,k_c_offset)
51C     $Id$
52C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
53C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
54C     i0 ( p2 h1 )_o + = 1 * o ( p2 h1 )_o
55      IMPLICIT NONE
56#include "global.fh"
57#include "mafdecls.fh"
58#include "sym.fh"
59#include "errquit.fh"
60#include "tce.fh"
61      INTEGER d_a
62      INTEGER k_a_offset
63      INTEGER d_c
64      INTEGER k_c_offset
65      INTEGER NXTASK
66      INTEGER next
67      INTEGER nprocs
68      INTEGER count
69      INTEGER p2b
70      INTEGER h1b
71      INTEGER dimc
72      INTEGER p2b_1
73      INTEGER h1b_1
74      INTEGER dim_common
75      INTEGER dima_sort
76      INTEGER dima
77      INTEGER l_a_sort
78      INTEGER k_a_sort
79      INTEGER l_a
80      INTEGER k_a
81      INTEGER l_c
82      INTEGER k_c
83      EXTERNAL NXTASK
84      nprocs = GA_NNODES()
85      count = 0
86      next = NXTASK(nprocs,1)
87      DO p2b = noab+1,noab+nvab
88      DO h1b = 1,noab
89      IF (next.eq.count) THEN
90      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
91     &).ne.4)) THEN
92      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
93      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. irrep_o) TH
94     &EN
95      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
96      CALL TCE_RESTRICTED_2(p2b,h1b,p2b_1,h1b_1)
97      dim_common = 1
98      dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
99      dima = dim_common * dima_sort
100      IF (dima .gt. 0) THEN
101      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
102     & ERRQUIT('ccsdtq_o1_1',0,MA_ERR)
103      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
104     &ccsdtq_o1_1',1,MA_ERR)
105      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
106     & - 1 + (noab+nvab) * (p2b_1 - 1)))
107      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
108     &,int_mb(k_range+h1b-1),2,1,1.0d0)
109      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o1_1',2,MA_ERR)
110      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
111     &ccsdtq_o1_1',3,MA_ERR)
112      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
113     &,int_mb(k_range+p2b-1),2,1,1.0d0)
114      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
115     & 1 + noab * (p2b - noab - 1)))
116      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o1_1',4,MA_ERR)
117      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o1_1',5,MA_E
118     &RR)
119      END IF
120      END IF
121      END IF
122      END IF
123      next = NXTASK(nprocs,1)
124      END IF
125      count = count + 1
126      END DO
127      END DO
128      next = NXTASK(-nprocs,1)
129      call GA_SYNC()
130      RETURN
131      END
132      SUBROUTINE ccsdtq_o1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
133     &t)
134C     $Id$
135C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
136C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
137C     i0 ( p2 h1 )_to + = -1 * Sum ( h5 ) * t ( p2 h5 )_t * i1 ( h5 h1 )_o
138      IMPLICIT NONE
139#include "global.fh"
140#include "mafdecls.fh"
141#include "sym.fh"
142#include "errquit.fh"
143#include "tce.fh"
144      INTEGER d_a
145      INTEGER k_a_offset
146      INTEGER d_b
147      INTEGER k_b_offset
148      INTEGER d_c
149      INTEGER k_c_offset
150      INTEGER NXTASK
151      INTEGER next
152      INTEGER nprocs
153      INTEGER count
154      INTEGER p2b
155      INTEGER h1b
156      INTEGER dimc
157      INTEGER l_c_sort
158      INTEGER k_c_sort
159      INTEGER h5b
160      INTEGER p2b_1
161      INTEGER h5b_1
162      INTEGER h5b_2
163      INTEGER h1b_2
164      INTEGER dim_common
165      INTEGER dima_sort
166      INTEGER dima
167      INTEGER dimb_sort
168      INTEGER dimb
169      INTEGER l_a_sort
170      INTEGER k_a_sort
171      INTEGER l_a
172      INTEGER k_a
173      INTEGER l_b_sort
174      INTEGER k_b_sort
175      INTEGER l_b
176      INTEGER k_b
177      INTEGER l_c
178      INTEGER k_c
179      EXTERNAL NXTASK
180      nprocs = GA_NNODES()
181      count = 0
182      next = NXTASK(nprocs,1)
183      DO p2b = noab+1,noab+nvab
184      DO h1b = 1,noab
185      IF (next.eq.count) THEN
186      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
187     &).ne.4)) THEN
188      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
189      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
190     &t,irrep_o)) THEN
191      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
192      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
193     & ERRQUIT('ccsdtq_o1_2',0,MA_ERR)
194      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
195      DO h5b = 1,noab
196      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h5b-1)) THEN
197      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h5b-1)) .eq. irrep_t) TH
198     &EN
199      CALL TCE_RESTRICTED_2(p2b,h5b,p2b_1,h5b_1)
200      CALL TCE_RESTRICTED_2(h5b,h1b,h5b_2,h1b_2)
201      dim_common = int_mb(k_range+h5b-1)
202      dima_sort = int_mb(k_range+p2b-1)
203      dima = dim_common * dima_sort
204      dimb_sort = int_mb(k_range+h1b-1)
205      dimb = dim_common * dimb_sort
206      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
207      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
208     & ERRQUIT('ccsdtq_o1_2',1,MA_ERR)
209      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
210     &ccsdtq_o1_2',2,MA_ERR)
211      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1
212     & - 1 + noab * (p2b_1 - noab - 1)))
213      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
214     &,int_mb(k_range+h5b-1),1,2,1.0d0)
215      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o1_2',3,MA_ERR)
216      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
217     & ERRQUIT('ccsdtq_o1_2',4,MA_ERR)
218      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
219     &ccsdtq_o1_2',5,MA_ERR)
220      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2
221     & - 1 + noab * (h5b_2 - 1)))
222      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
223     &,int_mb(k_range+h1b-1),2,1,1.0d0)
224      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o1_2',6,MA_ERR)
225      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
226     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
227     &t),dima_sort)
228      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o1_2',7,MA_E
229     &RR)
230      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o1_2',8,MA_E
231     &RR)
232      END IF
233      END IF
234      END IF
235      END DO
236      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
237     &ccsdtq_o1_2',9,MA_ERR)
238      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
239     &,int_mb(k_range+p2b-1),2,1,-1.0d0)
240      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
241     & 1 + noab * (p2b - noab - 1)))
242      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o1_2',10,MA_ERR)
243      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o1_2',11,MA_
244     &ERR)
245      END IF
246      END IF
247      END IF
248      next = NXTASK(nprocs,1)
249      END IF
250      count = count + 1
251      END DO
252      END DO
253      next = NXTASK(-nprocs,1)
254      call GA_SYNC()
255      RETURN
256      END
257      SUBROUTINE ccsdtq_o1_2_1(d_a,k_a_offset,d_c,k_c_offset)
258C     $Id$
259C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
260C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
261C     i1 ( h5 h1 )_o + = 1 * o ( h5 h1 )_o
262      IMPLICIT NONE
263#include "global.fh"
264#include "mafdecls.fh"
265#include "sym.fh"
266#include "errquit.fh"
267#include "tce.fh"
268      INTEGER d_a
269      INTEGER k_a_offset
270      INTEGER d_c
271      INTEGER k_c_offset
272      INTEGER NXTASK
273      INTEGER next
274      INTEGER nprocs
275      INTEGER count
276      INTEGER h5b
277      INTEGER h1b
278      INTEGER dimc
279      INTEGER h5b_1
280      INTEGER h1b_1
281      INTEGER dim_common
282      INTEGER dima_sort
283      INTEGER dima
284      INTEGER l_a_sort
285      INTEGER k_a_sort
286      INTEGER l_a
287      INTEGER k_a
288      INTEGER l_c
289      INTEGER k_c
290      EXTERNAL NXTASK
291      nprocs = GA_NNODES()
292      count = 0
293      next = NXTASK(nprocs,1)
294      DO h5b = 1,noab
295      DO h1b = 1,noab
296      IF (next.eq.count) THEN
297      IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h1b-1
298     &).ne.4)) THEN
299      IF (int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
300      IF (ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_o) TH
301     &EN
302      dimc = int_mb(k_range+h5b-1) * int_mb(k_range+h1b-1)
303      CALL TCE_RESTRICTED_2(h5b,h1b,h5b_1,h1b_1)
304      dim_common = 1
305      dima_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h1b-1)
306      dima = dim_common * dima_sort
307      IF (dima .gt. 0) THEN
308      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
309     & ERRQUIT('ccsdtq_o1_2_1',0,MA_ERR)
310      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
311     &ccsdtq_o1_2_1',1,MA_ERR)
312      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
313     & - 1 + (noab+nvab) * (h5b_1 - 1)))
314      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1)
315     &,int_mb(k_range+h1b-1),2,1,1.0d0)
316      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o1_2_1',2,MA_ERR)
317      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
318     &ccsdtq_o1_2_1',3,MA_ERR)
319      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
320     &,int_mb(k_range+h5b-1),2,1,1.0d0)
321      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
322     & 1 + noab * (h5b - 1)))
323      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o1_2_1',4,MA_ERR)
324      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o1_2_1',5,MA
325     &_ERR)
326      END IF
327      END IF
328      END IF
329      END IF
330      next = NXTASK(nprocs,1)
331      END IF
332      count = count + 1
333      END DO
334      END DO
335      next = NXTASK(-nprocs,1)
336      call GA_SYNC()
337      RETURN
338      END
339      SUBROUTINE OFFSET_ccsdtq_o1_2_1(l_a_offset,k_a_offset,size)
340C     $Id$
341C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
342C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
343C     i1 ( h5 h1 )_o
344      IMPLICIT NONE
345#include "global.fh"
346#include "mafdecls.fh"
347#include "sym.fh"
348#include "errquit.fh"
349#include "tce.fh"
350      INTEGER l_a_offset
351      INTEGER k_a_offset
352      INTEGER size
353      INTEGER length
354      INTEGER addr
355      INTEGER h5b
356      INTEGER h1b
357      length = 0
358      DO h5b = 1,noab
359      DO h1b = 1,noab
360      IF (int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
361      IF (ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_o) TH
362     &EN
363      IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h1b-1
364     &).ne.4)) THEN
365      length = length + 1
366      END IF
367      END IF
368      END IF
369      END DO
370      END DO
371      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
372     &set)) CALL ERRQUIT('ccsdtq_o1_2_1',0,MA_ERR)
373      int_mb(k_a_offset) = length
374      addr = 0
375      size = 0
376      DO h5b = 1,noab
377      DO h1b = 1,noab
378      IF (int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
379      IF (ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_o) TH
380     &EN
381      IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h1b-1
382     &).ne.4)) THEN
383      addr = addr + 1
384      int_mb(k_a_offset+addr) = h1b - 1 + noab * (h5b - 1)
385      int_mb(k_a_offset+length+addr) = size
386      size = size + int_mb(k_range+h5b-1) * int_mb(k_range+h1b-1)
387      END IF
388      END IF
389      END IF
390      END DO
391      END DO
392      RETURN
393      END
394      SUBROUTINE ccsdtq_o1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
395     &set)
396C     $Id$
397C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
398C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
399C     i1 ( h5 h1 )_ot + = 1 * Sum ( p3 ) * o ( h5 p3 )_o * t ( p3 h1 )_t
400      IMPLICIT NONE
401#include "global.fh"
402#include "mafdecls.fh"
403#include "sym.fh"
404#include "errquit.fh"
405#include "tce.fh"
406      INTEGER d_a
407      INTEGER k_a_offset
408      INTEGER d_b
409      INTEGER k_b_offset
410      INTEGER d_c
411      INTEGER k_c_offset
412      INTEGER NXTASK
413      INTEGER next
414      INTEGER nprocs
415      INTEGER count
416      INTEGER h5b
417      INTEGER h1b
418      INTEGER dimc
419      INTEGER l_c_sort
420      INTEGER k_c_sort
421      INTEGER p3b
422      INTEGER h5b_1
423      INTEGER p3b_1
424      INTEGER p3b_2
425      INTEGER h1b_2
426      INTEGER dim_common
427      INTEGER dima_sort
428      INTEGER dima
429      INTEGER dimb_sort
430      INTEGER dimb
431      INTEGER l_a_sort
432      INTEGER k_a_sort
433      INTEGER l_a
434      INTEGER k_a
435      INTEGER l_b_sort
436      INTEGER k_b_sort
437      INTEGER l_b
438      INTEGER k_b
439      INTEGER l_c
440      INTEGER k_c
441      EXTERNAL NXTASK
442      nprocs = GA_NNODES()
443      count = 0
444      next = NXTASK(nprocs,1)
445      DO h5b = 1,noab
446      DO h1b = 1,noab
447      IF (next.eq.count) THEN
448      IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h1b-1
449     &).ne.4)) THEN
450      IF (int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
451      IF (ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
452     &o,irrep_t)) THEN
453      dimc = int_mb(k_range+h5b-1) * int_mb(k_range+h1b-1)
454      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
455     & ERRQUIT('ccsdtq_o1_2_2',0,MA_ERR)
456      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
457      DO p3b = noab+1,noab+nvab
458      IF (int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+p3b-1)) THEN
459      IF (ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+p3b-1)) .eq. irrep_o) TH
460     &EN
461      CALL TCE_RESTRICTED_2(h5b,p3b,h5b_1,p3b_1)
462      CALL TCE_RESTRICTED_2(p3b,h1b,p3b_2,h1b_2)
463      dim_common = int_mb(k_range+p3b-1)
464      dima_sort = int_mb(k_range+h5b-1)
465      dima = dim_common * dima_sort
466      dimb_sort = int_mb(k_range+h1b-1)
467      dimb = dim_common * dimb_sort
468      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
469      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
470     & ERRQUIT('ccsdtq_o1_2_2',1,MA_ERR)
471      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
472     &ccsdtq_o1_2_2',2,MA_ERR)
473      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p3b_1
474     & - 1 + (noab+nvab) * (h5b_1 - 1)))
475      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1)
476     &,int_mb(k_range+p3b-1),1,2,1.0d0)
477      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o1_2_2',3,MA_ERR)
478      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
479     & ERRQUIT('ccsdtq_o1_2_2',4,MA_ERR)
480      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
481     &ccsdtq_o1_2_2',5,MA_ERR)
482      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2
483     & - 1 + noab * (p3b_2 - noab - 1)))
484      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1)
485     &,int_mb(k_range+h1b-1),2,1,1.0d0)
486      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o1_2_2',6,MA_ERR)
487      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
488     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
489     &t),dima_sort)
490      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o1_2_2',7,MA
491     &_ERR)
492      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o1_2_2',8,MA
493     &_ERR)
494      END IF
495      END IF
496      END IF
497      END DO
498      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
499     &ccsdtq_o1_2_2',9,MA_ERR)
500      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
501     &,int_mb(k_range+h5b-1),2,1,1.0d0)
502      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
503     & 1 + noab * (h5b - 1)))
504      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o1_2_2',10,MA_ERR
505     &)
506      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o1_2_2',11,M
507     &A_ERR)
508      END IF
509      END IF
510      END IF
511      next = NXTASK(nprocs,1)
512      END IF
513      count = count + 1
514      END DO
515      END DO
516      next = NXTASK(-nprocs,1)
517      call GA_SYNC()
518      RETURN
519      END
520      SUBROUTINE ccsdtq_o1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
521     &t)
522C     $Id$
523C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
524C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
525C     i0 ( p2 h1 )_to + = 1 * Sum ( p3 ) * o ( p2 p3 )_o * t ( p3 h1 )_t
526      IMPLICIT NONE
527#include "global.fh"
528#include "mafdecls.fh"
529#include "sym.fh"
530#include "errquit.fh"
531#include "tce.fh"
532      INTEGER d_a
533      INTEGER k_a_offset
534      INTEGER d_b
535      INTEGER k_b_offset
536      INTEGER d_c
537      INTEGER k_c_offset
538      INTEGER NXTASK
539      INTEGER next
540      INTEGER nprocs
541      INTEGER count
542      INTEGER p2b
543      INTEGER h1b
544      INTEGER dimc
545      INTEGER l_c_sort
546      INTEGER k_c_sort
547      INTEGER p3b
548      INTEGER p2b_1
549      INTEGER p3b_1
550      INTEGER p3b_2
551      INTEGER h1b_2
552      INTEGER dim_common
553      INTEGER dima_sort
554      INTEGER dima
555      INTEGER dimb_sort
556      INTEGER dimb
557      INTEGER l_a_sort
558      INTEGER k_a_sort
559      INTEGER l_a
560      INTEGER k_a
561      INTEGER l_b_sort
562      INTEGER k_b_sort
563      INTEGER l_b
564      INTEGER k_b
565      INTEGER l_c
566      INTEGER k_c
567      EXTERNAL NXTASK
568      nprocs = GA_NNODES()
569      count = 0
570      next = NXTASK(nprocs,1)
571      DO p2b = noab+1,noab+nvab
572      DO h1b = 1,noab
573      IF (next.eq.count) THEN
574      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
575     &).ne.4)) THEN
576      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
577      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
578     &t,irrep_o)) THEN
579      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
580      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
581     & ERRQUIT('ccsdtq_o1_3',0,MA_ERR)
582      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
583      DO p3b = noab+1,noab+nvab
584      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN
585      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) .eq. irrep_o) TH
586     &EN
587      CALL TCE_RESTRICTED_2(p2b,p3b,p2b_1,p3b_1)
588      CALL TCE_RESTRICTED_2(p3b,h1b,p3b_2,h1b_2)
589      dim_common = int_mb(k_range+p3b-1)
590      dima_sort = int_mb(k_range+p2b-1)
591      dima = dim_common * dima_sort
592      dimb_sort = int_mb(k_range+h1b-1)
593      dimb = dim_common * dimb_sort
594      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
595      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
596     & ERRQUIT('ccsdtq_o1_3',1,MA_ERR)
597      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
598     &ccsdtq_o1_3',2,MA_ERR)
599      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p3b_1
600     & - 1 + (noab+nvab) * (p2b_1 - 1)))
601      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
602     &,int_mb(k_range+p3b-1),1,2,1.0d0)
603      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o1_3',3,MA_ERR)
604      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
605     & ERRQUIT('ccsdtq_o1_3',4,MA_ERR)
606      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
607     &ccsdtq_o1_3',5,MA_ERR)
608      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2
609     & - 1 + noab * (p3b_2 - noab - 1)))
610      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1)
611     &,int_mb(k_range+h1b-1),2,1,1.0d0)
612      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o1_3',6,MA_ERR)
613      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
614     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
615     &t),dima_sort)
616      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o1_3',7,MA_E
617     &RR)
618      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o1_3',8,MA_E
619     &RR)
620      END IF
621      END IF
622      END IF
623      END DO
624      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
625     &ccsdtq_o1_3',9,MA_ERR)
626      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
627     &,int_mb(k_range+p2b-1),2,1,1.0d0)
628      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
629     & 1 + noab * (p2b - noab - 1)))
630      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o1_3',10,MA_ERR)
631      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o1_3',11,MA_
632     &ERR)
633      END IF
634      END IF
635      END IF
636      next = NXTASK(nprocs,1)
637      END IF
638      count = count + 1
639      END DO
640      END DO
641      next = NXTASK(-nprocs,1)
642      call GA_SYNC()
643      RETURN
644      END
645      SUBROUTINE ccsdtq_o1_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
646     &t)
647C     $Id$
648C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
649C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
650C     i0 ( p2 h1 )_to + = 1 * Sum ( p4 h3 ) * o ( h3 p4 )_o * t ( p2 p4 h1 h3 )_t
651      IMPLICIT NONE
652#include "global.fh"
653#include "mafdecls.fh"
654#include "sym.fh"
655#include "errquit.fh"
656#include "tce.fh"
657      INTEGER d_a
658      INTEGER k_a_offset
659      INTEGER d_b
660      INTEGER k_b_offset
661      INTEGER d_c
662      INTEGER k_c_offset
663      INTEGER NXTASK
664      INTEGER next
665      INTEGER nprocs
666      INTEGER count
667      INTEGER p2b
668      INTEGER h1b
669      INTEGER dimc
670      INTEGER l_c_sort
671      INTEGER k_c_sort
672      INTEGER h3b
673      INTEGER p4b
674      INTEGER h3b_1
675      INTEGER p4b_1
676      INTEGER p2b_2
677      INTEGER p4b_2
678      INTEGER h1b_2
679      INTEGER h3b_2
680      INTEGER dim_common
681      INTEGER dima_sort
682      INTEGER dima
683      INTEGER dimb_sort
684      INTEGER dimb
685      INTEGER l_a_sort
686      INTEGER k_a_sort
687      INTEGER l_a
688      INTEGER k_a
689      INTEGER l_b_sort
690      INTEGER k_b_sort
691      INTEGER l_b
692      INTEGER k_b
693      INTEGER l_c
694      INTEGER k_c
695      EXTERNAL NXTASK
696      nprocs = GA_NNODES()
697      count = 0
698      next = NXTASK(nprocs,1)
699      DO p2b = noab+1,noab+nvab
700      DO h1b = 1,noab
701      IF (next.eq.count) THEN
702      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
703     &).ne.4)) THEN
704      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
705      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
706     &t,irrep_o)) THEN
707      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
708      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
709     & ERRQUIT('ccsdtq_o1_4',0,MA_ERR)
710      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
711      DO h3b = 1,noab
712      DO p4b = noab+1,noab+nvab
713      IF (int_mb(k_spin+h3b-1) .eq. int_mb(k_spin+p4b-1)) THEN
714      IF (ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+p4b-1)) .eq. irrep_o) TH
715     &EN
716      CALL TCE_RESTRICTED_2(h3b,p4b,h3b_1,p4b_1)
717      CALL TCE_RESTRICTED_4(p2b,p4b,h1b,h3b,p2b_2,p4b_2,h1b_2,h3b_2)
718      dim_common = int_mb(k_range+h3b-1) * int_mb(k_range+p4b-1)
719      dima_sort = 1
720      dima = dim_common * dima_sort
721      dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
722      dimb = dim_common * dimb_sort
723      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
724      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
725     & ERRQUIT('ccsdtq_o1_4',1,MA_ERR)
726      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
727     &ccsdtq_o1_4',2,MA_ERR)
728      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p4b_1
729     & - 1 + (noab+nvab) * (h3b_1 - 1)))
730      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1)
731     &,int_mb(k_range+p4b-1),2,1,1.0d0)
732      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_o1_4',3,MA_ERR)
733      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
734     & ERRQUIT('ccsdtq_o1_4',4,MA_ERR)
735      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
736     &ccsdtq_o1_4',5,MA_ERR)
737      IF ((p4b .lt. p2b) .and. (h3b .lt. h1b)) THEN
738      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2
739     & - 1 + noab * (h3b_2 - 1 + noab * (p2b_2 - noab - 1 + nvab * (p4b_
740     &2 - noab - 1)))))
741      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
742     &,int_mb(k_range+p2b-1),int_mb(k_range+h3b-1),int_mb(k_range+h1b-1)
743     &,4,2,1,3,1.0d0)
744      END IF
745      IF ((p4b .lt. p2b) .and. (h1b .le. h3b)) THEN
746      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2
747     & - 1 + noab * (h1b_2 - 1 + noab * (p2b_2 - noab - 1 + nvab * (p4b_
748     &2 - noab - 1)))))
749      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
750     &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+h3b-1)
751     &,3,2,1,4,-1.0d0)
752      END IF
753      IF ((p2b .le. p4b) .and. (h3b .lt. h1b)) THEN
754      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2
755     & - 1 + noab * (h3b_2 - 1 + noab * (p4b_2 - noab - 1 + nvab * (p2b_
756     &2 - noab - 1)))))
757      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1)
758     &,int_mb(k_range+p4b-1),int_mb(k_range+h3b-1),int_mb(k_range+h1b-1)
759     &,4,1,2,3,-1.0d0)
760      END IF
761      IF ((p2b .le. p4b) .and. (h1b .le. h3b)) THEN
762      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h3b_2
763     & - 1 + noab * (h1b_2 - 1 + noab * (p4b_2 - noab - 1 + nvab * (p2b_
764     &2 - noab - 1)))))
765      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1)
766     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h3b-1)
767     &,3,1,2,4,1.0d0)
768      END IF
769      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_o1_4',6,MA_ERR)
770      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
771     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
772     &t),dima_sort)
773      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_o1_4',7,MA_E
774     &RR)
775      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_o1_4',8,MA_E
776     &RR)
777      END IF
778      END IF
779      END IF
780      END DO
781      END DO
782      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
783     &ccsdtq_o1_4',9,MA_ERR)
784      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
785     &,int_mb(k_range+p2b-1),2,1,1.0d0)
786      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
787     & 1 + noab * (p2b - noab - 1)))
788      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_o1_4',10,MA_ERR)
789      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_o1_4',11,MA_
790     &ERR)
791      END IF
792      END IF
793      END IF
794      next = NXTASK(nprocs,1)
795      END IF
796      count = count + 1
797      END DO
798      END DO
799      next = NXTASK(-nprocs,1)
800      call GA_SYNC()
801      RETURN
802      END
803