1      SUBROUTINE nr0(d_f1,d_i0,d_t1,d_v2,d_x1,d_x2,k_f1_offset,k_i0_offs
2     &et,k_t1_offset,k_v2_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 ( )_xf + = 1 * Sum ( p2 h1 ) * x ( p2 h1 )_x * f ( h1 p2 )_f
7C     i0 ( )_xv + = 1/4 * Sum ( p3 p4 h1 h2 ) * x ( p3 p4 h1 h2 )_x * v ( h1 h2 p3 p4 )_v
8C     i0 ( )_vxt + = 1 * Sum ( h2 p1 ) * t ( p1 h2 )_t * i1 ( h2 p1 )_vx
9C         i1 ( h2 p1 )_vx + = 1 * Sum ( h3 p4 ) * x ( p4 h3 )_x * v ( h2 h3 p1 p4 )_v
10      IMPLICIT NONE
11#include "global.fh"
12#include "mafdecls.fh"
13#include "util.fh"
14#include "errquit.fh"
15#include "tce.fh"
16      INTEGER d_i0
17      INTEGER k_i0_offset
18      INTEGER d_x1
19      INTEGER k_x1_offset
20      INTEGER d_f1
21      INTEGER k_f1_offset
22      INTEGER d_x2
23      INTEGER k_x2_offset
24      INTEGER d_v2
25      INTEGER k_v2_offset
26      INTEGER d_t1
27      INTEGER k_t1_offset
28      INTEGER d_i1
29      INTEGER k_i1_offset
30      INTEGER l_i1_offset
31      INTEGER size_i1
32      CHARACTER*255 filename
33      CALL nr0_1(d_x1,k_x1_offset,d_f1,k_f1_offset,d_i0,k_i0_offset)
34      CALL nr0_2(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i0,k_i0_offset)
35      CALL OFFSET_nr0_3_1(l_i1_offset,k_i1_offset,size_i1)
36      CALL TCE_FILENAME('nr0_3_1_i1',filename)
37      CALL CREATEFILE(filename,d_i1,size_i1)
38      CALL nr0_3_1(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset)
39      CALL RECONCILEFILE(d_i1,size_i1)
40      CALL nr0_3(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
41      CALL DELETEFILE(d_i1)
42      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('nr0',-1,MA_ERR)
43      RETURN
44      END
45      SUBROUTINE nr0_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
46C     $Id$
47C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
48C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
49C     i0 ( )_xf + = 1 * Sum ( p2 h1 ) * x ( p2 h1 )_x * f ( h1 p2 )_f
50      IMPLICIT NONE
51#include "global.fh"
52#include "mafdecls.fh"
53#include "sym.fh"
54#include "errquit.fh"
55#include "tce.fh"
56      INTEGER d_a
57      INTEGER k_a_offset
58      INTEGER d_b
59      INTEGER k_b_offset
60      INTEGER d_c
61      INTEGER k_c_offset
62      INTEGER nxtask
63      INTEGER next
64      INTEGER nprocs
65      INTEGER count
66      INTEGER dimc
67      INTEGER l_c_sort
68      INTEGER k_c_sort
69      INTEGER p2b
70      INTEGER h1b
71      INTEGER p2b_1
72      INTEGER h1b_1
73      INTEGER h1b_2
74      INTEGER p2b_2
75      INTEGER dim_common
76      INTEGER dima_sort
77      INTEGER dima
78      INTEGER dimb_sort
79      INTEGER dimb
80      INTEGER l_a_sort
81      INTEGER k_a_sort
82      INTEGER l_a
83      INTEGER k_a
84      INTEGER l_b_sort
85      INTEGER k_b_sort
86      INTEGER l_b
87      INTEGER k_b
88      INTEGER l_c
89      INTEGER k_c
90      EXTERNAL nxtask
91      nprocs = GA_NNODES()
92      count = 0
93      next = nxtask(nprocs,1)
94      IF (next.eq.count) THEN
95      IF (0 .eq. ieor(irrep_x,irrep_f)) THEN
96      dimc = 1
97      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
98     & ERRQUIT('nr0_1',0,MA_ERR)
99      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
100      DO p2b = noab+1,noab+nvab
101      DO h1b = 1,noab
102      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
103      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH
104     &EN
105      CALL TCE_RESTRICTED_2(p2b,h1b,p2b_1,h1b_1)
106      CALL TCE_RESTRICTED_2(h1b,p2b,h1b_2,p2b_2)
107      dim_common = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
108      dima_sort = 1
109      dima = dim_common * dima_sort
110      dimb_sort = 1
111      dimb = dim_common * dimb_sort
112      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
113      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
114     & ERRQUIT('nr0_1',1,MA_ERR)
115      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
116     &nr0_1',2,MA_ERR)
117      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
118     & - 1 + noab * (p2b_1 - noab - 1)))
119      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
120     &,int_mb(k_range+h1b-1),2,1,1.0d0)
121      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_1',3,MA_ERR)
122      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
123     & ERRQUIT('nr0_1',4,MA_ERR)
124      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
125     &nr0_1',5,MA_ERR)
126      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2
127     & - 1 + (noab+nvab) * (h1b_2 - 1)))
128      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1)
129     &,int_mb(k_range+p2b-1),1,2,1.0d0)
130      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_1',6,MA_ERR)
131      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
132     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
133     &t),dima_sort)
134      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_1',7,MA_ERR)
135      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_1',8,MA_ERR)
136      END IF
137      END IF
138      END IF
139      END DO
140      END DO
141      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
142     &nr0_1',9,MA_ERR)
143      CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0)
144      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0)
145      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_1',10,MA_ERR)
146      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_1',11,MA_ERR)
147      END IF
148      next = nxtask(nprocs,1)
149      END IF
150      count = count + 1
151      next = nxtask(-nprocs,1)
152      call GA_SYNC()
153      RETURN
154      END
155      SUBROUTINE nr0_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
156C     $Id$
157C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
158C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
159C     i0 ( )_xv + = 1/4 * Sum ( p3 p4 h1 h2 ) * x ( p3 p4 h1 h2 )_x * v ( h1 h2 p3 p4 )_v
160      IMPLICIT NONE
161#include "global.fh"
162#include "mafdecls.fh"
163#include "sym.fh"
164#include "errquit.fh"
165#include "tce.fh"
166      INTEGER d_a
167      INTEGER k_a_offset
168      INTEGER d_b
169      INTEGER k_b_offset
170      INTEGER d_c
171      INTEGER k_c_offset
172      INTEGER nxtask
173      INTEGER next
174      INTEGER nprocs
175      INTEGER count
176      INTEGER dimc
177      INTEGER l_c_sort
178      INTEGER k_c_sort
179      INTEGER p3b
180      INTEGER p4b
181      INTEGER h1b
182      INTEGER h2b
183      INTEGER p3b_1
184      INTEGER p4b_1
185      INTEGER h1b_1
186      INTEGER h2b_1
187      INTEGER h1b_2
188      INTEGER h2b_2
189      INTEGER p3b_2
190      INTEGER p4b_2
191      INTEGER dim_common
192      INTEGER dima_sort
193      INTEGER dima
194      INTEGER dimb_sort
195      INTEGER dimb
196      INTEGER l_a_sort
197      INTEGER k_a_sort
198      INTEGER l_a
199      INTEGER k_a
200      INTEGER l_b_sort
201      INTEGER k_b_sort
202      INTEGER l_b
203      INTEGER k_b
204      INTEGER nsuperp(2)
205      INTEGER isuperp
206      INTEGER nsubh(2)
207      INTEGER isubh
208      INTEGER l_c
209      INTEGER k_c
210      DOUBLE PRECISION FACTORIAL
211      EXTERNAL nxtask
212      EXTERNAL FACTORIAL
213      nprocs = GA_NNODES()
214      count = 0
215      next = nxtask(nprocs,1)
216      IF (next.eq.count) THEN
217      IF (0 .eq. ieor(irrep_x,irrep_v)) THEN
218      dimc = 1
219      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
220     & ERRQUIT('nr0_2',0,MA_ERR)
221      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
222      DO p3b = noab+1,noab+nvab
223      DO p4b = p3b,noab+nvab
224      DO h1b = 1,noab
225      DO h2b = h1b,noab
226      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
227     &1b-1)+int_mb(k_spin+h2b-1)) THEN
228      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
229     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN
230      CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h2b,p3b_1,p4b_1,h1b_1,h2b_1)
231      CALL TCE_RESTRICTED_4(h1b,h2b,p3b,p4b,h1b_2,h2b_2,p3b_2,p4b_2)
232      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m
233     &b(k_range+h1b-1) * int_mb(k_range+h2b-1)
234      dima_sort = 1
235      dima = dim_common * dima_sort
236      dimb_sort = 1
237      dimb = dim_common * dimb_sort
238      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
239      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
240     & ERRQUIT('nr0_2',1,MA_ERR)
241      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
242     &nr0_2',2,MA_ERR)
243      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
244     & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
245     &1 - noab - 1)))))
246      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
247     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
248     &,4,3,2,1,1.0d0)
249      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_2',3,MA_ERR)
250      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
251     & ERRQUIT('nr0_2',4,MA_ERR)
252      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
253     &nr0_2',5,MA_ERR)
254      if(.not.intorb) then
255      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
256     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
257     &+nvab) * (h1b_2 - 1)))))
258      else
259      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
260     &(p4b_2
261     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
262     &+nvab) * (h1b_2 - 1)))),p4b_2,p3b_2,h2b_2,h1b_2)
263      end if
264      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1)
265     &,int_mb(k_range+h2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1)
266     &,2,1,4,3,1.0d0)
267      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_2',6,MA_ERR)
268      nsuperp(1) = 1
269      nsuperp(2) = 1
270      isuperp = 1
271      IF (p3b .eq. p4b) THEN
272      nsuperp(isuperp) = nsuperp(isuperp) + 1
273      ELSE
274      isuperp = isuperp + 1
275      END IF
276      nsubh(1) = 1
277      nsubh(2) = 1
278      isubh = 1
279      IF (h1b .eq. h2b) THEN
280      nsubh(isubh) = nsubh(isubh) + 1
281      ELSE
282      isubh = isubh + 1
283      END IF
284      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,4.0d0/FACTORIAL(
285     &nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsubh(1))/FACTORIAL(ns
286     &ubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.
287     &0d0,dbl_mb(k_c_sort),dima_sort)
288      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_2',7,MA_ERR)
289      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_2',8,MA_ERR)
290      END IF
291      END IF
292      END IF
293      END DO
294      END DO
295      END DO
296      END DO
297      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
298     &nr0_2',9,MA_ERR)
299      CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0/4.0d0)
300      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0)
301      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_2',10,MA_ERR)
302      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_2',11,MA_ERR)
303      END IF
304      next = nxtask(nprocs,1)
305      END IF
306      count = count + 1
307      next = nxtask(-nprocs,1)
308      call GA_SYNC()
309      RETURN
310      END
311      SUBROUTINE nr0_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
312C     $Id$
313C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
314C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
315C     i0 ( )_vxt + = 1 * Sum ( h2 p1 ) * t ( p1 h2 )_t * i1 ( h2 p1 )_vx
316      IMPLICIT NONE
317#include "global.fh"
318#include "mafdecls.fh"
319#include "sym.fh"
320#include "errquit.fh"
321#include "tce.fh"
322      INTEGER d_a
323      INTEGER k_a_offset
324      INTEGER d_b
325      INTEGER k_b_offset
326      INTEGER d_c
327      INTEGER k_c_offset
328      INTEGER nxtask
329      INTEGER next
330      INTEGER nprocs
331      INTEGER count
332      INTEGER dimc
333      INTEGER l_c_sort
334      INTEGER k_c_sort
335      INTEGER p1b
336      INTEGER h2b
337      INTEGER p1b_1
338      INTEGER h2b_1
339      INTEGER h2b_2
340      INTEGER p1b_2
341      INTEGER dim_common
342      INTEGER dima_sort
343      INTEGER dima
344      INTEGER dimb_sort
345      INTEGER dimb
346      INTEGER l_a_sort
347      INTEGER k_a_sort
348      INTEGER l_a
349      INTEGER k_a
350      INTEGER l_b_sort
351      INTEGER k_b_sort
352      INTEGER l_b
353      INTEGER k_b
354      INTEGER l_c
355      INTEGER k_c
356      EXTERNAL nxtask
357      nprocs = GA_NNODES()
358      count = 0
359      next = nxtask(nprocs,1)
360      IF (next.eq.count) THEN
361      IF (0 .eq. ieor(irrep_v,ieor(irrep_x,irrep_t))) THEN
362      dimc = 1
363      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
364     & ERRQUIT('nr0_3',0,MA_ERR)
365      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
366      DO p1b = noab+1,noab+nvab
367      DO h2b = 1,noab
368      IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) THEN
369      IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)) .eq. irrep_t) TH
370     &EN
371      CALL TCE_RESTRICTED_2(p1b,h2b,p1b_1,h2b_1)
372      CALL TCE_RESTRICTED_2(h2b,p1b,h2b_2,p1b_2)
373      dim_common = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1)
374      dima_sort = 1
375      dima = dim_common * dima_sort
376      dimb_sort = 1
377      dimb = dim_common * dimb_sort
378      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
379      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
380     & ERRQUIT('nr0_3',1,MA_ERR)
381      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
382     &nr0_3',2,MA_ERR)
383      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
384     & - 1 + noab * (p1b_1 - noab - 1)))
385      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
386     &,int_mb(k_range+h2b-1),2,1,1.0d0)
387      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_3',3,MA_ERR)
388      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
389     & ERRQUIT('nr0_3',4,MA_ERR)
390      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
391     &nr0_3',5,MA_ERR)
392      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2
393     & - noab - 1 + nvab * (h2b_2 - 1)))
394      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
395     &,int_mb(k_range+p1b-1),1,2,1.0d0)
396      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_3',6,MA_ERR)
397      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
398     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
399     &t),dima_sort)
400      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_3',7,MA_ERR)
401      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_3',8,MA_ERR)
402      END IF
403      END IF
404      END IF
405      END DO
406      END DO
407      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
408     &nr0_3',9,MA_ERR)
409      CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0)
410      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0)
411      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_3',10,MA_ERR)
412      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_3',11,MA_ERR)
413      END IF
414      next = nxtask(nprocs,1)
415      END IF
416      count = count + 1
417      next = nxtask(-nprocs,1)
418      call GA_SYNC()
419      RETURN
420      END
421      SUBROUTINE nr0_3_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
422C     $Id$
423C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
424C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
425C     i1 ( h2 p1 )_vx + = 1 * Sum ( h3 p4 ) * x ( p4 h3 )_x * v ( h2 h3 p1 p4 )_v
426      IMPLICIT NONE
427#include "global.fh"
428#include "mafdecls.fh"
429#include "sym.fh"
430#include "errquit.fh"
431#include "tce.fh"
432      INTEGER d_a
433      INTEGER k_a_offset
434      INTEGER d_b
435      INTEGER k_b_offset
436      INTEGER d_c
437      INTEGER k_c_offset
438      INTEGER nxtask
439      INTEGER next
440      INTEGER nprocs
441      INTEGER count
442      INTEGER h2b
443      INTEGER p1b
444      INTEGER dimc
445      INTEGER l_c_sort
446      INTEGER k_c_sort
447      INTEGER p4b
448      INTEGER h3b
449      INTEGER p4b_1
450      INTEGER h3b_1
451      INTEGER h2b_2
452      INTEGER h3b_2
453      INTEGER p1b_2
454      INTEGER p4b_2
455      INTEGER dim_common
456      INTEGER dima_sort
457      INTEGER dima
458      INTEGER dimb_sort
459      INTEGER dimb
460      INTEGER l_a_sort
461      INTEGER k_a_sort
462      INTEGER l_a
463      INTEGER k_a
464      INTEGER l_b_sort
465      INTEGER k_b_sort
466      INTEGER l_b
467      INTEGER k_b
468      INTEGER l_c
469      INTEGER k_c
470      EXTERNAL nxtask
471      nprocs = GA_NNODES()
472      count = 0
473      next = nxtask(nprocs,1)
474      DO h2b = 1,noab
475      DO p1b = noab+1,noab+nvab
476      IF (next.eq.count) THEN
477      IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1
478     &).ne.4)) THEN
479      IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN
480      IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_
481     &v,irrep_x)) THEN
482      dimc = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1)
483      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
484     & ERRQUIT('nr0_3_1',0,MA_ERR)
485      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
486      DO p4b = noab+1,noab+nvab
487      DO h3b = 1,noab
488      IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h3b-1)) THEN
489      IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH
490     &EN
491      CALL TCE_RESTRICTED_2(p4b,h3b,p4b_1,h3b_1)
492      CALL TCE_RESTRICTED_4(h2b,h3b,p1b,p4b,h2b_2,h3b_2,p1b_2,p4b_2)
493      dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h3b-1)
494      dima_sort = 1
495      dima = dim_common * dima_sort
496      dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1)
497      dimb = dim_common * dimb_sort
498      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
499      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
500     & ERRQUIT('nr0_3_1',1,MA_ERR)
501      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
502     &nr0_3_1',2,MA_ERR)
503      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
504     & - 1 + noab * (p4b_1 - noab - 1)))
505      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
506     &,int_mb(k_range+h3b-1),2,1,1.0d0)
507      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_3_1',3,MA_ERR)
508      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
509     & ERRQUIT('nr0_3_1',4,MA_ERR)
510      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
511     &nr0_3_1',5,MA_ERR)
512      IF ((h3b .lt. h2b) .and. (p4b .lt. p1b)) THEN
513      if(.not.intorb) then
514      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2
515     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
516     &+nvab) * (h3b_2 - 1)))))
517      else
518      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
519     &(p1b_2
520     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
521     &+nvab) * (h3b_2 - 1)))),p1b_2,p4b_2,h2b_2,h3b_2)
522      end if
523      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
524     &,int_mb(k_range+h2b-1),int_mb(k_range+p4b-1),int_mb(k_range+p1b-1)
525     &,4,2,1,3,1.0d0)
526      END IF
527      IF ((h3b .lt. h2b) .and. (p1b .le. p4b)) THEN
528      if(.not.intorb) then
529      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
530     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
531     &+nvab) * (h3b_2 - 1)))))
532      else
533      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
534     &(p4b_2
535     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
536     &+nvab) * (h3b_2 - 1)))),p4b_2,p1b_2,h2b_2,h3b_2)
537      end if
538      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
539     &,int_mb(k_range+h2b-1),int_mb(k_range+p1b-1),int_mb(k_range+p4b-1)
540     &,3,2,1,4,-1.0d0)
541      END IF
542      IF ((h2b .le. h3b) .and. (p4b .lt. p1b)) THEN
543      if(.not.intorb) then
544      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2
545     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab
546     &+nvab) * (h2b_2 - 1)))))
547      else
548      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
549     &(p1b_2
550     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab
551     &+nvab) * (h2b_2 - 1)))),p1b_2,p4b_2,h3b_2,h2b_2)
552      end if
553      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
554     &,int_mb(k_range+h3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p1b-1)
555     &,4,1,2,3,-1.0d0)
556      END IF
557      IF ((h2b .le. h3b) .and. (p1b .le. p4b)) THEN
558      if(.not.intorb) then
559      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
560     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab
561     &+nvab) * (h2b_2 - 1)))))
562      else
563      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
564     &(p4b_2
565     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab
566     &+nvab) * (h2b_2 - 1)))),p4b_2,p1b_2,h3b_2,h2b_2)
567      end if
568      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
569     &,int_mb(k_range+h3b-1),int_mb(k_range+p1b-1),int_mb(k_range+p4b-1)
570     &,3,1,2,4,1.0d0)
571      END IF
572      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_3_1',6,MA_ERR)
573      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
574     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
575     &t),dima_sort)
576      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_3_1',7,MA_ERR)
577      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_3_1',8,MA_ERR)
578      END IF
579      END IF
580      END IF
581      END DO
582      END DO
583      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
584     &nr0_3_1',9,MA_ERR)
585      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1)
586     &,int_mb(k_range+h2b-1),2,1,1.0d0)
587      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b -
588     & noab - 1 + nvab * (h2b - 1)))
589      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_3_1',10,MA_ERR)
590      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_3_1',11,MA_ERR)
591      END IF
592      END IF
593      END IF
594      next = nxtask(nprocs,1)
595      END IF
596      count = count + 1
597      END DO
598      END DO
599      next = nxtask(-nprocs,1)
600      call GA_SYNC()
601      RETURN
602      END
603      SUBROUTINE OFFSET_nr0_3_1(l_a_offset,k_a_offset,size)
604C     $Id$
605C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
606C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
607C     i1 ( h2 p1 )_vx
608      IMPLICIT NONE
609#include "global.fh"
610#include "mafdecls.fh"
611#include "sym.fh"
612#include "errquit.fh"
613#include "tce.fh"
614      INTEGER l_a_offset
615      INTEGER k_a_offset
616      INTEGER size
617      INTEGER length
618      INTEGER addr
619      INTEGER h2b
620      INTEGER p1b
621      length = 0
622      DO h2b = 1,noab
623      DO p1b = noab+1,noab+nvab
624      IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN
625      IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_
626     &v,irrep_x)) THEN
627      IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1
628     &).ne.4)) THEN
629      length = length + 1
630      END IF
631      END IF
632      END IF
633      END DO
634      END DO
635      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
636     &set)) CALL ERRQUIT('nr0_3_1',0,MA_ERR)
637      int_mb(k_a_offset) = length
638      addr = 0
639      size = 0
640      DO h2b = 1,noab
641      DO p1b = noab+1,noab+nvab
642      IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN
643      IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_
644     &v,irrep_x)) THEN
645      IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1
646     &).ne.4)) THEN
647      addr = addr + 1
648      int_mb(k_a_offset+addr) = p1b - noab - 1 + nvab * (h2b - 1)
649      int_mb(k_a_offset+length+addr) = size
650      size = size + int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1)
651      END IF
652      END IF
653      END IF
654      END DO
655      END DO
656      RETURN
657      END
658c
659c
660c
661c
662c
663c
664c
665c
666c
667      SUBROUTINE nr0_act(d_f1,d_i0,d_t1,d_v2,d_x1,d_x2,k_f1_offset,
668     &k_i0_offset,k_t1_offset,k_v2_offset,k_x1_offset,k_x2_offset)
669C     $Id$
670C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
671C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
672C     i0 ( )_xf + = 1 * Sum ( p2 h1 ) * x ( p2 h1 )_x * f ( h1 p2 )_f
673C     i0 ( )_xv + = 1/4 * Sum ( p3 p4 h1 h2 ) * x ( p3 p4 h1 h2 )_x * v ( h1 h2 p3 p4 )_v
674C     i0 ( )_vxt + = 1 * Sum ( h2 p1 ) * t ( p1 h2 )_t * i1 ( h2 p1 )_vx
675C         i1 ( h2 p1 )_vx + = 1 * Sum ( h3 p4 ) * x ( p4 h3 )_x * v ( h2 h3 p1 p4 )_v
676      IMPLICIT NONE
677#include "global.fh"
678#include "mafdecls.fh"
679#include "util.fh"
680#include "errquit.fh"
681#include "tce.fh"
682      INTEGER d_i0
683      INTEGER k_i0_offset
684      INTEGER d_x1
685      INTEGER k_x1_offset
686      INTEGER d_f1
687      INTEGER k_f1_offset
688      INTEGER d_x2
689      INTEGER k_x2_offset
690      INTEGER d_v2
691      INTEGER k_v2_offset
692      INTEGER d_t1
693      INTEGER k_t1_offset
694      INTEGER d_i1
695      INTEGER k_i1_offset
696      INTEGER l_i1_offset
697      INTEGER size_i1
698      CHARACTER*255 filename
699      CALL nr0_act_1(d_x1,k_x1_offset,d_f1,k_f1_offset,d_i0,k_i0_offset)
700      CALL nr0_act_2(d_x2,k_x2_offset,d_v2,k_v2_offset,d_i0,k_i0_offset)
701      CALL OFFSET_nr0_act_3_1(l_i1_offset,k_i1_offset,size_i1)
702      CALL TCE_FILENAME('nr0_3_1_i1',filename)
703      CALL CREATEFILE(filename,d_i1,size_i1)
704      CALL nr0_act_3_1(d_x1,k_x1_offset,d_v2,k_v2_offset,
705     &     d_i1,k_i1_offset)
706      CALL RECONCILEFILE(d_i1,size_i1)
707      CALL nr0_act_3(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
708      CALL DELETEFILE(d_i1)
709      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('nr0',-1,MA_ERR)
710      RETURN
711      END
712      SUBROUTINE nr0_act_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
713C     $Id$
714C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
715C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
716C     i0 ( )_xf + = 1 * Sum ( p2 h1 ) * x ( p2 h1 )_x * f ( h1 p2 )_f
717      IMPLICIT NONE
718#include "global.fh"
719#include "mafdecls.fh"
720#include "sym.fh"
721#include "errquit.fh"
722#include "tce.fh"
723      INTEGER d_a
724      INTEGER k_a_offset
725      INTEGER d_b
726      INTEGER k_b_offset
727      INTEGER d_c
728      INTEGER k_c_offset
729      INTEGER nxtask
730      INTEGER next
731      INTEGER nprocs
732      INTEGER count
733      INTEGER dimc
734      INTEGER l_c_sort
735      INTEGER k_c_sort
736      INTEGER p2b
737      INTEGER h1b
738      INTEGER p2b_1
739      INTEGER h1b_1
740      INTEGER h1b_2
741      INTEGER p2b_2
742      INTEGER dim_common
743      INTEGER dima_sort
744      INTEGER dima
745      INTEGER dimb_sort
746      INTEGER dimb
747      INTEGER l_a_sort
748      INTEGER k_a_sort
749      INTEGER l_a
750      INTEGER k_a
751      INTEGER l_b_sort
752      INTEGER k_b_sort
753      INTEGER l_b
754      INTEGER k_b
755      INTEGER l_c
756      INTEGER k_c
757      EXTERNAL nxtask
758      nprocs = GA_NNODES()
759      count = 0
760      next = nxtask(nprocs,1)
761      IF (next.eq.count) THEN
762      IF (0 .eq. ieor(irrep_x,irrep_f)) THEN
763      dimc = 1
764      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
765     & ERRQUIT('nr0_1',0,MA_ERR)
766      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
767      DO p2b = noab+1,noab+nvab
768      DO h1b = 1,noab
769      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
770      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH
771     &EN
772      CALL TCE_RESTRICTED_2(p2b,h1b,p2b_1,h1b_1)
773      CALL TCE_RESTRICTED_2(h1b,p2b,h1b_2,p2b_2)
774      dim_common = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
775      dima_sort = 1
776      dima = dim_common * dima_sort
777      dimb_sort = 1
778      dimb = dim_common * dimb_sort
779      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
780      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
781     & ERRQUIT('nr0_1',1,MA_ERR)
782      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
783     &nr0_1',2,MA_ERR)
784      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
785     & - 1 + noab * (p2b_1 - noab - 1)))
786      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
787     &,int_mb(k_range+h1b-1),2,1,1.0d0)
788      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_1',3,MA_ERR)
789      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
790     & ERRQUIT('nr0_1',4,MA_ERR)
791      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
792     &nr0_1',5,MA_ERR)
793      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2
794     & - 1 + (noab+nvab) * (h1b_2 - 1)))
795      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1)
796     &,int_mb(k_range+p2b-1),1,2,1.0d0)
797      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_1',6,MA_ERR)
798      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
799     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
800     &t),dima_sort)
801      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_1',7,MA_ERR)
802      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_1',8,MA_ERR)
803      END IF
804      END IF
805      END IF
806      END DO
807      END DO
808      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
809     &nr0_1',9,MA_ERR)
810      CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0)
811      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0)
812      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_1',10,MA_ERR)
813      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_1',11,MA_ERR)
814      END IF
815      next = nxtask(nprocs,1)
816      END IF
817      count = count + 1
818      next = nxtask(-nprocs,1)
819      call GA_SYNC()
820      RETURN
821      END
822      SUBROUTINE nr0_act_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
823C     $Id$
824C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
825C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
826C     i0 ( )_xv + = 1/4 * Sum ( p3 p4 h1 h2 ) * x ( p3 p4 h1 h2 )_x * v ( h1 h2 p3 p4 )_v
827      IMPLICIT NONE
828#include "global.fh"
829#include "mafdecls.fh"
830#include "sym.fh"
831#include "errquit.fh"
832#include "tce.fh"
833      INTEGER d_a
834      INTEGER k_a_offset
835      INTEGER d_b
836      INTEGER k_b_offset
837      INTEGER d_c
838      INTEGER k_c_offset
839      INTEGER nxtask
840      INTEGER next
841      INTEGER nprocs
842      INTEGER count
843      INTEGER dimc
844      INTEGER l_c_sort
845      INTEGER k_c_sort
846      INTEGER p3b
847      INTEGER p4b
848      INTEGER h1b
849      INTEGER h2b
850      INTEGER p3b_1
851      INTEGER p4b_1
852      INTEGER h1b_1
853      INTEGER h2b_1
854      INTEGER h1b_2
855      INTEGER h2b_2
856      INTEGER p3b_2
857      INTEGER p4b_2
858      INTEGER dim_common
859      INTEGER dima_sort
860      INTEGER dima
861      INTEGER dimb_sort
862      INTEGER dimb
863      INTEGER l_a_sort
864      INTEGER k_a_sort
865      INTEGER l_a
866      INTEGER k_a
867      INTEGER l_b_sort
868      INTEGER k_b_sort
869      INTEGER l_b
870      INTEGER k_b
871      INTEGER nsuperp(2)
872      INTEGER isuperp
873      INTEGER nsubh(2)
874      INTEGER isubh
875      INTEGER l_c
876      INTEGER k_c
877      LOGICAL is_active_1,is_active_2,is_active_3,is_active_4
878      LOGICAL one_of_two_act
879      DOUBLE PRECISION FACTORIAL
880      EXTERNAL nxtask
881      EXTERNAL FACTORIAL
882      nprocs = GA_NNODES()
883      count = 0
884      next = nxtask(nprocs,1)
885      IF (next.eq.count) THEN
886      IF (0 .eq. ieor(irrep_x,irrep_v)) THEN
887      dimc = 1
888      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
889     & ERRQUIT('nr0_2',0,MA_ERR)
890      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
891      DO p3b = noab+1,noab+nvab
892      DO p4b = p3b,noab+nvab
893      DO h1b = 1,noab
894      DO h2b = h1b,noab
895      IF(is_active_4(p3b,p4b,h1b,h2b)) THEN
896      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
897     &1b-1)+int_mb(k_spin+h2b-1)) THEN
898      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
899     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN
900      CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h2b,p3b_1,p4b_1,h1b_1,h2b_1)
901      CALL TCE_RESTRICTED_4(h1b,h2b,p3b,p4b,h1b_2,h2b_2,p3b_2,p4b_2)
902      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m
903     &b(k_range+h1b-1) * int_mb(k_range+h2b-1)
904      dima_sort = 1
905      dima = dim_common * dima_sort
906      dimb_sort = 1
907      dimb = dim_common * dimb_sort
908      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
909      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
910     & ERRQUIT('nr0_2',1,MA_ERR)
911      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
912     &nr0_2',2,MA_ERR)
913      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
914     & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
915     &1 - noab - 1)))))
916      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
917     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
918     &,4,3,2,1,1.0d0)
919      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_2',3,MA_ERR)
920      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
921     & ERRQUIT('nr0_2',4,MA_ERR)
922      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
923     &nr0_2',5,MA_ERR)
924      if(.not.intorb) then
925      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
926     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
927     &+nvab) * (h1b_2 - 1)))))
928      else
929      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
930     &(p4b_2
931     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
932     &+nvab) * (h1b_2 - 1)))),p4b_2,p3b_2,h2b_2,h1b_2)
933      end if
934      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1)
935     &,int_mb(k_range+h2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1)
936     &,2,1,4,3,1.0d0)
937      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_2',6,MA_ERR)
938      nsuperp(1) = 1
939      nsuperp(2) = 1
940      isuperp = 1
941      IF (p3b .eq. p4b) THEN
942      nsuperp(isuperp) = nsuperp(isuperp) + 1
943      ELSE
944      isuperp = isuperp + 1
945      END IF
946      nsubh(1) = 1
947      nsubh(2) = 1
948      isubh = 1
949      IF (h1b .eq. h2b) THEN
950      nsubh(isubh) = nsubh(isubh) + 1
951      ELSE
952      isubh = isubh + 1
953      END IF
954      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,4.0d0/FACTORIAL(
955     &nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsubh(1))/FACTORIAL(ns
956     &ubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.
957     &0d0,dbl_mb(k_c_sort),dima_sort)
958      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_2',7,MA_ERR)
959      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_2',8,MA_ERR)
960      END IF
961      END IF
962      END IF
963      END IF
964      END DO
965      END DO
966      END DO
967      END DO
968      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
969     &nr0_2',9,MA_ERR)
970      CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0/4.0d0)
971      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0)
972      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_2',10,MA_ERR)
973      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_2',11,MA_ERR)
974      END IF
975      next = nxtask(nprocs,1)
976      END IF
977      count = count + 1
978      next = nxtask(-nprocs,1)
979      call GA_SYNC()
980      RETURN
981      END
982      SUBROUTINE nr0_act_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
983C     $Id$
984C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
985C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
986C     i0 ( )_vxt + = 1 * Sum ( h2 p1 ) * t ( p1 h2 )_t * i1 ( h2 p1 )_vx
987      IMPLICIT NONE
988#include "global.fh"
989#include "mafdecls.fh"
990#include "sym.fh"
991#include "errquit.fh"
992#include "tce.fh"
993      INTEGER d_a
994      INTEGER k_a_offset
995      INTEGER d_b
996      INTEGER k_b_offset
997      INTEGER d_c
998      INTEGER k_c_offset
999      INTEGER nxtask
1000      INTEGER next
1001      INTEGER nprocs
1002      INTEGER count
1003      INTEGER dimc
1004      INTEGER l_c_sort
1005      INTEGER k_c_sort
1006      INTEGER p1b
1007      INTEGER h2b
1008      INTEGER p1b_1
1009      INTEGER h2b_1
1010      INTEGER h2b_2
1011      INTEGER p1b_2
1012      INTEGER dim_common
1013      INTEGER dima_sort
1014      INTEGER dima
1015      INTEGER dimb_sort
1016      INTEGER dimb
1017      INTEGER l_a_sort
1018      INTEGER k_a_sort
1019      INTEGER l_a
1020      INTEGER k_a
1021      INTEGER l_b_sort
1022      INTEGER k_b_sort
1023      INTEGER l_b
1024      INTEGER k_b
1025      INTEGER l_c
1026      INTEGER k_c
1027      EXTERNAL nxtask
1028      nprocs = GA_NNODES()
1029      count = 0
1030      next = nxtask(nprocs,1)
1031      IF (next.eq.count) THEN
1032      IF (0 .eq. ieor(irrep_v,ieor(irrep_x,irrep_t))) THEN
1033      dimc = 1
1034      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1035     & ERRQUIT('nr0_3',0,MA_ERR)
1036      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1037      DO p1b = noab+1,noab+nvab
1038      DO h2b = 1,noab
1039      IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) THEN
1040      IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)) .eq. irrep_t) TH
1041     &EN
1042      CALL TCE_RESTRICTED_2(p1b,h2b,p1b_1,h2b_1)
1043      CALL TCE_RESTRICTED_2(h2b,p1b,h2b_2,p1b_2)
1044      dim_common = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1)
1045      dima_sort = 1
1046      dima = dim_common * dima_sort
1047      dimb_sort = 1
1048      dimb = dim_common * dimb_sort
1049      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1050      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1051     & ERRQUIT('nr0_3',1,MA_ERR)
1052      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1053     &nr0_3',2,MA_ERR)
1054      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
1055     & - 1 + noab * (p1b_1 - noab - 1)))
1056      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
1057     &,int_mb(k_range+h2b-1),2,1,1.0d0)
1058      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_3',3,MA_ERR)
1059      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1060     & ERRQUIT('nr0_3',4,MA_ERR)
1061      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1062     &nr0_3',5,MA_ERR)
1063      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2
1064     & - noab - 1 + nvab * (h2b_2 - 1)))
1065      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
1066     &,int_mb(k_range+p1b-1),1,2,1.0d0)
1067      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_3',6,MA_ERR)
1068      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1069     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1070     &t),dima_sort)
1071      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_3',7,MA_ERR)
1072      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_3',8,MA_ERR)
1073      END IF
1074      END IF
1075      END IF
1076      END DO
1077      END DO
1078      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1079     &nr0_3',9,MA_ERR)
1080      CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0)
1081      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0)
1082      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_3',10,MA_ERR)
1083      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_3',11,MA_ERR)
1084      END IF
1085      next = nxtask(nprocs,1)
1086      END IF
1087      count = count + 1
1088      next = nxtask(-nprocs,1)
1089      call GA_SYNC()
1090      RETURN
1091      END
1092      SUBROUTINE nr0_act_3_1(d_a,k_a_offset,d_b,k_b_offset,
1093     & d_c,k_c_offset)
1094C     $Id$
1095C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1096C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1097C     i1 ( h2 p1 )_vx + = 1 * Sum ( h3 p4 ) * x ( p4 h3 )_x * v ( h2 h3 p1 p4 )_v
1098      IMPLICIT NONE
1099#include "global.fh"
1100#include "mafdecls.fh"
1101#include "sym.fh"
1102#include "errquit.fh"
1103#include "tce.fh"
1104      INTEGER d_a
1105      INTEGER k_a_offset
1106      INTEGER d_b
1107      INTEGER k_b_offset
1108      INTEGER d_c
1109      INTEGER k_c_offset
1110      INTEGER nxtask
1111      INTEGER next
1112      INTEGER nprocs
1113      INTEGER count
1114      INTEGER h2b
1115      INTEGER p1b
1116      INTEGER dimc
1117      INTEGER l_c_sort
1118      INTEGER k_c_sort
1119      INTEGER p4b
1120      INTEGER h3b
1121      INTEGER p4b_1
1122      INTEGER h3b_1
1123      INTEGER h2b_2
1124      INTEGER h3b_2
1125      INTEGER p1b_2
1126      INTEGER p4b_2
1127      INTEGER dim_common
1128      INTEGER dima_sort
1129      INTEGER dima
1130      INTEGER dimb_sort
1131      INTEGER dimb
1132      INTEGER l_a_sort
1133      INTEGER k_a_sort
1134      INTEGER l_a
1135      INTEGER k_a
1136      INTEGER l_b_sort
1137      INTEGER k_b_sort
1138      INTEGER l_b
1139      INTEGER k_b
1140      INTEGER l_c
1141      INTEGER k_c
1142      EXTERNAL nxtask
1143      nprocs = GA_NNODES()
1144      count = 0
1145      next = nxtask(nprocs,1)
1146      DO h2b = 1,noab
1147      DO p1b = noab+1,noab+nvab
1148      IF (next.eq.count) THEN
1149      IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1
1150     &).ne.4)) THEN
1151      IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN
1152      IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_
1153     &v,irrep_x)) THEN
1154      dimc = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1)
1155      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
1156     & ERRQUIT('nr0_3_1',0,MA_ERR)
1157      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
1158      DO p4b = noab+1,noab+nvab
1159      DO h3b = 1,noab
1160      IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h3b-1)) THEN
1161      IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH
1162     &EN
1163      CALL TCE_RESTRICTED_2(p4b,h3b,p4b_1,h3b_1)
1164      CALL TCE_RESTRICTED_4(h2b,h3b,p1b,p4b,h2b_2,h3b_2,p1b_2,p4b_2)
1165      dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h3b-1)
1166      dima_sort = 1
1167      dima = dim_common * dima_sort
1168      dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1)
1169      dimb = dim_common * dimb_sort
1170      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1171      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
1172     & ERRQUIT('nr0_3_1',1,MA_ERR)
1173      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1174     &nr0_3_1',2,MA_ERR)
1175      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
1176     & - 1 + noab * (p4b_1 - noab - 1)))
1177      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
1178     &,int_mb(k_range+h3b-1),2,1,1.0d0)
1179      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('nr0_3_1',3,MA_ERR)
1180      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
1181     & ERRQUIT('nr0_3_1',4,MA_ERR)
1182      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1183     &nr0_3_1',5,MA_ERR)
1184      IF ((h3b .lt. h2b) .and. (p4b .lt. p1b)) THEN
1185      if(.not.intorb) then
1186      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2
1187     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
1188     &+nvab) * (h3b_2 - 1)))))
1189      else
1190      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1191     &(p1b_2
1192     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
1193     &+nvab) * (h3b_2 - 1)))),p1b_2,p4b_2,h2b_2,h3b_2)
1194      end if
1195      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
1196     &,int_mb(k_range+h2b-1),int_mb(k_range+p4b-1),int_mb(k_range+p1b-1)
1197     &,4,2,1,3,1.0d0)
1198      END IF
1199      IF ((h3b .lt. h2b) .and. (p1b .le. p4b)) THEN
1200      if(.not.intorb) then
1201      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
1202     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
1203     &+nvab) * (h3b_2 - 1)))))
1204      else
1205      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1206     &(p4b_2
1207     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h2b_2 - 1 + (noab
1208     &+nvab) * (h3b_2 - 1)))),p4b_2,p1b_2,h2b_2,h3b_2)
1209      end if
1210      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
1211     &,int_mb(k_range+h2b-1),int_mb(k_range+p1b-1),int_mb(k_range+p4b-1)
1212     &,3,2,1,4,-1.0d0)
1213      END IF
1214      IF ((h2b .le. h3b) .and. (p4b .lt. p1b)) THEN
1215      if(.not.intorb) then
1216      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2
1217     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab
1218     &+nvab) * (h2b_2 - 1)))))
1219      else
1220      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1221     &(p1b_2
1222     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab
1223     &+nvab) * (h2b_2 - 1)))),p1b_2,p4b_2,h3b_2,h2b_2)
1224      end if
1225      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
1226     &,int_mb(k_range+h3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p1b-1)
1227     &,4,1,2,3,-1.0d0)
1228      END IF
1229      IF ((h2b .le. h3b) .and. (p1b .le. p4b)) THEN
1230      if(.not.intorb) then
1231      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
1232     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab
1233     &+nvab) * (h2b_2 - 1)))))
1234      else
1235      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1236     &(p4b_2
1237     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h3b_2 - 1 + (noab
1238     &+nvab) * (h2b_2 - 1)))),p4b_2,p1b_2,h3b_2,h2b_2)
1239      end if
1240      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
1241     &,int_mb(k_range+h3b-1),int_mb(k_range+p1b-1),int_mb(k_range+p4b-1)
1242     &,3,1,2,4,1.0d0)
1243      END IF
1244      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('nr0_3_1',6,MA_ERR)
1245      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
1246     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
1247     &t),dima_sort)
1248      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('nr0_3_1',7,MA_ERR)
1249      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('nr0_3_1',8,MA_ERR)
1250      END IF
1251      END IF
1252      END IF
1253      END DO
1254      END DO
1255      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1256     &nr0_3_1',9,MA_ERR)
1257      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1)
1258     &,int_mb(k_range+h2b-1),2,1,1.0d0)
1259      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b -
1260     & noab - 1 + nvab * (h2b - 1)))
1261      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('nr0_3_1',10,MA_ERR)
1262      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('nr0_3_1',11,MA_ERR)
1263      END IF
1264      END IF
1265      END IF
1266      next = nxtask(nprocs,1)
1267      END IF
1268      count = count + 1
1269      END DO
1270      END DO
1271      next = nxtask(-nprocs,1)
1272      call GA_SYNC()
1273      RETURN
1274      END
1275      SUBROUTINE OFFSET_nr0_act_3_1(l_a_offset,k_a_offset,size)
1276C     $Id$
1277C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1278C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1279C     i1 ( h2 p1 )_vx
1280      IMPLICIT NONE
1281#include "global.fh"
1282#include "mafdecls.fh"
1283#include "sym.fh"
1284#include "errquit.fh"
1285#include "tce.fh"
1286      INTEGER l_a_offset
1287      INTEGER k_a_offset
1288      INTEGER size
1289      INTEGER length
1290      INTEGER addr
1291      INTEGER h2b
1292      INTEGER p1b
1293      length = 0
1294      DO h2b = 1,noab
1295      DO p1b = noab+1,noab+nvab
1296      IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN
1297      IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_
1298     &v,irrep_x)) THEN
1299      IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1
1300     &).ne.4)) THEN
1301      length = length + 1
1302      END IF
1303      END IF
1304      END IF
1305      END DO
1306      END DO
1307      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
1308     &set)) CALL ERRQUIT('nr0_3_1',0,MA_ERR)
1309      int_mb(k_a_offset) = length
1310      addr = 0
1311      size = 0
1312      DO h2b = 1,noab
1313      DO p1b = noab+1,noab+nvab
1314      IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+p1b-1)) THEN
1315      IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_
1316     &v,irrep_x)) THEN
1317      IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p1b-1
1318     &).ne.4)) THEN
1319      addr = addr + 1
1320      int_mb(k_a_offset+addr) = p1b - noab - 1 + nvab * (h2b - 1)
1321      int_mb(k_a_offset+length+addr) = size
1322      size = size + int_mb(k_range+h2b-1) * int_mb(k_range+p1b-1)
1323      END IF
1324      END IF
1325      END IF
1326      END DO
1327      END DO
1328      RETURN
1329      END
1330
1331