1      SUBROUTINE cis_x1(d_f1,d_i0,d_v2,d_x1,k_f1_offset,k_i0_offset,k_v2
2     &_offset,k_x1_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 * f ( h3 h1 )_f
7C     i0 ( p2 h1 )_xf + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * f ( p2 p3 )_f
8C     i0 ( p2 h1 )_xv + = -1 * Sum ( p4 h3 ) * x ( p4 h3 )_x * v ( h3 p2 h1 p4 )_v
9      IMPLICIT NONE
10#include "global.fh"
11#include "mafdecls.fh"
12#include "util.fh"
13#include "errquit.fh"
14#include "tce.fh"
15      INTEGER d_i0
16      INTEGER k_i0_offset
17      INTEGER d_x1
18      INTEGER k_x1_offset
19      INTEGER d_f1
20      INTEGER k_f1_offset
21      INTEGER d_v2
22      INTEGER k_v2_offset
23      CALL cis_x1_1(d_x1,k_x1_offset,d_f1,k_f1_offset,d_i0,k_i0_offset)
24      CALL cis_x1_2(d_x1,k_x1_offset,d_f1,k_f1_offset,d_i0,k_i0_offset)
25      CALL cis_x1_3(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i0,k_i0_offset)
26      RETURN
27      END
28      SUBROUTINE cis_x1_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
29C     $Id$
30C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
31C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
32C     i0 ( p2 h1 )_xf + = -1 * Sum ( h3 ) * x ( p2 h3 )_x * f ( h3 h1 )_f
33      IMPLICIT NONE
34#include "global.fh"
35#include "mafdecls.fh"
36#include "sym.fh"
37#include "errquit.fh"
38#include "tce.fh"
39      INTEGER d_a
40      INTEGER k_a_offset
41      INTEGER d_b
42      INTEGER k_b_offset
43      INTEGER d_c
44      INTEGER k_c_offset
45      INTEGER nxtask
46      INTEGER next
47      INTEGER nprocs
48      INTEGER count
49      INTEGER p2b
50      INTEGER h1b
51      INTEGER dimc
52      INTEGER l_c_sort
53      INTEGER k_c_sort
54      INTEGER h3b
55      INTEGER p2b_1
56      INTEGER h3b_1
57      INTEGER h3b_2
58      INTEGER h1b_2
59      INTEGER dim_common
60      INTEGER dima_sort
61      INTEGER dima
62      INTEGER dimb_sort
63      INTEGER dimb
64      INTEGER l_a_sort
65      INTEGER k_a_sort
66      INTEGER l_a
67      INTEGER k_a
68      INTEGER l_b_sort
69      INTEGER k_b_sort
70      INTEGER l_b
71      INTEGER k_b
72      INTEGER l_c
73      INTEGER k_c
74      EXTERNAL nxtask
75      nprocs = GA_NNODES()
76      count = 0
77      next = nxtask(nprocs,1)
78      DO p2b = noab+1,noab+nvab
79      DO h1b = 1,noab
80      IF (next.eq.count) THEN
81      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
82     &).ne.4)) THEN
83      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
84      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
85     &x,irrep_f)) THEN
86      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
87      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
88     & ERRQUIT('cis_x1_1',0,MA_ERR)
89      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
90      DO h3b = 1,noab
91      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h3b-1)) THEN
92      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH
93     &EN
94      CALL TCE_RESTRICTED_2(p2b,h3b,p2b_1,h3b_1)
95      CALL TCE_RESTRICTED_2(h3b,h1b,h3b_2,h1b_2)
96      dim_common = int_mb(k_range+h3b-1)
97      dima_sort = int_mb(k_range+p2b-1)
98      dima = dim_common * dima_sort
99      dimb_sort = int_mb(k_range+h1b-1)
100      dimb = dim_common * dimb_sort
101      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
102      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
103     & ERRQUIT('cis_x1_1',1,MA_ERR)
104      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
105     &cis_x1_1',2,MA_ERR)
106      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
107     & - 1 + noab * (p2b_1 - noab - 1)))
108      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
109     &,int_mb(k_range+h3b-1),1,2,1.0d0)
110      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cis_x1_1',3,MA_ERR)
111      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
112     & ERRQUIT('cis_x1_1',4,MA_ERR)
113      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
114     &cis_x1_1',5,MA_ERR)
115      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2
116     & - 1 + (noab+nvab) * (h3b_2 - 1)))
117      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
118     &,int_mb(k_range+h1b-1),2,1,1.0d0)
119      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cis_x1_1',6,MA_ERR)
120      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
121     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
122     &t),dima_sort)
123      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cis_x1_1',7,MA_ERR)
124      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cis_x1_1',8,MA_ERR)
125      END IF
126      END IF
127      END IF
128      END DO
129      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
130     &cis_x1_1',9,MA_ERR)
131      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
132     &,int_mb(k_range+p2b-1),2,1,-1.0d0)
133      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
134     & 1 + noab * (p2b - noab - 1)))
135      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cis_x1_1',10,MA_ERR)
136      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cis_x1_1',11,MA_ERR
137     &)
138      END IF
139      END IF
140      END IF
141      next = nxtask(nprocs,1)
142      END IF
143      count = count + 1
144      END DO
145      END DO
146      next = nxtask(-nprocs,1)
147      call GA_SYNC()
148      RETURN
149      END
150      SUBROUTINE cis_x1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
151C     $Id$
152C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
153C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
154C     i0 ( p2 h1 )_xf + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * f ( p2 p3 )_f
155      IMPLICIT NONE
156#include "global.fh"
157#include "mafdecls.fh"
158#include "sym.fh"
159#include "errquit.fh"
160#include "tce.fh"
161      INTEGER d_a
162      INTEGER k_a_offset
163      INTEGER d_b
164      INTEGER k_b_offset
165      INTEGER d_c
166      INTEGER k_c_offset
167      INTEGER nxtask
168      INTEGER next
169      INTEGER nprocs
170      INTEGER count
171      INTEGER p2b
172      INTEGER h1b
173      INTEGER dimc
174      INTEGER l_c_sort
175      INTEGER k_c_sort
176      INTEGER p3b
177      INTEGER p3b_1
178      INTEGER h1b_1
179      INTEGER p2b_2
180      INTEGER p3b_2
181      INTEGER dim_common
182      INTEGER dima_sort
183      INTEGER dima
184      INTEGER dimb_sort
185      INTEGER dimb
186      INTEGER l_a_sort
187      INTEGER k_a_sort
188      INTEGER l_a
189      INTEGER k_a
190      INTEGER l_b_sort
191      INTEGER k_b_sort
192      INTEGER l_b
193      INTEGER k_b
194      INTEGER l_c
195      INTEGER k_c
196      EXTERNAL nxtask
197      nprocs = GA_NNODES()
198      count = 0
199      next = nxtask(nprocs,1)
200      DO p2b = noab+1,noab+nvab
201      DO h1b = 1,noab
202      IF (next.eq.count) THEN
203      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
204     &).ne.4)) THEN
205      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
206      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
207     &x,irrep_f)) THEN
208      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
209      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
210     & ERRQUIT('cis_x1_2',0,MA_ERR)
211      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
212      DO p3b = noab+1,noab+nvab
213      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
214      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH
215     &EN
216      CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1)
217      CALL TCE_RESTRICTED_2(p2b,p3b,p2b_2,p3b_2)
218      dim_common = int_mb(k_range+p3b-1)
219      dima_sort = int_mb(k_range+h1b-1)
220      dima = dim_common * dima_sort
221      dimb_sort = int_mb(k_range+p2b-1)
222      dimb = dim_common * dimb_sort
223      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
224      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
225     & ERRQUIT('cis_x1_2',1,MA_ERR)
226      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
227     &cis_x1_2',2,MA_ERR)
228      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
229     & - 1 + noab * (p3b_1 - noab - 1)))
230      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
231     &,int_mb(k_range+h1b-1),2,1,1.0d0)
232      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cis_x1_2',3,MA_ERR)
233      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
234     & ERRQUIT('cis_x1_2',4,MA_ERR)
235      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
236     &cis_x1_2',5,MA_ERR)
237      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
238     & - 1 + (noab+nvab) * (p2b_2 - 1)))
239      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1)
240     &,int_mb(k_range+p3b-1),1,2,1.0d0)
241      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cis_x1_2',6,MA_ERR)
242      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
243     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
244     &t),dima_sort)
245      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cis_x1_2',7,MA_ERR)
246      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cis_x1_2',8,MA_ERR)
247      END IF
248      END IF
249      END IF
250      END DO
251      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
252     &cis_x1_2',9,MA_ERR)
253      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1)
254     &,int_mb(k_range+h1b-1),1,2,1.0d0)
255      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
256     & 1 + noab * (p2b - noab - 1)))
257      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cis_x1_2',10,MA_ERR)
258      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cis_x1_2',11,MA_ERR
259     &)
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 cis_x1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
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     i0 ( p2 h1 )_xv + = -1 * Sum ( p4 h3 ) * x ( p4 h3 )_x * v ( h3 p2 h1 p4 )_v
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 d_a
284      INTEGER k_a_offset
285      INTEGER d_b
286      INTEGER k_b_offset
287      INTEGER d_c
288      INTEGER k_c_offset
289      INTEGER nxtask
290      INTEGER next
291      INTEGER nprocs
292      INTEGER count
293      INTEGER p2b
294      INTEGER h1b
295      INTEGER dimc
296      INTEGER l_c_sort
297      INTEGER k_c_sort
298      INTEGER p4b
299      INTEGER h3b
300      INTEGER p4b_1
301      INTEGER h3b_1
302      INTEGER p2b_2
303      INTEGER h3b_2
304      INTEGER h1b_2
305      INTEGER p4b_2
306      INTEGER dim_common
307      INTEGER dima_sort
308      INTEGER dima
309      INTEGER dimb_sort
310      INTEGER dimb
311      INTEGER l_a_sort
312      INTEGER k_a_sort
313      INTEGER l_a
314      INTEGER k_a
315      INTEGER l_b_sort
316      INTEGER k_b_sort
317      INTEGER l_b
318      INTEGER k_b
319      INTEGER l_c
320      INTEGER k_c
321      EXTERNAL nxtask
322      nprocs = GA_NNODES()
323      count = 0
324      next = nxtask(nprocs,1)
325      DO p2b = noab+1,noab+nvab
326      DO h1b = 1,noab
327      IF (next.eq.count) THEN
328      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
329     &).ne.4)) THEN
330      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
331      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
332     &x,irrep_v)) THEN
333      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
334      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
335     & ERRQUIT('cis_x1_3',0,MA_ERR)
336      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
337      DO p4b = noab+1,noab+nvab
338      DO h3b = 1,noab
339      IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h3b-1)) THEN
340      IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH
341     &EN
342      CALL TCE_RESTRICTED_2(p4b,h3b,p4b_1,h3b_1)
343      CALL TCE_RESTRICTED_4(p2b,h3b,h1b,p4b,p2b_2,h3b_2,h1b_2,p4b_2)
344      dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h3b-1)
345      dima_sort = 1
346      dima = dim_common * dima_sort
347      dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
348      dimb = dim_common * dimb_sort
349      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
350      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
351     & ERRQUIT('cis_x1_3',1,MA_ERR)
352      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
353     &cis_x1_3',2,MA_ERR)
354      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1
355     & - 1 + noab * (p4b_1 - noab - 1)))
356      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1)
357     &,int_mb(k_range+h3b-1),2,1,1.0d0)
358      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cis_x1_3',3,MA_ERR)
359      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
360     & ERRQUIT('cis_x1_3',4,MA_ERR)
361      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
362     &cis_x1_3',5,MA_ERR)
363      IF ((h3b .le. p2b) .and. (h1b .le. p4b)) THEN
364      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
365     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
366     &+nvab) * (h3b_2 - 1)))))
367      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
368     &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1)
369     &,3,2,1,4,1.0d0)
370      END IF
371      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cis_x1_3',6,MA_ERR)
372      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
373     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
374     &t),dima_sort)
375      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cis_x1_3',7,MA_ERR)
376      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cis_x1_3',8,MA_ERR)
377      END IF
378      END IF
379      END IF
380      END DO
381      END DO
382      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
383     &cis_x1_3',9,MA_ERR)
384      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
385     &,int_mb(k_range+p2b-1),2,1,-1.0d0)
386      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
387     & 1 + noab * (p2b - noab - 1)))
388      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cis_x1_3',10,MA_ERR)
389      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cis_x1_3',11,MA_ERR
390     &)
391      END IF
392      END IF
393      END IF
394      next = nxtask(nprocs,1)
395      END IF
396      count = count + 1
397      END DO
398      END DO
399      next = nxtask(-nprocs,1)
400      call GA_SYNC()
401      RETURN
402      END
403