1      SUBROUTINE ccsdt_lambda2_12_1(d_a,k_a_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 ( p11 p13 h12 p1 )_v + = -1 * v ( p11 p13 h12 p1 )_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_c
15      INTEGER k_c_offset
16      INTEGER NXTASK
17      INTEGER next
18      INTEGER nprocs
19      INTEGER count
20      INTEGER p11b
21      INTEGER p13b
22      INTEGER p1b
23      INTEGER h12b
24      INTEGER dimc
25      INTEGER p11b_1
26      INTEGER p13b_1
27      INTEGER p1b_1
28      INTEGER h12b_1
29      INTEGER dim_common
30      INTEGER dima_sort
31      INTEGER dima
32      INTEGER l_a_sort
33      INTEGER k_a_sort
34      INTEGER l_a
35      INTEGER k_a
36      INTEGER l_c
37      INTEGER k_c
38      EXTERNAL NXTASK
39      nprocs = GA_NNODES()
40      count = 0
41      next = NXTASK(nprocs,1)
42      DO p11b = noab+1,noab+nvab
43      DO p13b = p11b,noab+nvab
44      DO p1b = noab+1,noab+nvab
45      DO h12b = 1,noab
46      IF (next.eq.count) THEN
47      IF ((.not.restricted).or.(int_mb(k_spin+p11b-1)+int_mb(k_spin+p13b
48     &-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+h12b-1).ne.8)) THEN
49      IF (int_mb(k_spin+p11b-1)+int_mb(k_spin+p13b-1) .eq. int_mb(k_spin
50     &+p1b-1)+int_mb(k_spin+h12b-1)) THEN
51      IF (ieor(int_mb(k_sym+p11b-1),ieor(int_mb(k_sym+p13b-1),ieor(int_m
52     &b(k_sym+p1b-1),int_mb(k_sym+h12b-1)))) .eq. irrep_v) THEN
53      dimc = int_mb(k_range+p11b-1) * int_mb(k_range+p13b-1) * int_mb(k_
54     &range+p1b-1) * int_mb(k_range+h12b-1)
55      CALL TCE_RESTRICTED_4(p11b,p13b,p1b,h12b,p11b_1,p13b_1,p1b_1,h12b_
56     &1)
57      dim_common = 1
58      dima_sort = int_mb(k_range+p11b-1) * int_mb(k_range+p13b-1) * int_
59     &mb(k_range+p1b-1) * int_mb(k_range+h12b-1)
60      dima = dim_common * dima_sort
61      IF (dima .gt. 0) THEN
62      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
63     & ERRQUIT('ccsdt_lambda2_12_1',0,MA_ERR)
64      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
65     &ccsdt_lambda2_12_1',1,MA_ERR)
66      IF ((h12b .le. p1b)) THEN
67      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1
68     & - 1 + (noab+nvab) * (h12b_1 - 1 + (noab+nvab) * (p13b_1 - 1 + (no
69     &ab+nvab) * (p11b_1 - 1)))))
70      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p11b-1
71     &),int_mb(k_range+p13b-1),int_mb(k_range+h12b-1),int_mb(k_range+p1b
72     &-1),3,4,2,1,1.0d0)
73      END IF
74      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_lambda2_12_1',2,MA
75     &_ERR)
76      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
77     &ccsdt_lambda2_12_1',3,MA_ERR)
78      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h12b-1
79     &),int_mb(k_range+p1b-1),int_mb(k_range+p13b-1),int_mb(k_range+p11b
80     &-1),4,3,2,1,-1.0d0)
81      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h12b
82     &- 1 + noab * (p1b - noab - 1 + nvab * (p13b - noab - 1 + nvab * (p
83     &11b - noab - 1)))))
84      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_lambda2_12_1',4,MA
85     &_ERR)
86      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_lambda2_12_1'
87     &,5,MA_ERR)
88      END IF
89      END IF
90      END IF
91      END IF
92      next = NXTASK(nprocs,1)
93      END IF
94      count = count + 1
95      END DO
96      END DO
97      END DO
98      END DO
99      next = NXTASK(-nprocs,1)
100      call GA_SYNC()
101      RETURN
102      END
103