1      SUBROUTINE alpha_1_1_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 ( p2 h1 )_tr + = 1 * tr ( p2 h1 )_tr
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 p2b
21      INTEGER h1b
22      INTEGER dimc
23      INTEGER p2b_1
24      INTEGER h1b_1
25      INTEGER dim_common
26      INTEGER dima_sort
27      INTEGER dima
28      INTEGER l_a_sort
29      INTEGER k_a_sort
30      INTEGER l_a
31      INTEGER k_a
32      INTEGER l_c
33      INTEGER k_c
34      EXTERNAL NXTASK
35      nprocs = GA_NNODES()
36      count = 0
37      next = NXTASK(nprocs,1)
38      DO p2b = noab+1,noab+nvab
39      DO h1b = 1,noab
40      IF (next.eq.count) THEN
41      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
42     &).ne.4)) THEN
43      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
44      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. irrep_tr) T
45     &HEN
46      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
47      CALL TCE_RESTRICTED_2(p2b,h1b,p2b_1,h1b_1)
48      dim_common = 1
49      dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
50      dima = dim_common * dima_sort
51      IF (dima .gt. 0) THEN
52      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
53     & ERRQUIT('alpha_1_1_1',0,MA_ERR)
54      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
55     &alpha_1_1_1',1,MA_ERR)
56      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
57     & - 1 + noab * (p2b_1 - noab - 1)))
58      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1)
59     &,int_mb(k_range+h1b-1),2,1,1.0d0)
60      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('alpha_1_1_1',2,MA_ERR)
61      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
62     &alpha_1_1_1',3,MA_ERR)
63      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
64     &,int_mb(k_range+p2b-1),2,1,1.0d0)
65      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
66     & 1 + noab * (p2b - noab - 1)))
67      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('alpha_1_1_1',4,MA_ERR)
68      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('alpha_1_1_1',5,MA_E
69     &RR)
70      END IF
71      END IF
72      END IF
73      END IF
74      next = NXTASK(nprocs,1)
75      END IF
76      count = count + 1
77      END DO
78      END DO
79      next = NXTASK(-nprocs,1)
80      call GA_SYNC()
81      RETURN
82      END
83