1      SUBROUTINE ccsdt_lr_alpha_offdiag_15_27_8_2_1(d_a,k_a_offset,d_b,k
2     &_b_offset,d_c,k_c_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     i4 ( h2 h9 h10 h15 p3 p7 )_yc + = -1 * Sum ( p5 ) * c ( p5 h15 )_c * y ( h2 h9 h10 p3 p5 p7 )_y
7      IMPLICIT NONE
8#include "global.fh"
9#include "mafdecls.fh"
10#include "sym.fh"
11#include "errquit.fh"
12#include "tce.fh"
13      INTEGER d_a
14      INTEGER k_a_offset
15      INTEGER d_b
16      INTEGER k_b_offset
17      INTEGER d_c
18      INTEGER k_c_offset
19      INTEGER nxtask
20      INTEGER next
21      INTEGER nprocs
22      INTEGER count
23      INTEGER h2b
24      INTEGER h9b
25      INTEGER h10b
26      INTEGER h15b
27      INTEGER p3b
28      INTEGER p7b
29      INTEGER dimc
30      INTEGER l_c_sort
31      INTEGER k_c_sort
32      INTEGER p5b
33      INTEGER p5b_1
34      INTEGER h15b_1
35      INTEGER h2b_2
36      INTEGER h9b_2
37      INTEGER h10b_2
38      INTEGER p3b_2
39      INTEGER p7b_2
40      INTEGER p5b_2
41      INTEGER dim_common
42      INTEGER dima_sort
43      INTEGER dima
44      INTEGER dimb_sort
45      INTEGER dimb
46      INTEGER l_a_sort
47      INTEGER k_a_sort
48      INTEGER l_a
49      INTEGER k_a
50      INTEGER l_b_sort
51      INTEGER k_b_sort
52      INTEGER l_b
53      INTEGER k_b
54      INTEGER l_c
55      INTEGER k_c
56      EXTERNAL nxtask
57      nprocs = GA_NNODES()
58      count = 0
59      next = nxtask(nprocs,1)
60      DO h2b = 1,noab
61      DO h9b = h2b,noab
62      DO h10b = h9b,noab
63      DO h15b = 1,noab
64      DO p3b = noab+1,noab+nvab
65      DO p7b = p3b,noab+nvab
66      IF (next.eq.count) THEN
67      IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h9b-1
68     &)+int_mb(k_spin+h10b-1)+int_mb(k_spin+h15b-1)+int_mb(k_spin+p3b-1)
69     &+int_mb(k_spin+p7b-1).ne.12)) THEN
70      IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1
71     &) .eq. int_mb(k_spin+h15b-1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p7
72     &b-1)) THEN
73      IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb(
74     &k_sym+h10b-1),ieor(int_mb(k_sym+h15b-1),ieor(int_mb(k_sym+p3b-1),i
75     &nt_mb(k_sym+p7b-1)))))) .eq. ieor(irrep_y,irrep_c)) THEN
76      dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra
77     &nge+h10b-1) * int_mb(k_range+h15b-1) * int_mb(k_range+p3b-1) * int
78     &_mb(k_range+p7b-1)
79      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
80     & ERRQUIT('ccsdt_lr_alpha_offdiag_15_27_8_2_1',0,MA_ERR)
81      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
82      DO p5b = noab+1,noab+nvab
83      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h15b-1)) THEN
84      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h15b-1)) .eq. irrep_c) T
85     &HEN
86      CALL TCE_RESTRICTED_2(p5b,h15b,p5b_1,h15b_1)
87      CALL TCE_RESTRICTED_6(h2b,h9b,h10b,p3b,p7b,p5b,h2b_2,h9b_2,h10b_2,
88     &p3b_2,p7b_2,p5b_2)
89      dim_common = int_mb(k_range+p5b-1)
90      dima_sort = int_mb(k_range+h15b-1)
91      dima = dim_common * dima_sort
92      dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+h9b-1) * int_mb
93     &(k_range+h10b-1) * int_mb(k_range+p3b-1) * int_mb(k_range+p7b-1)
94      dimb = dim_common * dimb_sort
95      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
96      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
97     & ERRQUIT('ccsdt_lr_alpha_offdiag_15_27_8_2_1',1,MA_ERR)
98      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
99     &ccsdt_lr_alpha_offdiag_15_27_8_2_1',2,MA_ERR)
100      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h15b_
101     &1 - 1 + noab * (p5b_1 - noab - 1)))
102      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
103     &,int_mb(k_range+h15b-1),2,1,1.0d0)
104      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1
105     &5_27_8_2_1',3,MA_ERR)
106      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
107     & ERRQUIT('ccsdt_lr_alpha_offdiag_15_27_8_2_1',4,MA_ERR)
108      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
109     &ccsdt_lr_alpha_offdiag_15_27_8_2_1',5,MA_ERR)
110      IF ((p5b .lt. p3b)) THEN
111      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
112     & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (p5b_2 - noab - 1
113     &+ nvab * (h10b_2 - 1 + noab * (h9b_2 - 1 + noab * (h2b_2 - 1))))))
114     &)
115      CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
116     &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+p5b-1
117     &),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1),6,5,3,2,1,4,-1.0d0)
118      END IF
119      IF ((p3b .le. p5b) .and. (p5b .le. p7b)) THEN
120      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
121     & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p3b_2 - noab - 1
122     &+ nvab * (h10b_2 - 1 + noab * (h9b_2 - 1 + noab * (h2b_2 - 1))))))
123     &)
124      CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
125     &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+p3b-1
126     &),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1),6,4,3,2,1,5,1.0d0)
127      END IF
128      IF ((p7b .lt. p5b)) THEN
129      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
130     & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p3b_2 - noab - 1
131     &+ nvab * (h10b_2 - 1 + noab * (h9b_2 - 1 + noab * (h2b_2 - 1))))))
132     &)
133      CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
134     &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+p3b-1
135     &),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1),5,4,3,2,1,6,-1.0d0)
136      END IF
137      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1
138     &5_27_8_2_1',6,MA_ERR)
139      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
140     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
141     &t),dima_sort)
142      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd
143     &iag_15_27_8_2_1',7,MA_ERR)
144      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd
145     &iag_15_27_8_2_1',8,MA_ERR)
146      END IF
147      END IF
148      END IF
149      END DO
150      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
151     &ccsdt_lr_alpha_offdiag_15_27_8_2_1',9,MA_ERR)
152      CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p7b-1)
153     &,int_mb(k_range+p3b-1),int_mb(k_range+h10b-1),int_mb(k_range+h9b-1
154     &),int_mb(k_range+h2b-1),int_mb(k_range+h15b-1),5,4,3,6,2,1,-1.0d0)
155      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b -
156     & noab - 1 + nvab * (p3b - noab - 1 + nvab * (h15b - 1 + noab * (h1
157     &0b - 1 + noab * (h9b - 1 + noab * (h2b - 1)))))))
158      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1
159     &5_27_8_2_1',10,MA_ERR)
160      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd
161     &iag_15_27_8_2_1',11,MA_ERR)
162      END IF
163      END IF
164      END IF
165      next = nxtask(nprocs,1)
166      END IF
167      count = count + 1
168      END DO
169      END DO
170      END DO
171      END DO
172      END DO
173      END DO
174      next = nxtask(-nprocs,1)
175      call GA_SYNC()
176      RETURN
177      END
178