1      SUBROUTINE ccsdt_lr_alpha_offdiag_15_21_1_1(d_a,k_a_offset,d_b,k_b
2     &_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     i3 ( h3 h4 h7 h15 p1 p5 )_yt + = -1 * Sum ( p9 ) * t ( p9 h15 )_t * y ( h3 h4 h7 p1 p5 p9 )_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 h3b
24      INTEGER h4b
25      INTEGER h7b
26      INTEGER h15b
27      INTEGER p1b
28      INTEGER p5b
29      INTEGER dimc
30      INTEGER l_c_sort
31      INTEGER k_c_sort
32      INTEGER p9b
33      INTEGER p9b_1
34      INTEGER h15b_1
35      INTEGER h3b_2
36      INTEGER h4b_2
37      INTEGER h7b_2
38      INTEGER p1b_2
39      INTEGER p5b_2
40      INTEGER p9b_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 h3b = 1,noab
61      DO h4b = h3b,noab
62      DO h7b = h4b,noab
63      DO h15b = 1,noab
64      DO p1b = noab+1,noab+nvab
65      DO p5b = p1b,noab+nvab
66      IF (next.eq.count) THEN
67      IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1
68     &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+h15b-1)+int_mb(k_spin+p1b-1)+
69     &int_mb(k_spin+p5b-1).ne.12)) THEN
70      IF (int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)+int_mb(k_spin+h7b-1)
71     & .eq. int_mb(k_spin+h15b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p5b
72     &-1)) THEN
73      IF (ieor(int_mb(k_sym+h3b-1),ieor(int_mb(k_sym+h4b-1),ieor(int_mb(
74     &k_sym+h7b-1),ieor(int_mb(k_sym+h15b-1),ieor(int_mb(k_sym+p1b-1),in
75     &t_mb(k_sym+p5b-1)))))) .eq. ieor(irrep_y,irrep_t)) THEN
76      dimc = int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) * int_mb(k_ra
77     &nge+h7b-1) * int_mb(k_range+h15b-1) * int_mb(k_range+p1b-1) * int_
78     &mb(k_range+p5b-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_21_1_1',0,MA_ERR)
81      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
82      DO p9b = noab+1,noab+nvab
83      IF (int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h15b-1)) THEN
84      IF (ieor(int_mb(k_sym+p9b-1),int_mb(k_sym+h15b-1)) .eq. irrep_t) T
85     &HEN
86      CALL TCE_RESTRICTED_2(p9b,h15b,p9b_1,h15b_1)
87      CALL TCE_RESTRICTED_6(h3b,h4b,h7b,p1b,p5b,p9b,h3b_2,h4b_2,h7b_2,p1
88     &b_2,p5b_2,p9b_2)
89      dim_common = int_mb(k_range+p9b-1)
90      dima_sort = int_mb(k_range+h15b-1)
91      dima = dim_common * dima_sort
92      dimb_sort = int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) * int_mb
93     &(k_range+h7b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+p5b-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_21_1_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_21_1_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 * (p9b_1 - noab - 1)))
102      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-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_21_1_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_21_1_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_21_1_1',5,MA_ERR)
110      IF ((p9b .lt. p1b)) THEN
111      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
112     & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (p9b_2 - noab - 1
113     &+ nvab * (h7b_2 - 1 + noab * (h4b_2 - 1 + noab * (h3b_2 - 1)))))))
114      CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
115     &,int_mb(k_range+h4b-1),int_mb(k_range+h7b-1),int_mb(k_range+p9b-1)
116     &,int_mb(k_range+p1b-1),int_mb(k_range+p5b-1),6,5,3,2,1,4,1.0d0)
117      END IF
118      IF ((p1b .le. p9b) .and. (p9b .lt. p5b)) THEN
119      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
120     & - noab - 1 + nvab * (p9b_2 - noab - 1 + nvab * (p1b_2 - noab - 1
121     &+ nvab * (h7b_2 - 1 + noab * (h4b_2 - 1 + noab * (h3b_2 - 1)))))))
122      CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
123     &,int_mb(k_range+h4b-1),int_mb(k_range+h7b-1),int_mb(k_range+p1b-1)
124     &,int_mb(k_range+p9b-1),int_mb(k_range+p5b-1),6,4,3,2,1,5,-1.0d0)
125      END IF
126      IF ((p5b .le. p9b)) THEN
127      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
128     & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p1b_2 - noab - 1
129     &+ nvab * (h7b_2 - 1 + noab * (h4b_2 - 1 + noab * (h3b_2 - 1)))))))
130      CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
131     &,int_mb(k_range+h4b-1),int_mb(k_range+h7b-1),int_mb(k_range+p1b-1)
132     &,int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),5,4,3,2,1,6,1.0d0)
133      END IF
134      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1
135     &5_21_1_1',6,MA_ERR)
136      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
137     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
138     &t),dima_sort)
139      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd
140     &iag_15_21_1_1',7,MA_ERR)
141      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd
142     &iag_15_21_1_1',8,MA_ERR)
143      END IF
144      END IF
145      END IF
146      END DO
147      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
148     &ccsdt_lr_alpha_offdiag_15_21_1_1',9,MA_ERR)
149      CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
150     &,int_mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h4b-1)
151     &,int_mb(k_range+h3b-1),int_mb(k_range+h15b-1),5,4,3,6,2,1,-1.0d0)
152      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
153     & noab - 1 + nvab * (p1b - noab - 1 + nvab * (h15b - 1 + noab * (h7
154     &b - 1 + noab * (h4b - 1 + noab * (h3b - 1)))))))
155      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1
156     &5_21_1_1',10,MA_ERR)
157      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd
158     &iag_15_21_1_1',11,MA_ERR)
159      END IF
160      END IF
161      END IF
162      next = nxtask(nprocs,1)
163      END IF
164      count = count + 1
165      END DO
166      END DO
167      END DO
168      END DO
169      END DO
170      END DO
171      next = nxtask(-nprocs,1)
172      call GA_SYNC()
173      RETURN
174      END
175