1      SUBROUTINE dip_r_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
2C     $Id$
3C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
4C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
5C     i1 ( h6 p5 )_vtr + = 1 * Sum ( h4 p3 ) * tr ( p3 h4 )_tr * v ( h4 h6 p3 p5 )_v
6      IMPLICIT NONE
7#include "global.fh"
8#include "mafdecls.fh"
9#include "sym.fh"
10#include "errquit.fh"
11#include "tce.fh"
12      INTEGER d_a
13      INTEGER k_a_offset
14      INTEGER d_b
15      INTEGER k_b_offset
16      INTEGER d_c
17      INTEGER k_c_offset
18      INTEGER NXTASK
19      INTEGER next
20      INTEGER nprocs
21      INTEGER count
22      INTEGER h6b
23      INTEGER p5b
24      INTEGER dimc
25      INTEGER l_c_sort
26      INTEGER k_c_sort
27      INTEGER p3b
28      INTEGER h4b
29      INTEGER p3b_1
30      INTEGER h4b_1
31      INTEGER h6b_2
32      INTEGER h4b_2
33      INTEGER p5b_2
34      INTEGER p3b_2
35      INTEGER dim_common
36      INTEGER dima_sort
37      INTEGER dima
38      INTEGER dimb_sort
39      INTEGER dimb
40      INTEGER l_a_sort
41      INTEGER k_a_sort
42      INTEGER l_a
43      INTEGER k_a
44      INTEGER l_b_sort
45      INTEGER k_b_sort
46      INTEGER l_b
47      INTEGER k_b
48      INTEGER l_c
49      INTEGER k_c
50      EXTERNAL NXTASK
51      nprocs = GA_NNODES()
52      count = 0
53      next = NXTASK(nprocs,1)
54      DO h6b = 1,noab
55      DO p5b = noab+1,noab+nvab
56      IF (next.eq.count) THEN
57      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p5b-1
58     &).ne.4)) THEN
59      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p5b-1)) THEN
60      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
61     &v,irrep_tr)) THEN
62      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1)
63      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
64     & ERRQUIT('dip_r_1_2',0,MA_ERR)
65      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
66      DO p3b = noab+1,noab+nvab
67      DO h4b = 1,noab
68      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN
69      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_tr) T
70     &HEN
71      CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1)
72      CALL TCE_RESTRICTED_4(h6b,h4b,p5b,p3b,h6b_2,h4b_2,p5b_2,p3b_2)
73      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1)
74      dima_sort = 1
75      dima = dim_common * dima_sort
76      dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1)
77      dimb = dim_common * dimb_sort
78      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
79      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
80     & ERRQUIT('dip_r_1_2',1,MA_ERR)
81      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
82     &dip_r_1_2',2,MA_ERR)
83      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1
84     & - 1 + noab * (p3b_1 - noab - 1)))
85      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
86     &,int_mb(k_range+h4b-1),2,1,1.0d0)
87      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('dip_r_1_2',3,MA_ERR)
88      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
89     & ERRQUIT('dip_r_1_2',4,MA_ERR)
90      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
91     &dip_r_1_2',5,MA_ERR)
92      IF ((h4b .le. h6b) .and. (p3b .le. p5b)) THEN
93      if(.not.intorb) then
94      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
95     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
96     &+nvab) * (h4b_2 - 1)))))
97      else
98      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
99     &(p5b_2
100     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
101     &+nvab) * (h4b_2 - 1)))),p5b_2,p3b_2,h6b_2,h4b_2)
102      end if
103      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
104     &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1)
105     &,4,2,1,3,1.0d0)
106      END IF
107      IF ((h4b .le. h6b) .and. (p5b .lt. p3b)) THEN
108      if(.not.intorb) then
109      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
110     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
111     &+nvab) * (h4b_2 - 1)))))
112      else
113      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
114     &(p3b_2
115     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
116     &+nvab) * (h4b_2 - 1)))),p3b_2,p5b_2,h6b_2,h4b_2)
117      end if
118      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
119     &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1)
120     &,3,2,1,4,-1.0d0)
121      END IF
122      IF ((h6b .lt. h4b) .and. (p3b .le. p5b)) THEN
123      if(.not.intorb) then
124      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
125     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
126     &+nvab) * (h6b_2 - 1)))))
127      else
128      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
129     &(p5b_2
130     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
131     &+nvab) * (h6b_2 - 1)))),p5b_2,p3b_2,h4b_2,h6b_2)
132      end if
133      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
134     &,int_mb(k_range+h4b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1)
135     &,4,1,2,3,-1.0d0)
136      END IF
137      IF ((h6b .lt. h4b) .and. (p5b .lt. p3b)) THEN
138      if(.not.intorb) then
139      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
140     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
141     &+nvab) * (h6b_2 - 1)))))
142      else
143      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
144     &(p3b_2
145     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
146     &+nvab) * (h6b_2 - 1)))),p3b_2,p5b_2,h4b_2,h6b_2)
147      end if
148      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
149     &,int_mb(k_range+h4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1)
150     &,3,1,2,4,1.0d0)
151      END IF
152      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('dip_r_1_2',6,MA_ERR)
153      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
154     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
155     &t),dima_sort)
156      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('dip_r_1_2',7,MA_ERR
157     &)
158      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('dip_r_1_2',8,MA_ERR
159     &)
160      END IF
161      END IF
162      END IF
163      END DO
164      END DO
165      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
166     &dip_r_1_2',9,MA_ERR)
167      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
168     &,int_mb(k_range+h6b-1),2,1,1.0d0)
169      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
170     & noab - 1 + nvab * (h6b - 1)))
171      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('dip_r_1_2',10,MA_ERR)
172      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('dip_r_1_2',11,MA_ER
173     &R)
174      END IF
175      END IF
176      END IF
177      next = NXTASK(nprocs,1)
178      END IF
179      count = count + 1
180      END DO
181      END DO
182      next = NXTASK(-nprocs,1)
183      call GA_SYNC()
184      RETURN
185      END
186