← Back to branch summary

~ubuntu-branches/ubuntu/saucy/nwchem/saucy

« back to all changes in this revision

Viewing changes to src/tce/ccsd/ccsd_t1_loc.F

  • Committer: Package Import Robot
  • Author(s): Michael Banck, Michael Banck, Daniel Leidert
  • Date: 2012-02-09 20:02:41 UTC
  • mfrom: (1.1.1)
  • Revision ID: package-import@ubuntu.com-20120209200241-jgk03qfsphal4ug2
Tags: 6.1-1
http://bugs.debian.org/632611
https://launchpad.net/bugs/791308
* New upstream release.

[ Michael Banck ]
* debian/patches/02_makefile_flags.patch: Updated.
* debian/patches/02_makefile_flags.patch: Use internal blas and lapack code.
* debian/patches/02_makefile_flags.patch: Define GCC4 for LINUX and LINUX64
  (Closes: #632611 and LP: #791308).
* debian/control (Build-Depends): Added openssh-client.
* debian/rules (USE_SCALAPACK, SCALAPACK): Removed variables (Closes:
  #654658).
* debian/rules (LIBDIR, USE_MPIF4, ARMCI_NETWORK): New variables.
* debian/TODO: New file.
* debian/control (Build-Depends): Removed libblas-dev, liblapack-dev and
  libscalapack-mpi-dev.
* debian/patches/04_show_testsuite_diff_output.patch: New patch, shows the
  diff output for failed tests.
* debian/patches/series: Adjusted.
* debian/testsuite: Optionally run all tests if "all" is passed as option.
* debian/rules: Run debian/testsuite with "all" if DEB_BUILD_OPTIONS
  contains "checkall".

[ Daniel Leidert ]
* debian/control: Used wrap-and-sort. Added Vcs-Svn and Vcs-Browser fields.
  (Priority): Moved to extra according to policy section 2.5.
  (Standards-Version): Bumped to 3.9.2.
  (Description): Fixed a typo.
* debian/watch: Added.
* debian/patches/03_hurd-i386_define_path_max.patch: Added.
  - Define MAX_PATH if not defines to fix FTBFS on hurd.
* debian/patches/series: Adjusted.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/tce/ccsd/ccsd_t1_loc.F
1
 
      SUBROUTINE ccsd_t1(d_f1,d_i0,d_t1,d_t2,d_v2,k_f1_offset,k_i0_offse
2
 
     &t,k_t1_offset,k_t2_offset,k_v2_offset)
3
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
4
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
5
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
6
 
C     i0 ( p2 h1 )_f + = 1 * f ( p2 h1 )_f                                                         DONE
7
 
C     i0 ( p2 h1 )_tf + = -1 * Sum ( h7 ) * t ( p2 h7 )_t * i1 ( h7 h1 )_f                         DONE
8
 
C         i1 ( h7 h1 )_f + = 1 * f ( h7 h1 )_f                                                     DONE
9
 
C         i1 ( h7 h1 )_ft + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * i2 ( h7 p3 )_f                      DONE
10
 
C             i2 ( h7 p3 )_f + = 1 * f ( h7 p3 )_f                                                 DONE
11
 
C             i2 ( h7 p3 )_vt + = -1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 h7 p3 p5 )_v         DONE
12
 
C         i1 ( h7 h1 )_vt + = -1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 h7 h1 p4 )_v             NOPE
13
 
C         i1 ( h7 h1 )_vt + = -1/2 * Sum ( h5 p3 p4 ) * t ( p3 p4 h1 h5 )_t * v ( h5 h7 p3 p4 )_v  NOPE
14
 
C     i0 ( p2 h1 )_tf + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * i1 ( p2 p3 )_f                          DONE
15
 
C         i1 ( p2 p3 )_f + = 1 * f ( p2 p3 )_f                                                     DONE
16
 
C         i1 ( p2 p3 )_vt + = -1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 p2 p3 p4 )_v             NOPE
17
 
C     i0 ( p2 h1 )_vt + = -1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 p2 h1 p3 )_v                 NOPE
18
 
C     i0 ( p2 h1 )_tf + = 1 * Sum ( p7 h8 ) * t ( p2 p7 h1 h8 )_t * i1 ( h8 p7 )_f                 DONE
19
 
C         i1 ( h8 p7 )_f + = 1 * f ( h8 p7 )_f                                                     DONE
20
 
C         i1 ( h8 p7 )_vt + = 1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 h8 p5 p7 )_v              NOPE
21
 
C     i0 ( p2 h1 )_vt + = -1/2 * Sum ( h4 h5 p3 ) * t ( p2 p3 h4 h5 )_t * i1 ( h4 h5 h1 p3 )_v     NOPE
22
 
C         i1 ( h4 h5 h1 p3 )_v + = 1 * v ( h4 h5 h1 p3 )_v                                         DONE
23
 
C         i1 ( h4 h5 h1 p3 )_vt + = -1 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h4 h5 p3 p6 )_v          NOPE
24
 
C     i0 ( p2 h1 )_vt + = -1/2 * Sum ( h5 p3 p4 ) * t ( p3 p4 h1 h5 )_t * v ( h5 p2 p3 p4 )_v      DONE
25
 
      IMPLICIT NONE
26
 
#include "global.fh"
27
 
#include "mafdecls.fh"
28
 
#include "util.fh"
29
 
#include "errquit.fh"
30
 
#include "tce.fh"
31
 
c when local copies of  T1/X1 tensors are used,  d_t1 refers to k_t1_local (kk)
32
 
      INTEGER d_i0
33
 
      INTEGER k_i0_offset
34
 
      INTEGER d_f1
35
 
      INTEGER k_f1_offset
36
 
      INTEGER d_t1
37
 
      INTEGER k_t1_offset
38
 
      INTEGER d_i1
39
 
      INTEGER k_i1_offset
40
 
      INTEGER d_v2
41
 
      INTEGER k_v2_offset
42
 
      INTEGER d_t2
43
 
      INTEGER k_t2_offset
44
 
      INTEGER l_i1_offset
45
 
      INTEGER size_i1
46
 
      INTEGER d_i2
47
 
      INTEGER k_i2_offset
48
 
      INTEGER l_i2_offset
49
 
      INTEGER size_i2
50
 
      CHARACTER*255 filename
51
 
c --- PETA -----------------------
52
 
      logical nodezero
53
 
      double precision cpu     ! CPU sec counter
54
 
      double precision wall    ! WALL sec counter
55
 
      nodezero=(ga_nodeid().eq.0)
56
 
c --------------------------------
57
 
      CALL ccsd_t1_1(d_f1,k_f1_offset,d_i0,k_i0_offset)
58
 
      CALL OFFSET_ccsd_t1_2_1(l_i1_offset,k_i1_offset,size_i1)
59
 
      CALL TCE_FILENAME('ccsd_t1_2_1_i1',filename)
60
 
      CALL CREATEFILE(filename,d_i1,size_i1)
61
 
      CALL ccsd_t1_2_1(d_f1,k_f1_offset,d_i1,k_i1_offset)
62
 
      CALL OFFSET_ccsd_t1_2_2_1(l_i2_offset,k_i2_offset,size_i2)
63
 
      CALL TCE_FILENAME('ccsd_t1_2_2_1_i2',filename)
64
 
      CALL CREATEFILE(filename,d_i2,size_i2)
65
 
      CALL ccsd_t1_2_2_1(d_f1,k_f1_offset,d_i2,k_i2_offset)
66
 
      CALL ccsd_t1_2_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,
67
 
     1                   d_i2,k_i2_offset)
68
 
      CALL RECONCILEFILE(d_i2,size_i2)
69
 
      CALL ccsd_t1_2_2(d_t1,k_t1_offset,d_i2,k_i2_offset,
70
 
     1                 d_i1,k_i1_offset)
71
 
      CALL DELETEFILE(d_i2)
72
 
      IF (.not.MA_POP_STACK(l_i2_offset))
73
 
     1     CALL ERRQUIT('ccsd_t1',-1,MA_ERR)
74
 
      CALL ccsd_t1_2_3(d_t1,k_t1_offset,d_v2,k_v2_offset,
75
 
     1                 d_i1,k_i1_offset)
76
 
      CALL ccsd_t1_2_4(d_t2,k_t2_offset,d_v2,k_v2_offset,
77
 
     1                 d_i1,k_i1_offset)
78
 
      CALL RECONCILEFILE(d_i1,size_i1)
79
 
      CALL ccsd_t1_2(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
80
 
      CALL DELETEFILE(d_i1)
81
 
      IF (.not.MA_POP_STACK(l_i1_offset))
82
 
     1     CALL ERRQUIT('ccsd_t1',-1,MA_ERR)
83
 
      CALL OFFSET_ccsd_t1_3_1(l_i1_offset,k_i1_offset,size_i1)
84
 
      CALL TCE_FILENAME('ccsd_t1_3_1_i1',filename)
85
 
      CALL CREATEFILE(filename,d_i1,size_i1)
86
 
      CALL ccsd_t1_3_1(d_f1,k_f1_offset,d_i1,k_i1_offset)
87
 
      CALL ccsd_t1_3_2(d_t1,k_t1_offset,d_v2,k_v2_offset,
88
 
     1                 d_i1,k_i1_offset)
89
 
      CALL RECONCILEFILE(d_i1,size_i1)
90
 
      CALL ccsd_t1_3(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
91
 
      CALL DELETEFILE(d_i1)
92
 
      IF (.not.MA_POP_STACK(l_i1_offset))
93
 
     1     CALL ERRQUIT('ccsd_t1',-1,MA_ERR)
94
 
      CALL ccsd_t1_4(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i0,k_i0_offset)
95
 
      CALL OFFSET_ccsd_t1_5_1(l_i1_offset,k_i1_offset,size_i1)
96
 
      CALL TCE_FILENAME('ccsd_t1_5_1_i1',filename)
97
 
      CALL CREATEFILE(filename,d_i1,size_i1)
98
 
      CALL ccsd_t1_5_1(d_f1,k_f1_offset,d_i1,k_i1_offset)
99
 
      CALL ccsd_t1_5_2(d_t1,k_t1_offset,d_v2,k_v2_offset,
100
 
     1                 d_i1,k_i1_offset)
101
 
      CALL RECONCILEFILE(d_i1,size_i1)
102
 
      CALL ccsd_t1_5(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
103
 
      CALL DELETEFILE(d_i1)
104
 
      IF (.not.MA_POP_STACK(l_i1_offset))
105
 
     1     CALL ERRQUIT('ccsd_t1',-1,MA_ERR)
106
 
      CALL OFFSET_ccsd_t1_6_1(l_i1_offset,k_i1_offset,size_i1)
107
 
      CALL TCE_FILENAME('ccsd_t1_6_1_i1',filename)
108
 
      CALL CREATEFILE(filename,d_i1,size_i1)
109
 
      CALL ccsd_t1_6_1(d_v2,k_v2_offset,d_i1,k_i1_offset)
110
 
      CALL ccsd_t1_6_2(d_t1,k_t1_offset,d_v2,k_v2_offset,
111
 
     1                 d_i1,k_i1_offset)
112
 
      CALL RECONCILEFILE(d_i1,size_i1)
113
 
      CALL ccsd_t1_6(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
114
 
      CALL DELETEFILE(d_i1)
115
 
      IF (.not.MA_POP_STACK(l_i1_offset))
116
 
     1     CALL ERRQUIT('ccsd_t1',-1,MA_ERR)
117
 
      CALL ccsd_t1_7(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i0,k_i0_offset)
118
 
c --- PETA ----------
119
 
c 9020 format('DIAG-S',i3,1x,'Cpu & wall time / sec',2f15.1)
120
 
c -------------------
121
 
      RETURN
122
 
      END
123
 
 
124
 
 
125
 
 
126
 
 
127
 
      SUBROUTINE ccsd_t1_1(d_a,k_a_offset,d_c,k_c_offset)
128
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
129
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
130
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
131
 
C     i0 ( p2 h1 )_f + = 1 * f ( p2 h1 )_f
132
 
      IMPLICIT NONE
133
 
#include "global.fh"
134
 
#include "mafdecls.fh"
135
 
#include "sym.fh"
136
 
#include "errquit.fh"
137
 
#include "tce.fh"
138
 
      INTEGER d_a, d_c
139
 
      INTEGER k_a_offset, k_c_offset
140
 
      INTEGER NXTASK, next, nprocs, count
141
 
      INTEGER p2b, h1b, p2b_1, h1b_1
142
 
      INTEGER dim_common, dima_sort, dima, dimc
143
 
      INTEGER k_a, l_a
144
 
      EXTERNAL NXTASK
145
 
      nprocs = GA_NNODES()
146
 
      count = 0
147
 
      next = NXTASK(nprocs, 1)
148
 
      DO p2b = noab+1,noab+nvab
149
 
       DO h1b = 1,noab
150
 
        IF (next.eq.count) THEN
151
 
         IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)
152
 
     1                            +int_mb(k_spin+h1b-1).ne.4)) THEN
153
 
          IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
154
 
           IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) 
155
 
     1         .eq. irrep_f) THEN
156
 
            dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
157
 
            CALL TCE_RESTRICTED_2(p2b,h1b,p2b_1,h1b_1)
158
 
            dim_common = 1
159
 
            dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
160
 
            dima = dim_common * dima_sort
161
 
            IF (dima .gt. 0) THEN
162
 
             IF (.not.MA_PUSH_GET(mt_dbl,dima,'a',l_a,k_a)) 
163
 
     1            CALL ERRQUIT('ccsd_t1_1',1,MA_ERR)
164
 
             CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,
165
 
     1            int_mb(k_a_offset),
166
 
     2            (h1b_1 - 1 + (noab+nvab) * (p2b_1 - 1)))
167
 
             CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_a),dimc,
168
 
     1            int_mb(k_c_offset),
169
 
     2            (h1b - 1 + noab * (p2b - noab - 1)))
170
 
             IF (.not.MA_POP_STACK(l_a)) 
171
 
     1            CALL ERRQUIT('ccsd_t1_1',5,MA_ERR)
172
 
            END IF
173
 
           END IF
174
 
          END IF
175
 
         END IF
176
 
         next = NXTASK(nprocs, 1)
177
 
        END IF
178
 
        count = count + 1
179
 
       END DO
180
 
      END DO
181
 
      next = NXTASK(-nprocs, 1)
182
 
      call GA_SYNC()
183
 
      RETURN
184
 
      END
185
 
 
186
 
 
187
 
 
188
 
 
189
 
      SUBROUTINE ccsd_t1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
190
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
191
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
192
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
193
 
C     i0 ( p2 h1 )_tf + = -1 * Sum ( h7 ) * t ( p2 h7 )_t * i1 ( h7 h1 )_f
194
 
      IMPLICIT NONE
195
 
#include "global.fh"
196
 
#include "mafdecls.fh"
197
 
#include "sym.fh"
198
 
#include "errquit.fh"
199
 
#include "tce.fh"
200
 
      INTEGER d_a,d_b,d_c
201
 
      INTEGER k_a_offset,k_b_offset,k_c_offset
202
 
      INTEGER NXTASK,next,nprocs,count
203
 
      INTEGER p2b,h1b,h7b,p2b_1,h7b_1,h7b_2,h1b_2
204
 
      INTEGER dim_common,dima_sort,dimb_sort
205
 
      INTEGER dima,dimb,dimc
206
 
      INTEGER k_a,l_a,k_b,l_b,k_c,l_c
207
 
      INTEGER k_bs,l_bs,k_cs,l_cs
208
 
      EXTERNAL NXTASK
209
 
      nprocs = GA_NNODES()
210
 
      count = 0
211
 
      next = NXTASK(nprocs, 1)
212
 
      DO p2b = noab+1,noab+nvab
213
 
       DO h1b = 1,noab
214
 
        IF (next.eq.count) THEN
215
 
         IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)
216
 
     1                            +int_mb(k_spin+h1b-1).ne.4)) THEN
217
 
          IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
218
 
           IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)).eq.
219
 
     1         ieor(irrep_t,irrep_f)) THEN
220
 
            dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
221
 
            IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_cs,k_cs))
222
 
     1           CALL ERRQUIT('ccsd_t1_2',0,MA_ERR)
223
 
            CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1)
224
 
            DO h7b = 1,noab
225
 
             IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h7b-1)) THEN
226
 
              IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h7b-1)) 
227
 
     1            .eq. irrep_t) THEN
228
 
               CALL TCE_RESTRICTED_2(p2b,h7b,p2b_1,h7b_1)
229
 
               CALL TCE_RESTRICTED_2(h7b,h1b,h7b_2,h1b_2)
230
 
               dim_common = int_mb(k_range+h7b-1)
231
 
               dima_sort = int_mb(k_range+p2b-1)
232
 
               dima = dim_common * dima_sort
233
 
               dimb_sort = int_mb(k_range+h1b-1)
234
 
               dimb = dim_common * dimb_sort
235
 
               IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
236
 
                IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a))
237
 
     1               CALL ERRQUIT('ccsd_t1_2',2,MA_ERR)
238
 
                CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
239
 
     1               int_mb(k_a_offset),
240
 
     2               (h7b_1 - 1 + noab * (p2b_1 - noab - 1)))
241
 
                IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_bs,k_bs))
242
 
     1               CALL ERRQUIT('ccsd_t1_2',4,MA_ERR)
243
 
                IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b))
244
 
     1               CALL ERRQUIT('ccsd_t1_2',5,MA_ERR)
245
 
                CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,
246
 
     1               int_mb(k_b_offset),
247
 
     2               (h1b_2 - 1 + noab * (h7b_2 - 1)))
248
 
                CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_bs),
249
 
     1               int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),
250
 
     2               2,1,1.0d0)
251
 
                IF (.not.MA_POP_STACK(l_b))
252
 
     1               CALL ERRQUIT('ccsd_t1_2',6,MA_ERR)
253
 
                CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,
254
 
     1               dbl_mb(k_a),dim_common,dbl_mb(k_bs),dim_common,
255
 
     2               1.0d0,dbl_mb(k_cs),dima_sort)
256
 
                IF (.not.MA_POP_STACK(l_bs))
257
 
     1               CALL ERRQUIT('ccsd_t1_2',7,MA_ERR)
258
 
                IF (.not.MA_POP_STACK(l_a))
259
 
     1               CALL ERRQUIT('ccsd_t1_2',8,MA_ERR)
260
 
               END IF
261
 
              END IF
262
 
             END IF
263
 
            END DO
264
 
            IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c))
265
 
     1           CALL ERRQUIT('ccsd_t1_2',9,MA_ERR)
266
 
            CALL TCE_SORT_2(dbl_mb(k_cs),dbl_mb(k_c),
267
 
     1           int_mb(k_range+h1b-1),int_mb(k_range+p2b-1),
268
 
     2           2,1,-1.0d0)
269
 
            CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),
270
 
     1           (h1b - 1 + noab * (p2b - noab - 1)))
271
 
            IF (.not.MA_POP_STACK(l_c))
272
 
     1           CALL ERRQUIT('ccsd_t1_2',10,MA_ERR)
273
 
            IF (.not.MA_POP_STACK(l_cs))
274
 
     1           CALL ERRQUIT('ccsd_t1_2',11,MA_ERR)
275
 
           END IF
276
 
          END IF
277
 
         END IF
278
 
         next = NXTASK(nprocs, 1)
279
 
        END IF
280
 
        count = count + 1
281
 
       END DO
282
 
      END DO
283
 
      next = NXTASK(-nprocs, 1)
284
 
      call GA_SYNC()
285
 
      RETURN
286
 
      END
287
 
 
288
 
 
289
 
 
290
 
 
291
 
      SUBROUTINE ccsd_t1_2_1(d_a,k_a_offset,d_c,k_c_offset)
292
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
293
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
294
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
295
 
C     i1 ( h7 h1 )_f + = 1 * f ( h7 h1 )_f
296
 
      IMPLICIT NONE
297
 
#include "global.fh"
298
 
#include "mafdecls.fh"
299
 
#include "sym.fh"
300
 
#include "errquit.fh"
301
 
#include "tce.fh"
302
 
      INTEGER d_a, d_c
303
 
      INTEGER k_a_offset, k_c_offset
304
 
      INTEGER NXTASK, next, nprocs, count
305
 
      INTEGER h7b, h1b, h7b_1, h1b_1
306
 
      INTEGER dim_common, dima_sort, dima, dimc
307
 
      INTEGER k_as, l_as, k_a, l_a, k_c, l_c
308
 
      EXTERNAL NXTASK
309
 
      nprocs = GA_NNODES()
310
 
      count = 0
311
 
      next = NXTASK(nprocs, 1)
312
 
      DO h7b = 1,noab
313
 
       DO h1b = 1,noab
314
 
        IF (next.eq.count) THEN
315
 
         IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)
316
 
     1                            +int_mb(k_spin+h1b-1).ne.4)) THEN
317
 
          IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h1b-1)) THEN
318
 
           IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h1b-1)) 
319
 
     1         .eq. irrep_f) THEN
320
 
            dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h1b-1)
321
 
            CALL TCE_RESTRICTED_2(h7b,h1b,h7b_1,h1b_1)
322
 
            dim_common = 1
323
 
            dima_sort = int_mb(k_range+h7b-1) * int_mb(k_range+h1b-1)
324
 
            dima = dim_common * dima_sort
325
 
            IF (dima .gt. 0) THEN
326
 
             IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as))
327
 
     1            CALL ERRQUIT('ccsd_t1_2_1',0,MA_ERR)
328
 
             IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a))
329
 
     1            CALL ERRQUIT('ccsd_t1_2_1',1,MA_ERR)
330
 
             CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,
331
 
     1            int_mb(k_a_offset),
332
 
     2            (h1b_1 - 1 + (noab+nvab) * (h7b_1 - 1)))
333
 
             CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),
334
 
     1            int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),
335
 
     2            2,1,1.0d0)
336
 
             IF (.not.MA_POP_STACK(l_a))
337
 
     1            CALL ERRQUIT('ccsd_t1_2_1',2,MA_ERR)
338
 
             IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c))
339
 
     1            CALL ERRQUIT('ccsd_t1_2_1',3,MA_ERR)
340
 
             CALL TCE_SORT_2(dbl_mb(k_as),dbl_mb(k_c),
341
 
     1            int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),
342
 
     2            2,1,1.0d0)
343
 
             CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,
344
 
     1            int_mb(k_c_offset),(h1b - 1 + noab * (h7b - 1)))
345
 
             IF (.not.MA_POP_STACK(l_c))
346
 
     1            CALL ERRQUIT('ccsd_t1_2_1',4,MA_ERR)
347
 
             IF (.not.MA_POP_STACK(l_as))
348
 
     1            CALL ERRQUIT('ccsd_t1_2_1',5,MA_ERR)
349
 
            END IF
350
 
           END IF
351
 
          END IF
352
 
         END IF
353
 
         next = NXTASK(nprocs, 1)
354
 
        END IF
355
 
        count = count + 1
356
 
       END DO
357
 
      END DO
358
 
      next = NXTASK(-nprocs, 1)
359
 
      call GA_SYNC()
360
 
      RETURN
361
 
      END
362
 
 
363
 
 
364
 
 
365
 
 
366
 
      SUBROUTINE OFFSET_ccsd_t1_2_1(l_a_offset,k_a_offset,size)
367
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
368
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
369
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
370
 
C     i1 ( h7 h1 )_f
371
 
      IMPLICIT NONE
372
 
#include "global.fh"
373
 
#include "mafdecls.fh"
374
 
#include "sym.fh"
375
 
#include "errquit.fh"
376
 
#include "tce.fh"
377
 
      INTEGER l_a_offset
378
 
      INTEGER k_a_offset
379
 
      INTEGER size
380
 
      INTEGER length
381
 
      INTEGER addr
382
 
      INTEGER h7b
383
 
      INTEGER h1b
384
 
      length = 0
385
 
      DO h7b = 1,noab
386
 
      DO h1b = 1,noab
387
 
      IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h1b-1)) THEN
388
 
      IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
389
 
     &EN
390
 
      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h1b-1
391
 
     &).ne.4)) THEN
392
 
      length = length + 1
393
 
      END IF
394
 
      END IF
395
 
      END IF
396
 
      END DO
397
 
      END DO
398
 
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
399
 
     &set)) CALL ERRQUIT('ccsd_t1_2_1',0,MA_ERR)
400
 
      int_mb(k_a_offset) = length
401
 
      addr = 0
402
 
      size = 0
403
 
      DO h7b = 1,noab
404
 
      DO h1b = 1,noab
405
 
      IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h1b-1)) THEN
406
 
      IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
407
 
     &EN
408
 
      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h1b-1
409
 
     &).ne.4)) THEN
410
 
      addr = addr + 1
411
 
      int_mb(k_a_offset+addr) = h1b - 1 + noab * (h7b - 1)
412
 
      int_mb(k_a_offset+length+addr) = size
413
 
      size = size + int_mb(k_range+h7b-1) * int_mb(k_range+h1b-1)
414
 
      END IF
415
 
      END IF
416
 
      END IF
417
 
      END DO
418
 
      END DO
419
 
      RETURN
420
 
      END
421
 
 
422
 
 
423
 
 
424
 
 
425
 
 
426
 
      SUBROUTINE ccsd_t1_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
427
 
     &t)
428
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
429
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
430
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
431
 
C     i1 ( h7 h1 )_ft + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * i2 ( h7 p3 )_f
432
 
      IMPLICIT NONE
433
 
#include "global.fh"
434
 
#include "mafdecls.fh"
435
 
#include "sym.fh"
436
 
#include "errquit.fh"
437
 
#include "tce.fh"
438
 
      INTEGER d_a, d_b, d_c
439
 
      INTEGER k_a_offset, k_b_offset, k_c_offset
440
 
      INTEGER NXTASK, next, nprocs, count
441
 
      INTEGER h7b, h1b, p3b, p3b_1, h1b_1, h7b_2, p3b_2
442
 
      INTEGER dim_common, dima_sort, dimb_sort
443
 
      INTEGER dima, dimb, dimc
444
 
      INTEGER k_a, l_a, k_b, l_b, k_c, l_c
445
 
      INTEGER k_as, l_as
446
 
      EXTERNAL NXTASK
447
 
      nprocs = GA_NNODES()
448
 
      count = 0
449
 
      next = NXTASK(nprocs, 1)
450
 
      DO h7b = 1,noab
451
 
       DO h1b = 1,noab
452
 
        IF (next.eq.count) THEN
453
 
         IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)
454
 
     1                            +int_mb(k_spin+h1b-1).ne.4)) THEN
455
 
          IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h1b-1)) THEN
456
 
           IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h1b-1)) 
457
 
     1         .eq. ieor(irrep_f,irrep_t)) THEN
458
 
            dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h1b-1)
459
 
            IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c))
460
 
     1           CALL ERRQUIT('ccsd_t1_2_2',0,MA_ERR)
461
 
            CALL DFILL(dimc,0.0d0,dbl_mb(k_c),1)
462
 
            DO p3b = noab+1,noab+nvab
463
 
             IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
464
 
              IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1))
465
 
     1            .eq. irrep_t) THEN
466
 
               CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1)
467
 
               CALL TCE_RESTRICTED_2(h7b,p3b,h7b_2,p3b_2)
468
 
               dim_common = int_mb(k_range+p3b-1)
469
 
               dima_sort = int_mb(k_range+h1b-1)
470
 
               dima = dim_common * dima_sort
471
 
               dimb_sort = int_mb(k_range+h7b-1)
472
 
               dimb = dim_common * dimb_sort
473
 
               IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
474
 
                IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as))
475
 
     1               CALL ERRQUIT('ccsd_t1_2_2',1,MA_ERR)
476
 
                IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a))
477
 
     1               CALL ERRQUIT('ccsd_t1_2_2',2,MA_ERR)
478
 
                CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
479
 
     1               int_mb(k_a_offset),
480
 
     2               (h1b_1 - 1 + noab * (p3b_1 - noab - 1)))
481
 
                CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),
482
 
     1               int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),
483
 
     2               2,1,1.0d0)
484
 
                IF (.not.MA_POP_STACK(l_a))
485
 
     1               CALL ERRQUIT('ccsd_t1_2_2',3,MA_ERR)
486
 
                IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b))
487
 
     1               CALL ERRQUIT('ccsd_t1_2_2',5,MA_ERR)
488
 
                CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,
489
 
     1               int_mb(k_b_offset),
490
 
     2               (p3b_2 - noab - 1 + nvab * (h7b_2 - 1)))
491
 
                CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,
492
 
     1               dbl_mb(k_as),dim_common,dbl_mb(k_b),dim_common,
493
 
     2               1.0d0,dbl_mb(k_c),dima_sort)
494
 
                IF (.not.MA_POP_STACK(l_b))
495
 
     1               CALL ERRQUIT('ccsd_t1_2_2',7,MA_ERR)
496
 
                IF (.not.MA_POP_STACK(l_as))
497
 
     1               CALL ERRQUIT('ccsd_t1_2_2',8,MA_ERR)
498
 
               END IF
499
 
              END IF
500
 
             END IF
501
 
            END DO
502
 
            CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,
503
 
     1           int_mb(k_c_offset),(h1b - 1 + noab * (h7b - 1)))
504
 
            IF (.not.MA_POP_STACK(l_c))
505
 
     1           CALL ERRQUIT('ccsd_t1_2_2',10,MA_ERR)
506
 
           END IF
507
 
          END IF
508
 
         END IF
509
 
         next = NXTASK(nprocs, 1)
510
 
        END IF
511
 
        count = count + 1
512
 
       END DO
513
 
      END DO
514
 
      next = NXTASK(-nprocs, 1)
515
 
      call GA_SYNC()
516
 
      RETURN
517
 
      END
518
 
 
519
 
 
520
 
 
521
 
 
522
 
      SUBROUTINE ccsd_t1_2_2_1(d_a,k_a_offset,d_c,k_c_offset)
523
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
524
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
525
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
526
 
C     i2 ( h7 p3 )_f + = 1 * f ( h7 p3 )_f
527
 
      IMPLICIT NONE
528
 
#include "global.fh"
529
 
#include "mafdecls.fh"
530
 
#include "sym.fh"
531
 
#include "errquit.fh"
532
 
#include "tce.fh"
533
 
      INTEGER d_a, d_c
534
 
      INTEGER k_a_offset, k_c_offset
535
 
      INTEGER NXTASK, next, nprocs, count
536
 
      INTEGER h7b, p3b, h7b_1, p3b_1
537
 
      INTEGER dimc
538
 
      INTEGER k_a, l_a
539
 
      EXTERNAL NXTASK
540
 
      nprocs = GA_NNODES()
541
 
      count = 0
542
 
      next = NXTASK(nprocs, 1)
543
 
      DO h7b = 1,noab
544
 
       DO p3b = noab+1,noab+nvab
545
 
        IF (next.eq.count) THEN
546
 
         IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)
547
 
     1                            +int_mb(k_spin+p3b-1).ne.4)) THEN
548
 
          IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+p3b-1)) THEN
549
 
           IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+p3b-1))
550
 
     1         .eq. irrep_f) THEN
551
 
            dimc = int_mb(k_range+h7b-1) * int_mb(k_range+p3b-1)
552
 
            CALL TCE_RESTRICTED_2(h7b,p3b,h7b_1,p3b_1)
553
 
            IF (dimc .gt. 0) THEN
554
 
             IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_a,k_a))
555
 
     1            CALL ERRQUIT('ccsd_t1_2_2_1',1,MA_ERR)
556
 
             CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dimc,
557
 
     1            int_mb(k_a_offset),
558
 
     2            (p3b_1 - 1 + (noab+nvab) * (h7b_1 - 1)))
559
 
             CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_a),dimc,
560
 
     1            int_mb(k_c_offset),
561
 
     2            (p3b - noab - 1 + nvab * (h7b - 1)))
562
 
             IF (.not.MA_POP_STACK(l_a))
563
 
     1            CALL ERRQUIT('ccsd_t1_2_2_1',5,MA_ERR)
564
 
            END IF
565
 
           END IF
566
 
          END IF
567
 
         END IF
568
 
         next = NXTASK(nprocs, 1)
569
 
        END IF
570
 
        count = count + 1
571
 
       END DO
572
 
      END DO
573
 
      next = NXTASK(-nprocs, 1)
574
 
      call GA_SYNC()
575
 
      RETURN
576
 
      END
577
 
 
578
 
 
579
 
 
580
 
 
581
 
      SUBROUTINE OFFSET_ccsd_t1_2_2_1(l_a_offset,k_a_offset,size)
582
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
583
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
584
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
585
 
C     i2 ( h7 p3 )_f
586
 
      IMPLICIT NONE
587
 
#include "global.fh"
588
 
#include "mafdecls.fh"
589
 
#include "sym.fh"
590
 
#include "errquit.fh"
591
 
#include "tce.fh"
592
 
      INTEGER l_a_offset
593
 
      INTEGER k_a_offset
594
 
      INTEGER size
595
 
      INTEGER length
596
 
      INTEGER addr
597
 
      INTEGER h7b
598
 
      INTEGER p3b
599
 
      length = 0
600
 
      DO h7b = 1,noab
601
 
      DO p3b = noab+1,noab+nvab
602
 
      IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+p3b-1)) THEN
603
 
      IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+p3b-1)) .eq. irrep_f) TH
604
 
     &EN
605
 
      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1
606
 
     &).ne.4)) THEN
607
 
      length = length + 1
608
 
      END IF
609
 
      END IF
610
 
      END IF
611
 
      END DO
612
 
      END DO
613
 
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
614
 
     &set)) CALL ERRQUIT('ccsd_t1_2_2_1',0,MA_ERR)
615
 
      int_mb(k_a_offset) = length
616
 
      addr = 0
617
 
      size = 0
618
 
      DO h7b = 1,noab
619
 
      DO p3b = noab+1,noab+nvab
620
 
      IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+p3b-1)) THEN
621
 
      IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+p3b-1)) .eq. irrep_f) TH
622
 
     &EN
623
 
      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+p3b-1
624
 
     &).ne.4)) THEN
625
 
      addr = addr + 1
626
 
      int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h7b - 1)
627
 
      int_mb(k_a_offset+length+addr) = size
628
 
      size = size + int_mb(k_range+h7b-1) * int_mb(k_range+p3b-1)
629
 
      END IF
630
 
      END IF
631
 
      END IF
632
 
      END DO
633
 
      END DO
634
 
      RETURN
635
 
      END
636
 
 
637
 
 
638
 
 
639
 
 
640
 
 
641
 
      SUBROUTINE ccsd_t1_2_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
642
 
     &set)
643
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
644
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
645
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
646
 
C     i2 ( h7 p3 )_vt + = -1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 h7 p3 p5 )_v
647
 
      IMPLICIT NONE
648
 
#include "global.fh"
649
 
#include "mafdecls.fh"
650
 
#include "sym.fh"
651
 
#include "errquit.fh"
652
 
#include "tce.fh"
653
 
      INTEGER d_a,d_b,d_c
654
 
      INTEGER k_a_offset,k_b_offset,k_c_offset
655
 
      INTEGER NXTASK,next,nprocs,count
656
 
      INTEGER h7b,p3b,p5b,h6b,p5b_1,h6b_1,h7b_2,h6b_2,p3b_2,p5b_2
657
 
      INTEGER dim_common,dima_sort,dimb_sort
658
 
      INTEGER dima,dimb,dimc
659
 
      INTEGER k_as,l_as,k_bs,l_bs,k_cs,l_cs
660
 
      INTEGER k_a,l_a,k_b,l_b,k_c,l_c
661
 
      EXTERNAL NXTASK
662
 
      nprocs = GA_NNODES()
663
 
      count = 0
664
 
      next = NXTASK(nprocs, 1)
665
 
      DO h7b = 1,noab
666
 
       DO p3b = noab+1,noab+nvab
667
 
        IF (next.eq.count) THEN
668
 
         IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)
669
 
     1                            +int_mb(k_spin+p3b-1).ne.4)) THEN
670
 
          IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+p3b-1)) THEN
671
 
           IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+p3b-1)) 
672
 
     1         .eq. ieor(irrep_v,irrep_t)) THEN
673
 
            dimc = int_mb(k_range+h7b-1) * int_mb(k_range+p3b-1)
674
 
            IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_cs,k_cs))
675
 
     1           CALL ERRQUIT('ccsd_t1_2_2_2',0,MA_ERR)
676
 
            CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1)
677
 
            DO p5b = noab+1,noab+nvab
678
 
             DO h6b = 1,noab
679
 
              IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h6b-1)) THEN
680
 
               IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h6b-1)) 
681
 
     1             .eq. irrep_t) THEN
682
 
                CALL TCE_RESTRICTED_2(p5b,h6b,p5b_1,h6b_1)
683
 
                CALL TCE_RESTRICTED_4(h7b,h6b,p3b,p5b,
684
 
     1                                h7b_2,h6b_2,p3b_2,p5b_2)
685
 
                dim_common = int_mb(k_range+p5b-1) 
686
 
     1                     * int_mb(k_range+h6b-1)
687
 
                dima_sort = 1
688
 
                dima = dim_common * dima_sort
689
 
                dimb_sort = int_mb(k_range+h7b-1) 
690
 
     1                    * int_mb(k_range+p3b-1)
691
 
                dimb = dim_common * dimb_sort
692
 
                IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
693
 
                 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as))
694
 
     1                CALL ERRQUIT('ccsd_t1_2_2_2',1,MA_ERR)
695
 
                 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a))
696
 
     1                CALL ERRQUIT('ccsd_t1_2_2_2',2,MA_ERR)
697
 
                 CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
698
 
     1                int_mb(k_a_offset),
699
 
     2                (h6b_1 - 1 + noab * (p5b_1 - noab - 1)))
700
 
                 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),
701
 
     1                int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),
702
 
     2                2,1,1.0d0)
703
 
                 IF (.not.MA_POP_STACK(l_a))
704
 
     1                CALL ERRQUIT('ccsd_t1_2_2_2',3,MA_ERR)
705
 
                 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_bs,k_bs))
706
 
     1                CALL ERRQUIT('ccsd_t1_2_2_2',4,MA_ERR)
707
 
                 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b))
708
 
     1                CALL ERRQUIT('ccsd_t1_2_2_2',5,MA_ERR)
709
 
                 IF ((h6b .le. h7b) .and. (p5b .lt. p3b)) THEN
710
 
                  if(.not.intorb) then
711
 
                   CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,
712
 
     1                  int_mb(k_b_offset),(p3b_2 - 1 + (noab+nvab) * 
713
 
     2                  (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + 
714
 
     3                  (noab+nvab) * (h6b_2 - 1)))))
715
 
                  else
716
 
                   CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,
717
 
     1                  int_mb(k_b_offset),(p3b_2 - 1 + (noab+nvab) * 
718
 
     2                  (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + 
719
 
     3                  (noab+nvab) * (h6b_2 - 1)))),
720
 
     4                  p3b_2,p5b_2,h7b_2,h6b_2)
721
 
                  end if
722
 
                  CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),
723
 
     1                 int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),
724
 
     2                 int_mb(k_range+p5b-1),int_mb(k_range+p3b-1),
725
 
     3                 4,2,1,3,-1.0d0)
726
 
                 END IF
727
 
                 IF ((h6b .le. h7b) .and. (p3b .le. p5b)) THEN
728
 
                  if(.not.intorb) then
729
 
                   CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,
730
 
     1                  int_mb(k_b_offset),(p5b_2 - 1 + (noab+nvab) *
731
 
     2                  (p3b_2 - 1 + (noab+nvab) * (h7b_2 - 1 +
732
 
     3                  (noab+nvab) * (h6b_2 - 1)))))
733
 
                  else
734
 
                   CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,
735
 
     1                  int_mb(k_b_offset),(p5b_2 - 1 + (noab+nvab) *
736
 
     2                  (p3b_2 - 1 + (noab+nvab) * (h7b_2 - 1 +
737
 
     3                  (noab+nvab) * (h6b_2 - 1)))),
738
 
     4                  p5b_2,p3b_2,h7b_2,h6b_2)
739
 
                  end if
740
 
                  CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),
741
 
     1                 int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),
742
 
     2                 int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),
743
 
     3                 3,2,1,4,1.0d0)
744
 
                 END IF
745
 
                 IF ((h7b .lt. h6b) .and. (p5b .lt. p3b)) THEN
746
 
                  if(.not.intorb) then
747
 
                   CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,
748
 
     1                  int_mb(k_b_offset),(p3b_2 - 1 + (noab+nvab) *
749
 
     2                  (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 +
750
 
     3                  (noab+nvab) * (h7b_2 - 1)))))
751
 
                  else
752
 
                   CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,
753
 
     1                  int_mb(k_b_offset),(p3b_2 - 1 + (noab+nvab) *
754
 
     2                  (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 +
755
 
     3                  (noab+nvab) * (h7b_2 - 1)))),
756
 
     4                  p3b_2,p5b_2,h6b_2,h7b_2)
757
 
                  end if
758
 
                  CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),
759
 
     1                 int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),
760
 
     2                 int_mb(k_range+p5b-1),int_mb(k_range+p3b-1),
761
 
     3                 4,1,2,3,1.0d0)
762
 
                 END IF
763
 
                 IF ((h7b .lt. h6b) .and. (p3b .le. p5b)) THEN
764
 
                  if(.not.intorb) then
765
 
                   CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,
766
 
     1                  int_mb(k_b_offset),(p5b_2 - 1 + (noab+nvab) *
767
 
     2                  (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 +
768
 
     3                  (noab+nvab) * (h7b_2 - 1)))))
769
 
                  else
770
 
                   CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,
771
 
     1                  int_mb(k_b_offset),(p5b_2 - 1 + (noab+nvab) *
772
 
     2                  (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 +
773
 
     3                  (noab+nvab) * (h7b_2 - 1)))),
774
 
     4                  p5b_2,p3b_2,h6b_2,h7b_2)
775
 
                  end if
776
 
                  CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),
777
 
     1                 int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),
778
 
     2                 int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),
779
 
     3                 3,1,2,4,-1.0d0)
780
 
                 END IF
781
 
                 IF (.not.MA_POP_STACK(l_b))
782
 
     1                CALL ERRQUIT('ccsd_t1_2_2_2',6,MA_ERR)
783
 
                 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,
784
 
     1                1.0d0,dbl_mb(k_as),dim_common,dbl_mb(k_bs),
785
 
     2                dim_common,1.0d0,dbl_mb(k_cs),dima_sort)
786
 
                 IF (.not.MA_POP_STACK(l_bs))
787
 
     1                CALL ERRQUIT('ccsd_t1_2_2_2',7,MA_ERR)
788
 
                 IF (.not.MA_POP_STACK(l_as))
789
 
     1                CALL ERRQUIT('ccsd_t1_2_2_2',8,MA_ERR)
790
 
                END IF
791
 
               END IF
792
 
              END IF
793
 
             END DO
794
 
            END DO
795
 
            IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c))
796
 
     1           CALL ERRQUIT('ccsd_t1_2_2_2',9,MA_ERR)
797
 
            CALL TCE_SORT_2(dbl_mb(k_cs),dbl_mb(k_c),
798
 
     1           int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),
799
 
     2           2,1,-1.0d0)
800
 
            CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,
801
 
     1           int_mb(k_c_offset),
802
 
     2           (p3b - noab - 1 + nvab * (h7b - 1)))
803
 
            IF (.not.MA_POP_STACK(l_c))
804
 
     1           CALL ERRQUIT('ccsd_t1_2_2_2',10,MA_ERR)
805
 
            IF (.not.MA_POP_STACK(l_cs))
806
 
     1           CALL ERRQUIT('ccsd_t1_2_2_2',11,MA_ERR)
807
 
           END IF
808
 
          END IF
809
 
         END IF
810
 
         next = NXTASK(nprocs, 1)
811
 
        END IF
812
 
        count = count + 1
813
 
       END DO
814
 
      END DO
815
 
      next = NXTASK(-nprocs, 1)
816
 
      call GA_SYNC()
817
 
      RETURN
818
 
      END
819
 
      SUBROUTINE ccsd_t1_2_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
820
 
     &t)
821
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
822
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
823
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
824
 
C     i1 ( h7 h1 )_vt + = -1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 h7 h1 p4 )_v
825
 
      IMPLICIT NONE
826
 
#include "global.fh"
827
 
#include "mafdecls.fh"
828
 
#include "sym.fh"
829
 
#include "errquit.fh"
830
 
#include "tce.fh"
831
 
      INTEGER d_a
832
 
      INTEGER k_a_offset
833
 
      INTEGER d_b
834
 
      INTEGER k_b_offset
835
 
      INTEGER d_c
836
 
      INTEGER k_c_offset
837
 
      INTEGER NXTASK
838
 
      INTEGER next
839
 
      INTEGER nprocs
840
 
      INTEGER count
841
 
      INTEGER h7b
842
 
      INTEGER h1b
843
 
      INTEGER dimc
844
 
      INTEGER l_cs
845
 
      INTEGER k_cs
846
 
      INTEGER p4b
847
 
      INTEGER h5b
848
 
      INTEGER p4b_1
849
 
      INTEGER h5b_1
850
 
      INTEGER h7b_2
851
 
      INTEGER h5b_2
852
 
      INTEGER h1b_2
853
 
      INTEGER p4b_2
854
 
      INTEGER dim_common
855
 
      INTEGER dima_sort
856
 
      INTEGER dima
857
 
      INTEGER dimb_sort
858
 
      INTEGER dimb
859
 
      INTEGER l_as
860
 
      INTEGER k_as
861
 
      INTEGER l_a
862
 
      INTEGER k_a
863
 
      INTEGER l_bs
864
 
      INTEGER k_bs
865
 
      INTEGER l_b
866
 
      INTEGER k_b
867
 
      INTEGER l_c
868
 
      INTEGER k_c
869
 
      EXTERNAL NXTASK
870
 
      nprocs = GA_NNODES()
871
 
      count = 0
872
 
      next = NXTASK(nprocs, 1)
873
 
      DO h7b = 1,noab
874
 
      DO h1b = 1,noab
875
 
      IF (next.eq.count) THEN
876
 
      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h1b-1
877
 
     &).ne.4)) THEN
878
 
      IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h1b-1)) THEN
879
 
      IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
880
 
     &v,irrep_t)) THEN
881
 
      dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h1b-1)
882
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_cs,k_cs)) CALL
883
 
     & ERRQUIT('ccsd_t1_2_3',0,MA_ERR)
884
 
      CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1)
885
 
      DO p4b = noab+1,noab+nvab
886
 
      DO h5b = 1,noab
887
 
      IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h5b-1)) THEN
888
 
      IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h5b-1)) .eq. irrep_t) TH
889
 
     &EN
890
 
      CALL TCE_RESTRICTED_2(p4b,h5b,p4b_1,h5b_1)
891
 
      CALL TCE_RESTRICTED_4(h7b,h5b,h1b,p4b,h7b_2,h5b_2,h1b_2,p4b_2)
892
 
      dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h5b-1)
893
 
      dima_sort = 1
894
 
      dima = dim_common * dima_sort
895
 
      dimb_sort = int_mb(k_range+h7b-1) * int_mb(k_range+h1b-1)
896
 
      dimb = dim_common * dimb_sort
897
 
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
898
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as)) CALL
899
 
     & ERRQUIT('ccsd_t1_2_3',1,MA_ERR)
900
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
901
 
     &ccsd_t1_2_3',2,MA_ERR)
902
 
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
903
 
     & int_mb(k_a_offset),(h5b_1
904
 
     & - 1 + noab * (p4b_1 - noab - 1)))
905
 
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p4b-1)
906
 
     &,int_mb(k_range+h5b-1),2,1,1.0d0)
907
 
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t1_2_3',3,MA_ERR)
908
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_bs,k_bs)) CALL
909
 
     & ERRQUIT('ccsd_t1_2_3',4,MA_ERR)
910
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
911
 
     &ccsd_t1_2_3',5,MA_ERR)
912
 
      IF ((h5b .le. h7b) .and. (h1b .le. p4b)) THEN
913
 
      if(.not.intorb) then
914
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
915
 
     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
916
 
     &+nvab) * (h5b_2 - 1)))))
917
 
      else
918
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
919
 
     &(p4b_2
920
 
     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
921
 
     &+nvab) * (h5b_2 - 1)))),p4b_2,h1b_2,h7b_2,h5b_2)
922
 
      end if
923
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h5b-1)
924
 
     &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1)
925
 
     &,3,2,1,4,1.0d0)
926
 
      END IF
927
 
      IF ((h7b .lt. h5b) .and. (h1b .le. p4b)) THEN
928
 
      if(.not.intorb) then
929
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
930
 
     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
931
 
     &+nvab) * (h7b_2 - 1)))))
932
 
      else
933
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
934
 
     &(p4b_2
935
 
     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
936
 
     &+nvab) * (h7b_2 - 1)))),p4b_2,h1b_2,h5b_2,h7b_2)
937
 
      end if
938
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h7b-1)
939
 
     &,int_mb(k_range+h5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1)
940
 
     &,3,1,2,4,-1.0d0)
941
 
      END IF
942
 
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t1_2_3',6,MA_ERR)
943
 
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,
944
 
     1     dbl_mb(k_as),dim_common,dbl_mb(k_bs),dim_common,1.0d0,
945
 
     2     dbl_mb(k_cs),dima_sort)
946
 
      IF (.not.MA_POP_STACK(l_bs))
947
 
     1     CALL ERRQUIT('ccsd_t1_2_3',7,MA_ERR)
948
 
      IF (.not.MA_POP_STACK(l_as))
949
 
     1     CALL ERRQUIT('ccsd_t1_2_3',8,MA_ERR)
950
 
      END IF
951
 
      END IF
952
 
      END IF
953
 
      END DO
954
 
      END DO
955
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
956
 
     &ccsd_t1_2_3',9,MA_ERR)
957
 
      CALL TCE_SORT_2(dbl_mb(k_cs),dbl_mb(k_c),int_mb(k_range+h1b-1)
958
 
     &,int_mb(k_range+h7b-1),2,1,-1.0d0)
959
 
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
960
 
     & 1 + noab * (h7b - 1)))
961
 
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_t1_2_3',10,MA_ERR)
962
 
      IF (.not.MA_POP_STACK(l_cs)) CALL ERRQUIT('ccsd_t1_2_3',11,MA_
963
 
     &ERR)
964
 
      END IF
965
 
      END IF
966
 
      END IF
967
 
      next = NXTASK(nprocs, 1)
968
 
      END IF
969
 
      count = count + 1
970
 
      END DO
971
 
      END DO
972
 
      next = NXTASK(-nprocs, 1)
973
 
      call GA_SYNC()
974
 
      RETURN
975
 
      END
976
 
      SUBROUTINE ccsd_t1_2_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
977
 
     &t)
978
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
979
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
980
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
981
 
C     i1 ( h7 h1 )_vt + = -1/2 * Sum ( h5 p3 p4 ) * t ( p3 p4 h1 h5 )_t * v ( h5 h7 p3 p4 )_v
982
 
      IMPLICIT NONE
983
 
#include "global.fh"
984
 
#include "mafdecls.fh"
985
 
#include "sym.fh"
986
 
#include "errquit.fh"
987
 
#include "tce.fh"
988
 
      INTEGER d_a
989
 
      INTEGER k_a_offset
990
 
      INTEGER d_b
991
 
      INTEGER k_b_offset
992
 
      INTEGER d_c
993
 
      INTEGER k_c_offset
994
 
      INTEGER NXTASK
995
 
      INTEGER next
996
 
      INTEGER nprocs
997
 
      INTEGER count
998
 
      INTEGER h7b
999
 
      INTEGER h1b
1000
 
      INTEGER dimc
1001
 
      INTEGER l_cs
1002
 
      INTEGER k_cs
1003
 
      INTEGER p3b
1004
 
      INTEGER p4b
1005
 
      INTEGER h5b
1006
 
      INTEGER p3b_1
1007
 
      INTEGER p4b_1
1008
 
      INTEGER h1b_1
1009
 
      INTEGER h5b_1
1010
 
      INTEGER h7b_2
1011
 
      INTEGER h5b_2
1012
 
      INTEGER p3b_2
1013
 
      INTEGER p4b_2
1014
 
      INTEGER dim_common
1015
 
      INTEGER dima_sort
1016
 
      INTEGER dima
1017
 
      INTEGER dimb_sort
1018
 
      INTEGER dimb
1019
 
      INTEGER l_as
1020
 
      INTEGER k_as
1021
 
      INTEGER l_a
1022
 
      INTEGER k_a
1023
 
      INTEGER l_bs
1024
 
      INTEGER k_bs
1025
 
      INTEGER l_b
1026
 
      INTEGER k_b
1027
 
      INTEGER nsuperp(2)
1028
 
      INTEGER isuperp
1029
 
      INTEGER l_c
1030
 
      INTEGER k_c
1031
 
      DOUBLE PRECISION FACTORIAL
1032
 
      EXTERNAL NXTASK
1033
 
      EXTERNAL FACTORIAL
1034
 
      nprocs = GA_NNODES()
1035
 
      count = 0
1036
 
      next = NXTASK(nprocs, 1)
1037
 
      DO h7b = 1,noab
1038
 
      DO h1b = 1,noab
1039
 
      IF (next.eq.count) THEN
1040
 
      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h1b-1
1041
 
     &).ne.4)) THEN
1042
 
      IF (int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1043
 
      IF (ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
1044
 
     &v,irrep_t)) THEN
1045
 
      dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h1b-1)
1046
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_cs,k_cs)) CALL
1047
 
     & ERRQUIT('ccsd_t1_2_4',0,MA_ERR)
1048
 
      CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1)
1049
 
      DO p3b = noab+1,noab+nvab
1050
 
      DO p4b = p3b,noab+nvab
1051
 
      DO h5b = 1,noab
1052
 
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
1053
 
     &1b-1)+int_mb(k_spin+h5b-1)) THEN
1054
 
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
1055
 
     &k_sym+h1b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN
1056
 
      CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h5b,p3b_1,p4b_1,h1b_1,h5b_1)
1057
 
      CALL TCE_RESTRICTED_4(h7b,h5b,p3b,p4b,h7b_2,h5b_2,p3b_2,p4b_2)
1058
 
      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m
1059
 
     &b(k_range+h5b-1)
1060
 
      dima_sort = int_mb(k_range+h1b-1)
1061
 
      dima = dim_common * dima_sort
1062
 
      dimb_sort = int_mb(k_range+h7b-1)
1063
 
      dimb = dim_common * dimb_sort
1064
 
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1065
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as)) CALL
1066
 
     & ERRQUIT('ccsd_t1_2_4',1,MA_ERR)
1067
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1068
 
     &ccsd_t1_2_4',2,MA_ERR)
1069
 
      IF ((h5b .lt. h1b)) THEN
1070
 
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
1071
 
     & - 1 + noab * (h5b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
1072
 
     &1 - noab - 1)))))
1073
 
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p3b-1)
1074
 
     &,int_mb(k_range+p4b-1),int_mb(k_range+h5b-1),int_mb(k_range+h1b-1)
1075
 
     &,4,3,2,1,-1.0d0)
1076
 
      END IF
1077
 
      IF ((h1b .le. h5b)) THEN
1078
 
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1
1079
 
     & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
1080
 
     &1 - noab - 1)))))
1081
 
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p3b-1)
1082
 
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h5b-1)
1083
 
     &,3,4,2,1,1.0d0)
1084
 
      END IF
1085
 
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t1_2_4',3,MA_ERR)
1086
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_bs,k_bs)) CALL
1087
 
     & ERRQUIT('ccsd_t1_2_4',4,MA_ERR)
1088
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1089
 
     &ccsd_t1_2_4',5,MA_ERR)
1090
 
      IF ((h5b .le. h7b)) THEN
1091
 
      if(.not.intorb) then
1092
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
1093
 
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
1094
 
     &+nvab) * (h5b_2 - 1)))))
1095
 
      else
1096
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1097
 
     &(p4b_2
1098
 
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
1099
 
     &+nvab) * (h5b_2 - 1)))),p4b_2,p3b_2,h7b_2,h5b_2)
1100
 
      end if
1101
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h5b-1)
1102
 
     &,int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1)
1103
 
     &,2,1,4,3,1.0d0)
1104
 
      END IF
1105
 
      IF ((h7b .lt. h5b)) THEN
1106
 
      if(.not.intorb) then
1107
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
1108
 
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
1109
 
     &+nvab) * (h7b_2 - 1)))))
1110
 
      else
1111
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1112
 
     &(p4b_2
1113
 
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
1114
 
     &+nvab) * (h7b_2 - 1)))),p4b_2,p3b_2,h5b_2,h7b_2)
1115
 
      end if
1116
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h7b-1)
1117
 
     &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1)
1118
 
     &,1,2,4,3,-1.0d0)
1119
 
      END IF
1120
 
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t1_2_4',6,MA_ERR)
1121
 
      nsuperp(1) = 1
1122
 
      nsuperp(2) = 1
1123
 
      isuperp = 1
1124
 
      IF (p3b .eq. p4b) THEN
1125
 
      nsuperp(isuperp) = nsuperp(isuperp) + 1
1126
 
      ELSE
1127
 
      isuperp = isuperp + 1
1128
 
      END IF
1129
 
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
1130
 
     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_as),dim_common,dbl_
1131
 
     &mb(k_bs),dim_common,1.0d0,dbl_mb(k_cs),dima_sort)
1132
 
      IF (.not.MA_POP_STACK(l_bs)) CALL ERRQUIT('ccsd_t1_2_4',7,MA_E
1133
 
     &RR)
1134
 
      IF (.not.MA_POP_STACK(l_as)) CALL ERRQUIT('ccsd_t1_2_4',8,MA_E
1135
 
     &RR)
1136
 
      END IF
1137
 
      END IF
1138
 
      END IF
1139
 
      END DO
1140
 
      END DO
1141
 
      END DO
1142
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1143
 
     &ccsd_t1_2_4',9,MA_ERR)
1144
 
      CALL TCE_SORT_2(dbl_mb(k_cs),dbl_mb(k_c),int_mb(k_range+h7b-1)
1145
 
     &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0)
1146
 
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
1147
 
     & 1 + noab * (h7b - 1)))
1148
 
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_t1_2_4',10,MA_ERR)
1149
 
      IF (.not.MA_POP_STACK(l_cs)) CALL ERRQUIT('ccsd_t1_2_4',11,MA_
1150
 
     &ERR)
1151
 
      END IF
1152
 
      END IF
1153
 
      END IF
1154
 
      next = NXTASK(nprocs, 1)
1155
 
      END IF
1156
 
      count = count + 1
1157
 
      END DO
1158
 
      END DO
1159
 
      next = NXTASK(-nprocs, 1)
1160
 
      call GA_SYNC()
1161
 
      RETURN
1162
 
      END
1163
 
 
1164
 
 
1165
 
 
1166
 
 
1167
 
 
1168
 
      SUBROUTINE ccsd_t1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
1169
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
1170
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1171
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1172
 
C     i0 ( p2 h1 )_tf + = 1 * Sum ( p3 ) * t ( p3 h1 )_t * i1 ( p2 p3 )_f
1173
 
      IMPLICIT NONE
1174
 
#include "global.fh"
1175
 
#include "mafdecls.fh"
1176
 
#include "sym.fh"
1177
 
#include "errquit.fh"
1178
 
#include "tce.fh"
1179
 
      INTEGER d_a, d_b, d_c
1180
 
      INTEGER k_a_offset, k_b_offset, k_c_offset
1181
 
      INTEGER NXTASK, next, nprocs, count
1182
 
      INTEGER p2b, h1b, p3b, p3b_1, h1b_1, p2b_2, p3b_2
1183
 
      INTEGER dim_common, dima_sort, dimb_sort, dima, dimb, dimc
1184
 
      INTEGER k_as, l_as
1185
 
      INTEGER k_a, k_b, l_b, k_c, l_c
1186
 
#ifdef LOCAL_COPY
1187
 
      INTEGER l_a
1188
 
#else
1189
 
      INTEGER offset_a
1190
 
#endif
1191
 
      EXTERNAL NXTASK
1192
 
      nprocs = GA_NNODES()
1193
 
      count = 0
1194
 
      next = NXTASK(nprocs, 1)
1195
 
      DO p2b = noab+1,noab+nvab
1196
 
       DO h1b = 1,noab
1197
 
        IF (next.eq.count) THEN
1198
 
         IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)
1199
 
     1                            +int_mb(k_spin+h1b-1).ne.4)) THEN
1200
 
          IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1201
 
           IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. 
1202
 
     1         ieor(irrep_t,irrep_f)) THEN
1203
 
            dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
1204
 
            IF (.not.MA_PUSH_GET(mt_dbl,dimc,'c',l_c,k_c))
1205
 
     1           CALL ERRQUIT('ccsd_t1_3',0,MA_ERR)
1206
 
            CALL DFILL(dimc,0.0d0,dbl_mb(k_c),1)
1207
 
            DO p3b = noab+1,noab+nvab
1208
 
             IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1209
 
              IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1))
1210
 
     1            .eq. irrep_t) THEN
1211
 
               CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1)
1212
 
               CALL TCE_RESTRICTED_2(p2b,p3b,p2b_2,p3b_2)
1213
 
               dim_common = int_mb(k_range+p3b-1)
1214
 
               dima_sort = int_mb(k_range+h1b-1)
1215
 
               dima = dim_common * dima_sort
1216
 
               dimb_sort = int_mb(k_range+p2b-1)
1217
 
               dimb = dim_common * dimb_sort
1218
 
               IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1219
 
                IF (.not.MA_PUSH_GET(mt_dbl,dima,'as',l_as,k_as))
1220
 
     1               CALL ERRQUIT('ccsd_t1_3',1,MA_ERR)
1221
 
#ifdef LOCAL_COPY
1222
 
                IF (.not.MA_PUSH_GET(mt_dbl,dima,'a',l_a,k_a))
1223
 
     1               CALL ERRQUIT('ccsd_t1_3',2,MA_ERR)
1224
 
                CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
1225
 
     1               int_mb(k_a_offset),
1226
 
     2               (h1b_1 - 1 + noab * (p3b_1 - noab - 1)))
1227
 
#else
1228
 
                call tce_hash(int_mb(k_a_offset),
1229
 
     1                        (h1b_1 - 1 + noab * (p3b_1 - noab - 1)),
1230
 
     2                        offset_a)
1231
 
                k_a = d_a + offset_a
1232
 
#endif
1233
 
                CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),
1234
 
     1               int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),
1235
 
     2               2,1,1.0d0)
1236
 
#ifdef LOCAL_COPY
1237
 
                IF (.not.MA_POP_STACK(l_a))
1238
 
     1               CALL ERRQUIT('ccsd_t1_3',3,MA_ERR)
1239
 
#endif
1240
 
                IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b))
1241
 
     1               CALL ERRQUIT('ccsd_t1_3',5,MA_ERR)
1242
 
                CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,
1243
 
     1               int_mb(k_b_offset),
1244
 
     2               (p3b_2 - noab - 1 + nvab * (p2b_2 - noab - 1)))
1245
 
                CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,
1246
 
     1               dbl_mb(k_as),dim_common,dbl_mb(k_b),dim_common,
1247
 
     2               1.0d0,dbl_mb(k_c),dima_sort)
1248
 
                IF (.not.MA_POP_STACK(l_b))
1249
 
     1               CALL ERRQUIT('ccsd_t1_3',7,MA_ERR)
1250
 
                IF (.not.MA_POP_STACK(l_as))
1251
 
     1               CALL ERRQUIT('ccsd_t1_3',8,MA_ERR)
1252
 
               END IF
1253
 
              END IF
1254
 
             END IF
1255
 
            END DO
1256
 
            CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,
1257
 
     1           int_mb(k_c_offset),
1258
 
     2           (h1b - 1 + noab * (p2b - noab - 1)))
1259
 
            IF (.not.MA_POP_STACK(l_c))
1260
 
     1           CALL ERRQUIT('ccsd_t1_3',10,MA_ERR)
1261
 
           END IF
1262
 
          END IF
1263
 
         END IF
1264
 
         next = NXTASK(nprocs, 1)
1265
 
        END IF
1266
 
        count = count + 1
1267
 
       END DO
1268
 
      END DO
1269
 
      next = NXTASK(-nprocs, 1)
1270
 
      call GA_SYNC()
1271
 
      RETURN
1272
 
      END
1273
 
 
1274
 
 
1275
 
 
1276
 
 
1277
 
 
1278
 
 
1279
 
      SUBROUTINE ccsd_t1_3_1(d_a,k_a_offset,d_c,k_c_offset)
1280
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
1281
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1282
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1283
 
C     i1 ( p2 p3 )_f + = 1 * f ( p2 p3 )_f
1284
 
      IMPLICIT NONE
1285
 
#include "global.fh"
1286
 
#include "mafdecls.fh"
1287
 
#include "sym.fh"
1288
 
#include "errquit.fh"
1289
 
#include "tce.fh"
1290
 
      INTEGER d_a, d_c
1291
 
      INTEGER k_a_offset, k_c_offset
1292
 
      INTEGER NXTASK, next, nprocs, count
1293
 
      INTEGER p2b, p3b, p2b_1, p3b_1
1294
 
      INTEGER dima
1295
 
      INTEGER k_a, l_a
1296
 
      EXTERNAL NXTASK
1297
 
      nprocs = GA_NNODES()
1298
 
      count = 0
1299
 
      next = NXTASK(nprocs, 1)
1300
 
      DO p2b = noab+1,noab+nvab
1301
 
       DO p3b = noab+1,noab+nvab
1302
 
        IF (next.eq.count) THEN
1303
 
         IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)
1304
 
     1                            +int_mb(k_spin+p3b-1).ne.4)) THEN
1305
 
          IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN
1306
 
           IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) 
1307
 
     1         .eq. irrep_f) THEN
1308
 
            CALL TCE_RESTRICTED_2(p2b,p3b,p2b_1,p3b_1)
1309
 
            dima = int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1)
1310
 
            IF (dima .gt. 0) THEN
1311
 
             IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) 
1312
 
     1            CALL ERRQUIT('ccsd_t1_3_1',1,MA_ERR)
1313
 
             CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,
1314
 
     1            int_mb(k_a_offset),
1315
 
     2            (p3b_1 - 1 + (noab+nvab) * (p2b_1 - 1)))
1316
 
             CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_a),dima,
1317
 
     1            int_mb(k_c_offset),
1318
 
     2            (p3b - noab - 1 + nvab * (p2b - noab - 1)))
1319
 
             IF (.not.MA_POP_STACK(l_a)) 
1320
 
     1            CALL ERRQUIT('ccsd_t1_3_1',5,MA_ERR)
1321
 
            END IF
1322
 
           END IF
1323
 
          END IF
1324
 
         END IF
1325
 
        next = NXTASK(nprocs, 1)
1326
 
        END IF
1327
 
       count = count + 1
1328
 
       END DO
1329
 
      END DO
1330
 
      next = NXTASK(-nprocs, 1)
1331
 
      call GA_SYNC()
1332
 
      RETURN
1333
 
      END
1334
 
 
1335
 
 
1336
 
 
1337
 
 
1338
 
 
1339
 
      SUBROUTINE OFFSET_ccsd_t1_3_1(l_a_offset,k_a_offset,size)
1340
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
1341
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1342
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1343
 
C     i1 ( p2 p3 )_f
1344
 
      IMPLICIT NONE
1345
 
#include "global.fh"
1346
 
#include "mafdecls.fh"
1347
 
#include "sym.fh"
1348
 
#include "errquit.fh"
1349
 
#include "tce.fh"
1350
 
      INTEGER l_a_offset
1351
 
      INTEGER k_a_offset
1352
 
      INTEGER size
1353
 
      INTEGER length
1354
 
      INTEGER addr
1355
 
      INTEGER p2b
1356
 
      INTEGER p3b
1357
 
      length = 0
1358
 
      DO p2b = noab+1,noab+nvab
1359
 
      DO p3b = noab+1,noab+nvab
1360
 
      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN
1361
 
      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) .eq. irrep_f) TH
1362
 
     &EN
1363
 
      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1
1364
 
     &).ne.4)) THEN
1365
 
      length = length + 1
1366
 
      END IF
1367
 
      END IF
1368
 
      END IF
1369
 
      END DO
1370
 
      END DO
1371
 
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
1372
 
     &set)) CALL ERRQUIT('ccsd_t1_3_1',0,MA_ERR)
1373
 
      int_mb(k_a_offset) = length
1374
 
      addr = 0
1375
 
      size = 0
1376
 
      DO p2b = noab+1,noab+nvab
1377
 
      DO p3b = noab+1,noab+nvab
1378
 
      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN
1379
 
      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) .eq. irrep_f) TH
1380
 
     &EN
1381
 
      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1
1382
 
     &).ne.4)) THEN
1383
 
      addr = addr + 1
1384
 
      int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (p2b - noab - 1)
1385
 
      int_mb(k_a_offset+length+addr) = size
1386
 
      size = size + int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1)
1387
 
      END IF
1388
 
      END IF
1389
 
      END IF
1390
 
      END DO
1391
 
      END DO
1392
 
      RETURN
1393
 
      END
1394
 
      SUBROUTINE ccsd_t1_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
1395
 
     &t)
1396
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
1397
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1398
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1399
 
C     i1 ( p2 p3 )_vt + = -1 * Sum ( h5 p4 ) * t ( p4 h5 )_t * v ( h5 p2 p3 p4 )_v
1400
 
      IMPLICIT NONE
1401
 
#include "global.fh"
1402
 
#include "mafdecls.fh"
1403
 
#include "sym.fh"
1404
 
#include "errquit.fh"
1405
 
#include "tce.fh"
1406
 
      INTEGER d_a
1407
 
      INTEGER k_a_offset
1408
 
      INTEGER d_b
1409
 
      INTEGER k_b_offset
1410
 
      INTEGER d_c
1411
 
      INTEGER k_c_offset
1412
 
      INTEGER NXTASK
1413
 
      INTEGER next
1414
 
      INTEGER nprocs
1415
 
      INTEGER count
1416
 
      INTEGER p2b
1417
 
      INTEGER p3b
1418
 
      INTEGER dimc
1419
 
      INTEGER l_cs
1420
 
      INTEGER k_cs
1421
 
      INTEGER p4b
1422
 
      INTEGER h5b
1423
 
      INTEGER p4b_1
1424
 
      INTEGER h5b_1
1425
 
      INTEGER p2b_2
1426
 
      INTEGER h5b_2
1427
 
      INTEGER p3b_2
1428
 
      INTEGER p4b_2
1429
 
      INTEGER dim_common
1430
 
      INTEGER dima_sort
1431
 
      INTEGER dima
1432
 
      INTEGER dimb_sort
1433
 
      INTEGER dimb
1434
 
      INTEGER l_as
1435
 
      INTEGER k_as
1436
 
      INTEGER l_a
1437
 
      INTEGER k_a
1438
 
      INTEGER l_bs
1439
 
      INTEGER k_bs
1440
 
      INTEGER l_b
1441
 
      INTEGER k_b
1442
 
      INTEGER l_c
1443
 
      INTEGER k_c
1444
 
      EXTERNAL NXTASK
1445
 
      nprocs = GA_NNODES()
1446
 
      count = 0
1447
 
      next = NXTASK(nprocs, 1)
1448
 
      DO p2b = noab+1,noab+nvab
1449
 
      DO p3b = noab+1,noab+nvab
1450
 
      IF (next.eq.count) THEN
1451
 
      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1
1452
 
     &).ne.4)) THEN
1453
 
      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+p3b-1)) THEN
1454
 
      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+p3b-1)) .eq. ieor(irrep_
1455
 
     &v,irrep_t)) THEN
1456
 
      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1)
1457
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_cs,k_cs)) CALL
1458
 
     & ERRQUIT('ccsd_t1_3_2',0,MA_ERR)
1459
 
      CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1)
1460
 
      DO p4b = noab+1,noab+nvab
1461
 
      DO h5b = 1,noab
1462
 
      IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h5b-1)) THEN
1463
 
      IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h5b-1)) .eq. irrep_t) TH
1464
 
     &EN
1465
 
      CALL TCE_RESTRICTED_2(p4b,h5b,p4b_1,h5b_1)
1466
 
      CALL TCE_RESTRICTED_4(p2b,h5b,p3b,p4b,p2b_2,h5b_2,p3b_2,p4b_2)
1467
 
      dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h5b-1)
1468
 
      dima_sort = 1
1469
 
      dima = dim_common * dima_sort
1470
 
      dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1)
1471
 
      dimb = dim_common * dimb_sort
1472
 
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1473
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as)) CALL
1474
 
     & ERRQUIT('ccsd_t1_3_2',1,MA_ERR)
1475
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1476
 
     &ccsd_t1_3_2',2,MA_ERR)
1477
 
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
1478
 
     & int_mb(k_a_offset),(h5b_1
1479
 
     & - 1 + noab * (p4b_1 - noab - 1)))
1480
 
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p4b-1)
1481
 
     &,int_mb(k_range+h5b-1),2,1,1.0d0)
1482
 
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t1_3_2',3,MA_ERR)
1483
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_bs,k_bs)) CALL
1484
 
     & ERRQUIT('ccsd_t1_3_2',4,MA_ERR)
1485
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1486
 
     &ccsd_t1_3_2',5,MA_ERR)
1487
 
      IF ((h5b .le. p2b) .and. (p4b .lt. p3b)) THEN
1488
 
      if(.not.intorb) then
1489
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
1490
 
     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1491
 
     &+nvab) * (h5b_2 - 1)))))
1492
 
      else
1493
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1494
 
     &(p3b_2
1495
 
     & - 1 + (noab+nvab) * (p4b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1496
 
     &+nvab) * (h5b_2 - 1)))),p3b_2,p4b_2,p2b_2,h5b_2)
1497
 
      end if
1498
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h5b-1)
1499
 
     &,int_mb(k_range+p2b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
1500
 
     &,4,2,1,3,-1.0d0)
1501
 
      END IF
1502
 
      IF ((h5b .le. p2b) .and. (p3b .le. p4b)) THEN
1503
 
      if(.not.intorb) then
1504
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
1505
 
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1506
 
     &+nvab) * (h5b_2 - 1)))))
1507
 
      else
1508
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1509
 
     &(p4b_2
1510
 
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1511
 
     &+nvab) * (h5b_2 - 1)))),p4b_2,p3b_2,p2b_2,h5b_2)
1512
 
      end if
1513
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h5b-1)
1514
 
     &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1)
1515
 
     &,3,2,1,4,1.0d0)
1516
 
      END IF
1517
 
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t1_3_2',6,MA_ERR)
1518
 
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,
1519
 
     1     dbl_mb(k_as),dim_common,dbl_mb(k_bs),dim_common,1.0d0,
1520
 
     2     dbl_mb(k_cs),dima_sort)
1521
 
      IF (.not.MA_POP_STACK(l_bs))
1522
 
     1     CALL ERRQUIT('ccsd_t1_3_2',7,MA_ERR)
1523
 
      IF (.not.MA_POP_STACK(l_as)) 
1524
 
     1     CALL ERRQUIT('ccsd_t1_3_2',8,MA_ERR)
1525
 
      END IF
1526
 
      END IF
1527
 
      END IF
1528
 
      END DO
1529
 
      END DO
1530
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1531
 
     &ccsd_t1_3_2',9,MA_ERR)
1532
 
      CALL TCE_SORT_2(dbl_mb(k_cs),dbl_mb(k_c),int_mb(k_range+p3b-1)
1533
 
     &,int_mb(k_range+p2b-1),2,1,-1.0d0)
1534
 
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
1535
 
     & noab - 1 + nvab * (p2b - noab - 1)))
1536
 
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_t1_3_2',10,MA_ERR)
1537
 
      IF (.not.MA_POP_STACK(l_cs)) CALL ERRQUIT('ccsd_t1_3_2',11,MA_
1538
 
     &ERR)
1539
 
      END IF
1540
 
      END IF
1541
 
      END IF
1542
 
      next = NXTASK(nprocs, 1)
1543
 
      END IF
1544
 
      count = count + 1
1545
 
      END DO
1546
 
      END DO
1547
 
      next = NXTASK(-nprocs, 1)
1548
 
      call GA_SYNC()
1549
 
      RETURN
1550
 
      END
1551
 
      SUBROUTINE ccsd_t1_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
1552
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
1553
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1554
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1555
 
C     i0 ( p2 h1 )_vt + = -1 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 p2 h1 p3 )_v
1556
 
      IMPLICIT NONE
1557
 
#include "global.fh"
1558
 
#include "mafdecls.fh"
1559
 
#include "sym.fh"
1560
 
#include "errquit.fh"
1561
 
#include "tce.fh"
1562
 
      INTEGER d_a
1563
 
      INTEGER k_a_offset
1564
 
      INTEGER d_b
1565
 
      INTEGER k_b_offset
1566
 
      INTEGER d_c
1567
 
      INTEGER k_c_offset
1568
 
      INTEGER NXTASK
1569
 
      INTEGER next
1570
 
      INTEGER nprocs
1571
 
      INTEGER count
1572
 
      INTEGER p2b
1573
 
      INTEGER h1b
1574
 
      INTEGER dimc
1575
 
      INTEGER l_cs
1576
 
      INTEGER k_cs
1577
 
      INTEGER p3b
1578
 
      INTEGER h4b
1579
 
      INTEGER p3b_1
1580
 
      INTEGER h4b_1
1581
 
      INTEGER p2b_2
1582
 
      INTEGER h4b_2
1583
 
      INTEGER h1b_2
1584
 
      INTEGER p3b_2
1585
 
      INTEGER dim_common
1586
 
      INTEGER dima_sort
1587
 
      INTEGER dima
1588
 
      INTEGER dimb_sort
1589
 
      INTEGER dimb
1590
 
      INTEGER l_as
1591
 
      INTEGER k_as
1592
 
      INTEGER l_a
1593
 
      INTEGER k_a
1594
 
      INTEGER l_bs
1595
 
      INTEGER k_bs
1596
 
      INTEGER l_b
1597
 
      INTEGER k_b
1598
 
      INTEGER l_c
1599
 
      INTEGER k_c
1600
 
      EXTERNAL NXTASK
1601
 
      nprocs = GA_NNODES()
1602
 
      count = 0
1603
 
      next = NXTASK(nprocs, 1)
1604
 
      DO p2b = noab+1,noab+nvab
1605
 
      DO h1b = 1,noab
1606
 
      IF (next.eq.count) THEN
1607
 
      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
1608
 
     &).ne.4)) THEN
1609
 
      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1610
 
      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
1611
 
     &v,irrep_t)) THEN
1612
 
      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
1613
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_cs,k_cs)) CALL
1614
 
     & ERRQUIT('ccsd_t1_4',0,MA_ERR)
1615
 
      CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1)
1616
 
      DO p3b = noab+1,noab+nvab
1617
 
      DO h4b = 1,noab
1618
 
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN
1619
 
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_t) TH
1620
 
     &EN
1621
 
      CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1)
1622
 
      CALL TCE_RESTRICTED_4(p2b,h4b,h1b,p3b,p2b_2,h4b_2,h1b_2,p3b_2)
1623
 
      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1)
1624
 
      dima_sort = 1
1625
 
      dima = dim_common * dima_sort
1626
 
      dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
1627
 
      dimb = dim_common * dimb_sort
1628
 
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1629
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as)) CALL
1630
 
     & ERRQUIT('ccsd_t1_4',1,MA_ERR)
1631
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
1632
 
     &ccsd_t1_4',2,MA_ERR)
1633
 
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
1634
 
     & int_mb(k_a_offset),(h4b_1
1635
 
     & - 1 + noab * (p3b_1 - noab - 1)))
1636
 
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p3b-1)
1637
 
     &,int_mb(k_range+h4b-1),2,1,1.0d0)
1638
 
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t1_4',3,MA_ERR)
1639
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_bs,k_bs)) CALL
1640
 
     & ERRQUIT('ccsd_t1_4',4,MA_ERR)
1641
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
1642
 
     &ccsd_t1_4',5,MA_ERR)
1643
 
      IF ((h4b .le. p2b) .and. (h1b .le. p3b)) THEN
1644
 
      if(.not.intorb) then
1645
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
1646
 
     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1647
 
     &+nvab) * (h4b_2 - 1)))))
1648
 
      else
1649
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
1650
 
     &(p3b_2
1651
 
     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab
1652
 
     &+nvab) * (h4b_2 - 1)))),p3b_2,h1b_2,p2b_2,h4b_2)
1653
 
      end if
1654
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h4b-1)
1655
 
     &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
1656
 
     &,3,2,1,4,1.0d0)
1657
 
      END IF
1658
 
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t1_4',6,MA_ERR)
1659
 
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,
1660
 
     1     dbl_mb(k_as),dim_common,dbl_mb(k_bs),dim_common,
1661
 
     2     1.0d0,dbl_mb(k_cs),dima_sort)
1662
 
      IF (.not.MA_POP_STACK(l_bs))
1663
 
     1     CALL ERRQUIT('ccsd_t1_4',7,MA_ERR)
1664
 
      IF (.not.MA_POP_STACK(l_as))
1665
 
     1     CALL ERRQUIT('ccsd_t1_4',8,MA_ERR)
1666
 
      END IF
1667
 
      END IF
1668
 
      END IF
1669
 
      END DO
1670
 
      END DO
1671
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
1672
 
     &ccsd_t1_4',9,MA_ERR)
1673
 
      CALL TCE_SORT_2(dbl_mb(k_cs),dbl_mb(k_c),int_mb(k_range+h1b-1)
1674
 
     &,int_mb(k_range+p2b-1),2,1,-1.0d0)
1675
 
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
1676
 
     & 1 + noab * (p2b - noab - 1)))
1677
 
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_t1_4',10,MA_ERR)
1678
 
      IF (.not.MA_POP_STACK(l_cs)) CALL ERRQUIT('ccsd_t1_4',11,MA_ER
1679
 
     &R)
1680
 
      END IF
1681
 
      END IF
1682
 
      END IF
1683
 
      next = NXTASK(nprocs, 1)
1684
 
      END IF
1685
 
      count = count + 1
1686
 
      END DO
1687
 
      END DO
1688
 
      next = NXTASK(-nprocs, 1)
1689
 
      call GA_SYNC()
1690
 
      RETURN
1691
 
      END
1692
 
 
1693
 
 
1694
 
 
1695
 
 
1696
 
      SUBROUTINE ccsd_t1_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
1697
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
1698
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1699
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1700
 
C     i0 ( p2 h1 )_tf + = 1 * Sum ( p7 h8 ) * t ( p2 p7 h1 h8 )_t * i1 ( h8 p7 )_f
1701
 
      IMPLICIT NONE
1702
 
#include "global.fh"
1703
 
#include "mafdecls.fh"
1704
 
#include "sym.fh"
1705
 
#include "errquit.fh"
1706
 
#include "tce.fh"
1707
 
      INTEGER d_a, d_b, d_c
1708
 
      INTEGER k_a_offset, k_b_offset, k_c_offset
1709
 
      INTEGER NXTASK, next, nprocs, count
1710
 
      INTEGER p2b,h1b,p7b,h8b,p2b_1,p7b_1,h1b_1,h8b_1,h8b_2,p7b_2
1711
 
      INTEGER dim_common, dima_sort, dimb_sort, dima, dimb, dimc
1712
 
      INTEGER k_as, l_as, k_cs, l_cs
1713
 
      INTEGER k_a, l_a, k_b, l_b, k_c, l_c
1714
 
      EXTERNAL NXTASK
1715
 
      nprocs = GA_NNODES()
1716
 
      count = 0
1717
 
      next = NXTASK(nprocs, 1)
1718
 
      DO p2b = noab+1,noab+nvab
1719
 
       DO h1b = 1,noab
1720
 
        IF (next.eq.count) THEN
1721
 
         IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)
1722
 
     1                            +int_mb(k_spin+h1b-1).ne.4)) THEN
1723
 
          IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
1724
 
           IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) 
1725
 
     1         .eq. ieor(irrep_t,irrep_f)) THEN
1726
 
            dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
1727
 
            IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_cs,k_cs))
1728
 
     1           CALL ERRQUIT('ccsd_t1_5',0,MA_ERR)
1729
 
            CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1)
1730
 
            DO p7b = noab+1,noab+nvab
1731
 
             DO h8b = 1,noab
1732
 
              IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p7b-1) .eq. 
1733
 
     1            int_mb(k_spin+h1b-1)+int_mb(k_spin+h8b-1)) THEN
1734
 
               IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p7b-1),
1735
 
     1             ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h8b-1)))) 
1736
 
     2             .eq. irrep_t) THEN
1737
 
                CALL TCE_RESTRICTED_4(p2b,p7b,h1b,h8b,
1738
 
     1                                p2b_1,p7b_1,h1b_1,h8b_1)
1739
 
                CALL TCE_RESTRICTED_2(h8b,p7b,h8b_2,p7b_2)
1740
 
                dim_common = int_mb(k_range+p7b-1) 
1741
 
     1                     * int_mb(k_range+h8b-1)
1742
 
                dima_sort = int_mb(k_range+p2b-1)
1743
 
     1                    * int_mb(k_range+h1b-1)
1744
 
                dima = dim_common * dima_sort
1745
 
                dimb_sort = 1
1746
 
                dimb = dim_common * dimb_sort
1747
 
                IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
1748
 
                 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as))
1749
 
     1                CALL ERRQUIT('ccsd_t1_5',1,MA_ERR)
1750
 
                 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a))
1751
 
     1                CALL ERRQUIT('ccsd_t1_5',2,MA_ERR)
1752
 
                 IF ((p7b .lt. p2b) .and. (h8b .lt. h1b)) THEN
1753
 
                  CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,
1754
 
     1                 int_mb(k_a_offset),(h1b_1 - 1 + noab * 
1755
 
     2                 (h8b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * 
1756
 
     3                 (p7b_1 - noab - 1)))))
1757
 
                  CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),
1758
 
     1                 int_mb(k_range+p7b-1),int_mb(k_range+p2b-1),
1759
 
     2                 int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),
1760
 
     3                 4,2,3,1,1.0d0)
1761
 
                 END IF
1762
 
                 IF ((p7b .lt. p2b) .and. (h1b .le. h8b)) THEN
1763
 
                  CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,
1764
 
     1                 int_mb(k_a_offset),(h8b_1 - 1 + noab * 
1765
 
     2                 (h1b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * 
1766
 
     3                 (p7b_1 - noab - 1)))))
1767
 
                  CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),
1768
 
     1                 int_mb(k_range+p7b-1),int_mb(k_range+p2b-1),
1769
 
     2                 int_mb(k_range+h1b-1),int_mb(k_range+h8b-1),
1770
 
     3                 3,2,4,1,-1.0d0)
1771
 
                 END IF
1772
 
                 IF ((p2b .le. p7b) .and. (h8b .lt. h1b)) THEN
1773
 
                  CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,
1774
 
     1                 int_mb(k_a_offset),(h1b_1 - 1 + noab * 
1775
 
     2                 (h8b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * 
1776
 
     3                 (p2b_1 - noab - 1)))))
1777
 
                  CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),
1778
 
     1                 int_mb(k_range+p2b-1),int_mb(k_range+p7b-1),
1779
 
     2                 int_mb(k_range+h8b-1),int_mb(k_range+h1b-1),
1780
 
     3                 4,1,3,2,-1.0d0)
1781
 
                 END IF
1782
 
                 IF ((p2b .le. p7b) .and. (h1b .le. h8b)) THEN
1783
 
                  CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,
1784
 
     1                 int_mb(k_a_offset),(h8b_1 - 1 + noab * 
1785
 
     2                 (h1b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * 
1786
 
     3                 (p2b_1 - noab - 1)))))
1787
 
                  CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),
1788
 
     1                 int_mb(k_range+p2b-1),int_mb(k_range+p7b-1),
1789
 
     2                 int_mb(k_range+h1b-1),int_mb(k_range+h8b-1),
1790
 
     3                 3,1,4,2,1.0d0)
1791
 
                 END IF
1792
 
                 IF (.not.MA_POP_STACK(l_a)) 
1793
 
     1                CALL ERRQUIT('ccsd_t1_5',3,MA_ERR)
1794
 
                 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) 
1795
 
     1                CALL ERRQUIT('ccsd_t1_5',5,MA_ERR)
1796
 
                 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,
1797
 
     1                int_mb(k_b_offset),(p7b_2 - noab - 1 + nvab * 
1798
 
     2                (h8b_2 - 1)))
1799
 
                 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,
1800
 
     1                1.0d0,dbl_mb(k_as),dim_common,dbl_mb(k_b),
1801
 
     2                dim_common,1.0d0,dbl_mb(k_cs),dima_sort)
1802
 
                 IF (.not.MA_POP_STACK(l_b))
1803
 
     1                CALL ERRQUIT('ccsd_t1_5',7,MA_ERR)
1804
 
                 IF (.not.MA_POP_STACK(l_as))
1805
 
     1                CALL ERRQUIT('ccsd_t1_5',8,MA_ERR)
1806
 
                END IF
1807
 
               END IF
1808
 
              END IF
1809
 
             END DO
1810
 
            END DO
1811
 
            IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c))
1812
 
     1           CALL ERRQUIT('ccsd_t1_5',9,MA_ERR)
1813
 
            CALL TCE_SORT_2(dbl_mb(k_cs),dbl_mb(k_c),
1814
 
     1           int_mb(k_range+h1b-1),int_mb(k_range+p2b-1),
1815
 
     2           2,1,1.0d0)
1816
 
            CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,
1817
 
     1           int_mb(k_c_offset),
1818
 
     2           (h1b - 1 + noab * (p2b - noab - 1)))
1819
 
            IF (.not.MA_POP_STACK(l_c)) 
1820
 
     1           CALL ERRQUIT('ccsd_t1_5',10,MA_ERR)
1821
 
            IF (.not.MA_POP_STACK(l_cs))
1822
 
     1           CALL ERRQUIT('ccsd_t1_5',11,MA_ERR)
1823
 
           END IF
1824
 
          END IF
1825
 
         END IF
1826
 
         next = NXTASK(nprocs, 1)
1827
 
        END IF
1828
 
        count = count + 1
1829
 
       END DO
1830
 
      END DO
1831
 
      next = NXTASK(-nprocs, 1)
1832
 
      call GA_SYNC()
1833
 
      RETURN
1834
 
      END
1835
 
 
1836
 
 
1837
 
 
1838
 
 
1839
 
 
1840
 
 
1841
 
      SUBROUTINE ccsd_t1_5_1(d_a,k_a_offset,d_c,k_c_offset)
1842
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
1843
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1844
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1845
 
C     i1 ( h8 p7 )_f + = 1 * f ( h8 p7 )_f
1846
 
      IMPLICIT NONE
1847
 
#include "global.fh"
1848
 
#include "mafdecls.fh"
1849
 
#include "sym.fh"
1850
 
#include "errquit.fh"
1851
 
#include "tce.fh"
1852
 
      INTEGER d_a, d_c
1853
 
      INTEGER k_a_offset, k_c_offset
1854
 
      INTEGER NXTASK, next, nprocs, count
1855
 
      INTEGER h8b, p7b, h8b_1, p7b_1
1856
 
      INTEGER dimc
1857
 
      INTEGER k_a, l_a
1858
 
      EXTERNAL NXTASK
1859
 
      nprocs = GA_NNODES()
1860
 
      count = 0
1861
 
      next = NXTASK(nprocs, 1)
1862
 
      DO h8b = 1,noab
1863
 
       DO p7b = noab+1,noab+nvab
1864
 
        IF (next.eq.count) THEN
1865
 
         IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)
1866
 
     1                            +int_mb(k_spin+p7b-1).ne.4)) THEN
1867
 
          IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p7b-1)) THEN
1868
 
           IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p7b-1)) 
1869
 
     1         .eq. irrep_f) THEN
1870
 
            dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p7b-1)
1871
 
            CALL TCE_RESTRICTED_2(h8b,p7b,h8b_1,p7b_1)
1872
 
            IF (dimc .gt. 0) THEN
1873
 
             IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_a,k_a)) 
1874
 
     1            CALL ERRQUIT('ccsd_t1_5_1',1,MA_ERR)
1875
 
             CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dimc,
1876
 
     1            int_mb(k_a_offset),
1877
 
     2            (p7b_1 - 1 + (noab+nvab) * (h8b_1 - 1)))
1878
 
             CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_a),dimc,
1879
 
     1            int_mb(k_c_offset),
1880
 
     2            (p7b - noab - 1 + nvab * (h8b - 1)))
1881
 
             IF (.not.MA_POP_STACK(l_a))
1882
 
     1            CALL ERRQUIT('ccsd_t1_5_1',5,MA_ERR)
1883
 
            END IF
1884
 
           END IF
1885
 
          END IF
1886
 
         END IF
1887
 
         next = NXTASK(nprocs, 1)
1888
 
        END IF
1889
 
        count = count + 1
1890
 
       END DO
1891
 
      END DO
1892
 
      next = NXTASK(-nprocs, 1)
1893
 
      call GA_SYNC()
1894
 
      RETURN
1895
 
      END
1896
 
 
1897
 
 
1898
 
 
1899
 
 
1900
 
      SUBROUTINE OFFSET_ccsd_t1_5_1(l_a_offset,k_a_offset,size)
1901
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
1902
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1903
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1904
 
C     i1 ( h8 p7 )_f
1905
 
      IMPLICIT NONE
1906
 
#include "global.fh"
1907
 
#include "mafdecls.fh"
1908
 
#include "sym.fh"
1909
 
#include "errquit.fh"
1910
 
#include "tce.fh"
1911
 
      INTEGER l_a_offset
1912
 
      INTEGER k_a_offset
1913
 
      INTEGER size
1914
 
      INTEGER length
1915
 
      INTEGER addr
1916
 
      INTEGER h8b
1917
 
      INTEGER p7b
1918
 
      length = 0
1919
 
      DO h8b = 1,noab
1920
 
      DO p7b = noab+1,noab+nvab
1921
 
      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p7b-1)) THEN
1922
 
      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH
1923
 
     &EN
1924
 
      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p7b-1
1925
 
     &).ne.4)) THEN
1926
 
      length = length + 1
1927
 
      END IF
1928
 
      END IF
1929
 
      END IF
1930
 
      END DO
1931
 
      END DO
1932
 
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
1933
 
     &set)) CALL ERRQUIT('ccsd_t1_5_1',0,MA_ERR)
1934
 
      int_mb(k_a_offset) = length
1935
 
      addr = 0
1936
 
      size = 0
1937
 
      DO h8b = 1,noab
1938
 
      DO p7b = noab+1,noab+nvab
1939
 
      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p7b-1)) THEN
1940
 
      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p7b-1)) .eq. irrep_f) TH
1941
 
     &EN
1942
 
      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p7b-1
1943
 
     &).ne.4)) THEN
1944
 
      addr = addr + 1
1945
 
      int_mb(k_a_offset+addr) = p7b - noab - 1 + nvab * (h8b - 1)
1946
 
      int_mb(k_a_offset+length+addr) = size
1947
 
      size = size + int_mb(k_range+h8b-1) * int_mb(k_range+p7b-1)
1948
 
      END IF
1949
 
      END IF
1950
 
      END IF
1951
 
      END DO
1952
 
      END DO
1953
 
      RETURN
1954
 
      END
1955
 
      SUBROUTINE ccsd_t1_5_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
1956
 
     &t)
1957
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
1958
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
1959
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
1960
 
C     i1 ( h8 p7 )_vt + = 1 * Sum ( h6 p5 ) * t ( p5 h6 )_t * v ( h6 h8 p5 p7 )_v
1961
 
      IMPLICIT NONE
1962
 
#include "global.fh"
1963
 
#include "mafdecls.fh"
1964
 
#include "sym.fh"
1965
 
#include "errquit.fh"
1966
 
#include "tce.fh"
1967
 
      INTEGER d_a
1968
 
      INTEGER k_a_offset
1969
 
      INTEGER d_b
1970
 
      INTEGER k_b_offset
1971
 
      INTEGER d_c
1972
 
      INTEGER k_c_offset
1973
 
      INTEGER NXTASK
1974
 
      INTEGER next
1975
 
      INTEGER nprocs
1976
 
      INTEGER count
1977
 
      INTEGER h8b
1978
 
      INTEGER p7b
1979
 
      INTEGER dimc
1980
 
      INTEGER l_cs
1981
 
      INTEGER k_cs
1982
 
      INTEGER p5b
1983
 
      INTEGER h6b
1984
 
      INTEGER p5b_1
1985
 
      INTEGER h6b_1
1986
 
      INTEGER h8b_2
1987
 
      INTEGER h6b_2
1988
 
      INTEGER p7b_2
1989
 
      INTEGER p5b_2
1990
 
      INTEGER dim_common
1991
 
      INTEGER dima_sort
1992
 
      INTEGER dima
1993
 
      INTEGER dimb_sort
1994
 
      INTEGER dimb
1995
 
      INTEGER l_as
1996
 
      INTEGER k_as
1997
 
      INTEGER l_a
1998
 
      INTEGER k_a
1999
 
      INTEGER l_bs
2000
 
      INTEGER k_bs
2001
 
      INTEGER l_b
2002
 
      INTEGER k_b
2003
 
      INTEGER l_c
2004
 
      INTEGER k_c
2005
 
      EXTERNAL NXTASK
2006
 
      nprocs = GA_NNODES()
2007
 
      count = 0
2008
 
      next = NXTASK(nprocs, 1)
2009
 
      DO h8b = 1,noab
2010
 
      DO p7b = noab+1,noab+nvab
2011
 
      IF (next.eq.count) THEN
2012
 
      IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+p7b-1
2013
 
     &).ne.4)) THEN
2014
 
      IF (int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p7b-1)) THEN
2015
 
      IF (ieor(int_mb(k_sym+h8b-1),int_mb(k_sym+p7b-1)) .eq. ieor(irrep_
2016
 
     &v,irrep_t)) THEN
2017
 
      dimc = int_mb(k_range+h8b-1) * int_mb(k_range+p7b-1)
2018
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_cs,k_cs)) CALL
2019
 
     & ERRQUIT('ccsd_t1_5_2',0,MA_ERR)
2020
 
      CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1)
2021
 
      DO p5b = noab+1,noab+nvab
2022
 
      DO h6b = 1,noab
2023
 
      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h6b-1)) THEN
2024
 
      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h6b-1)) .eq. irrep_t) TH
2025
 
     &EN
2026
 
      CALL TCE_RESTRICTED_2(p5b,h6b,p5b_1,h6b_1)
2027
 
      CALL TCE_RESTRICTED_4(h8b,h6b,p7b,p5b,h8b_2,h6b_2,p7b_2,p5b_2)
2028
 
      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1)
2029
 
      dima_sort = 1
2030
 
      dima = dim_common * dima_sort
2031
 
      dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p7b-1)
2032
 
      dimb = dim_common * dimb_sort
2033
 
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2034
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as)) CALL
2035
 
     & ERRQUIT('ccsd_t1_5_2',1,MA_ERR)
2036
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2037
 
     &ccsd_t1_5_2',2,MA_ERR)
2038
 
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
2039
 
     & int_mb(k_a_offset),(h6b_1
2040
 
     & - 1 + noab * (p5b_1 - noab - 1)))
2041
 
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p5b-1)
2042
 
     &,int_mb(k_range+h6b-1),2,1,1.0d0)
2043
 
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t1_5_2',3,MA_ERR)
2044
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_bs,k_bs)) CALL
2045
 
     & ERRQUIT('ccsd_t1_5_2',4,MA_ERR)
2046
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2047
 
     &ccsd_t1_5_2',5,MA_ERR)
2048
 
      IF ((h6b .le. h8b) .and. (p5b .le. p7b)) THEN
2049
 
      if(.not.intorb) then
2050
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
2051
 
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
2052
 
     &+nvab) * (h6b_2 - 1)))))
2053
 
      else
2054
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2055
 
     &(p7b_2
2056
 
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
2057
 
     &+nvab) * (h6b_2 - 1)))),p7b_2,p5b_2,h8b_2,h6b_2)
2058
 
      end if
2059
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h6b-1)
2060
 
     &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1)
2061
 
     &,4,2,1,3,1.0d0)
2062
 
      END IF
2063
 
      IF ((h6b .le. h8b) .and. (p7b .lt. p5b)) THEN
2064
 
      if(.not.intorb) then
2065
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
2066
 
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
2067
 
     &+nvab) * (h6b_2 - 1)))))
2068
 
      else
2069
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2070
 
     &(p5b_2
2071
 
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
2072
 
     &+nvab) * (h6b_2 - 1)))),p5b_2,p7b_2,h8b_2,h6b_2)
2073
 
      end if
2074
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h6b-1)
2075
 
     &,int_mb(k_range+h8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1)
2076
 
     &,3,2,1,4,-1.0d0)
2077
 
      END IF
2078
 
      IF ((h8b .lt. h6b) .and. (p5b .le. p7b)) THEN
2079
 
      if(.not.intorb) then
2080
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
2081
 
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
2082
 
     &+nvab) * (h8b_2 - 1)))))
2083
 
      else
2084
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2085
 
     &(p7b_2
2086
 
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
2087
 
     &+nvab) * (h8b_2 - 1)))),p7b_2,p5b_2,h6b_2,h8b_2)
2088
 
      end if
2089
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h8b-1)
2090
 
     &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1)
2091
 
     &,4,1,2,3,-1.0d0)
2092
 
      END IF
2093
 
      IF ((h8b .lt. h6b) .and. (p7b .lt. p5b)) THEN
2094
 
      if(.not.intorb) then
2095
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
2096
 
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
2097
 
     &+nvab) * (h8b_2 - 1)))))
2098
 
      else
2099
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2100
 
     &(p5b_2
2101
 
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
2102
 
     &+nvab) * (h8b_2 - 1)))),p5b_2,p7b_2,h6b_2,h8b_2)
2103
 
      end if 
2104
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h8b-1)
2105
 
     &,int_mb(k_range+h6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1)
2106
 
     &,3,1,2,4,1.0d0)
2107
 
      END IF
2108
 
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t1_5_2',6,MA_ERR)
2109
 
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,
2110
 
     1     dbl_mb(k_as),dim_common,dbl_mb(k_bs),dim_common,
2111
 
     2     1.0d0,dbl_mb(k_cs),dima_sort)
2112
 
      IF (.not.MA_POP_STACK(l_bs))
2113
 
     1     CALL ERRQUIT('ccsd_t1_5_2',7,MA_ERR)
2114
 
      IF (.not.MA_POP_STACK(l_as))
2115
 
     1     CALL ERRQUIT('ccsd_t1_5_2',8,MA_ERR)
2116
 
      END IF
2117
 
      END IF
2118
 
      END IF
2119
 
      END DO
2120
 
      END DO
2121
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2122
 
     &ccsd_t1_5_2',9,MA_ERR)
2123
 
      CALL TCE_SORT_2(dbl_mb(k_cs),dbl_mb(k_c),int_mb(k_range+p7b-1)
2124
 
     &,int_mb(k_range+h8b-1),2,1,1.0d0)
2125
 
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b -
2126
 
     & noab - 1 + nvab * (h8b - 1)))
2127
 
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_t1_5_2',10,MA_ERR)
2128
 
      IF (.not.MA_POP_STACK(l_cs)) CALL ERRQUIT('ccsd_t1_5_2',11,MA_
2129
 
     &ERR)
2130
 
      END IF
2131
 
      END IF
2132
 
      END IF
2133
 
      next = NXTASK(nprocs, 1)
2134
 
      END IF
2135
 
      count = count + 1
2136
 
      END DO
2137
 
      END DO
2138
 
      next = NXTASK(-nprocs, 1)
2139
 
      call GA_SYNC()
2140
 
      RETURN
2141
 
      END
2142
 
      SUBROUTINE ccsd_t1_6(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
2143
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
2144
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2145
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2146
 
C     i0 ( p2 h1 )_vt + = -1/2 * Sum ( h4 h5 p3 ) * t ( p2 p3 h4 h5 )_t * i1 ( h4 h5 h1 p3 )_v
2147
 
      IMPLICIT NONE
2148
 
#include "global.fh"
2149
 
#include "mafdecls.fh"
2150
 
#include "sym.fh"
2151
 
#include "errquit.fh"
2152
 
#include "tce.fh"
2153
 
      INTEGER d_a
2154
 
      INTEGER k_a_offset
2155
 
      INTEGER d_b
2156
 
      INTEGER k_b_offset
2157
 
      INTEGER d_c
2158
 
      INTEGER k_c_offset
2159
 
      INTEGER NXTASK
2160
 
      INTEGER next
2161
 
      INTEGER nprocs
2162
 
      INTEGER count
2163
 
      INTEGER p2b
2164
 
      INTEGER h1b
2165
 
      INTEGER dimc
2166
 
      INTEGER l_cs
2167
 
      INTEGER k_cs
2168
 
      INTEGER p3b
2169
 
      INTEGER h4b
2170
 
      INTEGER h5b
2171
 
      INTEGER p2b_1
2172
 
      INTEGER p3b_1
2173
 
      INTEGER h4b_1
2174
 
      INTEGER h5b_1
2175
 
      INTEGER h4b_2
2176
 
      INTEGER h5b_2
2177
 
      INTEGER h1b_2
2178
 
      INTEGER p3b_2
2179
 
      INTEGER dim_common
2180
 
      INTEGER dima_sort
2181
 
      INTEGER dima
2182
 
      INTEGER dimb_sort
2183
 
      INTEGER dimb
2184
 
      INTEGER l_as
2185
 
      INTEGER k_as
2186
 
      INTEGER l_a
2187
 
      INTEGER k_a
2188
 
      INTEGER l_bs
2189
 
      INTEGER k_bs
2190
 
      INTEGER l_b
2191
 
      INTEGER k_b
2192
 
      INTEGER nsubh(2)
2193
 
      INTEGER isubh
2194
 
      INTEGER l_c
2195
 
      INTEGER k_c
2196
 
      DOUBLE PRECISION FACTORIAL
2197
 
      EXTERNAL NXTASK
2198
 
      EXTERNAL FACTORIAL
2199
 
      nprocs = GA_NNODES()
2200
 
      count = 0
2201
 
      next = NXTASK(nprocs, 1)
2202
 
      DO p2b = noab+1,noab+nvab
2203
 
      DO h1b = 1,noab
2204
 
      IF (next.eq.count) THEN
2205
 
      IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1
2206
 
     &).ne.4)) THEN
2207
 
      IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2208
 
      IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
2209
 
     &v,irrep_t)) THEN
2210
 
      dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
2211
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_cs,k_cs)) CALL
2212
 
     & ERRQUIT('ccsd_t1_6',0,MA_ERR)
2213
 
      CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1)
2214
 
      DO p3b = noab+1,noab+nvab
2215
 
      DO h4b = 1,noab
2216
 
      DO h5b = h4b,noab
2217
 
      IF (int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
2218
 
     &4b-1)+int_mb(k_spin+h5b-1)) THEN
2219
 
      IF (ieor(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
2220
 
     &k_sym+h4b-1),int_mb(k_sym+h5b-1)))) .eq. irrep_t) THEN
2221
 
      CALL TCE_RESTRICTED_4(p2b,p3b,h4b,h5b,p2b_1,p3b_1,h4b_1,h5b_1)
2222
 
      CALL TCE_RESTRICTED_4(h4b,h5b,h1b,p3b,h4b_2,h5b_2,h1b_2,p3b_2)
2223
 
      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) * int_m
2224
 
     &b(k_range+h5b-1)
2225
 
      dima_sort = int_mb(k_range+p2b-1)
2226
 
      dima = dim_common * dima_sort
2227
 
      dimb_sort = int_mb(k_range+h1b-1)
2228
 
      dimb = dim_common * dimb_sort
2229
 
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2230
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as)) CALL
2231
 
     & ERRQUIT('ccsd_t1_6',1,MA_ERR)
2232
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2233
 
     &ccsd_t1_6',2,MA_ERR)
2234
 
      IF ((p3b .lt. p2b)) THEN
2235
 
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1
2236
 
     & - 1 + noab * (h4b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p3b_
2237
 
     &1 - noab - 1)))))
2238
 
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p3b-1)
2239
 
     &,int_mb(k_range+p2b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1)
2240
 
     &,2,4,3,1,-1.0d0)
2241
 
      END IF
2242
 
      IF ((p2b .le. p3b)) THEN
2243
 
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h5b_1
2244
 
     & - 1 + noab * (h4b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p2b_
2245
 
     &1 - noab - 1)))))
2246
 
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p2b-1)
2247
 
     &,int_mb(k_range+p3b-1),int_mb(k_range+h4b-1),int_mb(k_range+h5b-1)
2248
 
     &,1,4,3,2,1.0d0)
2249
 
      END IF
2250
 
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t1_6',3,MA_ERR)
2251
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_bs,k_bs)) CALL
2252
 
     & ERRQUIT('ccsd_t1_6',4,MA_ERR)
2253
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2254
 
     &ccsd_t1_6',5,MA_ERR)
2255
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
2256
 
     & - noab - 1 + nvab * (h1b_2 - 1 + noab * (h5b_2 - 1 + noab * (h4b_
2257
 
     &2 - 1)))))
2258
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h4b-1)
2259
 
     &,int_mb(k_range+h5b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
2260
 
     &,3,2,1,4,1.0d0)
2261
 
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t1_6',6,MA_ERR)
2262
 
      nsubh(1) = 1
2263
 
      nsubh(2) = 1
2264
 
      isubh = 1
2265
 
      IF (h4b .eq. h5b) THEN
2266
 
      nsubh(isubh) = nsubh(isubh) + 1
2267
 
      ELSE
2268
 
      isubh = isubh + 1
2269
 
      END IF
2270
 
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,
2271
 
     1     2.0d0/FACTORIAL(nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_as),
2272
 
     2     dim_common,dbl_mb(k_bs),dim_common,1.0d0,dbl_mb(k_cs),
2273
 
     3     dima_sort)
2274
 
      IF (.not.MA_POP_STACK(l_bs))
2275
 
     1     CALL ERRQUIT('ccsd_t1_6',7,MA_ERR)
2276
 
      IF (.not.MA_POP_STACK(l_as))
2277
 
     2     CALL ERRQUIT('ccsd_t1_6',8,MA_ERR)
2278
 
      END IF
2279
 
      END IF
2280
 
      END IF
2281
 
      END DO
2282
 
      END DO
2283
 
      END DO
2284
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
2285
 
     &ccsd_t1_6',9,MA_ERR)
2286
 
      CALL TCE_SORT_2(dbl_mb(k_cs),dbl_mb(k_c),int_mb(k_range+h1b-1)
2287
 
     &,int_mb(k_range+p2b-1),2,1,-1.0d0/2.0d0)
2288
 
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
2289
 
     & 1 + noab * (p2b - noab - 1)))
2290
 
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_t1_6',10,MA_ERR)
2291
 
      IF (.not.MA_POP_STACK(l_cs)) CALL ERRQUIT('ccsd_t1_6',11,MA_ER
2292
 
     &R)
2293
 
      END IF
2294
 
      END IF
2295
 
      END IF
2296
 
      next = NXTASK(nprocs, 1)
2297
 
      END IF
2298
 
      count = count + 1
2299
 
      END DO
2300
 
      END DO
2301
 
      next = NXTASK(-nprocs, 1)
2302
 
      call GA_SYNC()
2303
 
      RETURN
2304
 
      END
2305
 
 
2306
 
 
2307
 
 
2308
 
 
2309
 
 
2310
 
      SUBROUTINE ccsd_t1_6_1(d_a,k_a_offset,d_c,k_c_offset)
2311
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
2312
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2313
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2314
 
C     i1 ( h4 h5 h1 p3 )_v + = 1 * v ( h4 h5 h1 p3 )_v
2315
 
      IMPLICIT NONE
2316
 
#include "global.fh"
2317
 
#include "mafdecls.fh"
2318
 
#include "sym.fh"
2319
 
#include "errquit.fh"
2320
 
#include "tce.fh"
2321
 
      INTEGER d_a, d_c
2322
 
      INTEGER k_a_offset, k_c_offset
2323
 
      INTEGER NXTASK, next, nprocs, count
2324
 
      INTEGER h4b, h5b, h1b, p3b, h4b_1, h5b_1, h1b_1, p3b_1
2325
 
      INTEGER dimc
2326
 
      INTEGER k_a, l_a
2327
 
      EXTERNAL NXTASK
2328
 
      nprocs = GA_NNODES()
2329
 
      count = 0
2330
 
      next = NXTASK(nprocs, 1)
2331
 
      DO h4b = 1,noab
2332
 
       DO h5b = h4b,noab
2333
 
        DO h1b = 1,noab
2334
 
         DO p3b = noab+1,noab+nvab
2335
 
          IF (next.eq.count) THEN
2336
 
           IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)
2337
 
     1          +int_mb(k_spin+h5b-1)+int_mb(k_spin+h1b-1)
2338
 
     2          +int_mb(k_spin+p3b-1).ne.8)) THEN
2339
 
            IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. 
2340
 
     1          int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1)) THEN
2341
 
             IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),
2342
 
     1           ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+p3b-1)))) 
2343
 
     2           .eq. irrep_v) THEN
2344
 
              dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) 
2345
 
     1             * int_mb(k_range+h1b-1) * int_mb(k_range+p3b-1)
2346
 
              CALL TCE_RESTRICTED_4(h4b,h5b,h1b,p3b,
2347
 
     1                              h4b_1,h5b_1,h1b_1,p3b_1)
2348
 
              IF (dimc .gt. 0) THEN
2349
 
               IF (.not.MA_PUSH_GET(mt_dbl,dimc,'a',l_a,k_a)) 
2350
 
     1              CALL ERRQUIT('ccsd_t1_6_1',1,MA_ERR)
2351
 
               IF ((h1b .le. p3b)) THEN
2352
 
                if(.not.intorb) then
2353
 
                 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dimc,
2354
 
     1                int_mb(k_a_offset),(p3b_1 - 1 + (noab+nvab) * 
2355
 
     2                (h1b_1 - 1 + (noab+nvab) * (h5b_1 - 1 + 
2356
 
     3                (noab+nvab) * (h4b_1 - 1)))))
2357
 
                else
2358
 
                 CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dimc,
2359
 
     1                int_mb(k_a_offset),(p3b_1 - 1 + (noab+nvab) * 
2360
 
     2                (h1b_1 - 1 + (noab+nvab) * (h5b_1 - 1 + 
2361
 
     3                (noab+nvab) * (h4b_1 - 1)))),
2362
 
     4                p3b_1,h1b_1,h5b_1,h4b_1)
2363
 
                end if
2364
 
               END IF
2365
 
               CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_a),dimc,
2366
 
     1              int_mb(k_c_offset),(p3b - noab - 1 + nvab * 
2367
 
     2              (h1b - 1 + noab * (h5b - 1 + noab * (h4b - 1)))))
2368
 
               IF (.not.MA_POP_STACK(l_a))
2369
 
     1              CALL ERRQUIT('ccsd_t1_6_1',5,MA_ERR)
2370
 
              END IF
2371
 
             END IF
2372
 
            END IF
2373
 
           END IF
2374
 
           next = NXTASK(nprocs, 1)
2375
 
          END IF
2376
 
          count = count + 1
2377
 
         END DO
2378
 
        END DO
2379
 
       END DO
2380
 
      END DO
2381
 
      next = NXTASK(-nprocs, 1)
2382
 
      call GA_SYNC()
2383
 
      RETURN
2384
 
      END
2385
 
 
2386
 
 
2387
 
 
2388
 
 
2389
 
      SUBROUTINE OFFSET_ccsd_t1_6_1(l_a_offset,k_a_offset,size)
2390
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
2391
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2392
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2393
 
C     i1 ( h4 h5 h1 p3 )_v
2394
 
      IMPLICIT NONE
2395
 
#include "global.fh"
2396
 
#include "mafdecls.fh"
2397
 
#include "sym.fh"
2398
 
#include "errquit.fh"
2399
 
#include "tce.fh"
2400
 
      INTEGER l_a_offset
2401
 
      INTEGER k_a_offset
2402
 
      INTEGER size
2403
 
      INTEGER length
2404
 
      INTEGER addr
2405
 
      INTEGER h4b
2406
 
      INTEGER h5b
2407
 
      INTEGER h1b
2408
 
      INTEGER p3b
2409
 
      length = 0
2410
 
      DO h4b = 1,noab
2411
 
      DO h5b = h4b,noab
2412
 
      DO h1b = 1,noab
2413
 
      DO p3b = noab+1,noab+nvab
2414
 
      IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h
2415
 
     &1b-1)+int_mb(k_spin+p3b-1)) THEN
2416
 
      IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb(
2417
 
     &k_sym+h1b-1),int_mb(k_sym+p3b-1)))) .eq. irrep_v) THEN
2418
 
      IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1
2419
 
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN
2420
 
      length = length + 1
2421
 
      END IF
2422
 
      END IF
2423
 
      END IF
2424
 
      END DO
2425
 
      END DO
2426
 
      END DO
2427
 
      END DO
2428
 
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
2429
 
     &set)) CALL ERRQUIT('ccsd_t1_6_1',0,MA_ERR)
2430
 
      int_mb(k_a_offset) = length
2431
 
      addr = 0
2432
 
      size = 0
2433
 
      DO h4b = 1,noab
2434
 
      DO h5b = h4b,noab
2435
 
      DO h1b = 1,noab
2436
 
      DO p3b = noab+1,noab+nvab
2437
 
      IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h
2438
 
     &1b-1)+int_mb(k_spin+p3b-1)) THEN
2439
 
      IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb(
2440
 
     &k_sym+h1b-1),int_mb(k_sym+p3b-1)))) .eq. irrep_v) THEN
2441
 
      IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1
2442
 
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN
2443
 
      addr = addr + 1
2444
 
      int_mb(k_a_offset+addr) = p3b - noab - 1 + nvab * (h1b - 1 + noab 
2445
 
     &* (h5b - 1 + noab * (h4b - 1)))
2446
 
      int_mb(k_a_offset+length+addr) = size
2447
 
      size = size + int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_
2448
 
     &mb(k_range+h1b-1) * int_mb(k_range+p3b-1)
2449
 
      END IF
2450
 
      END IF
2451
 
      END IF
2452
 
      END DO
2453
 
      END DO
2454
 
      END DO
2455
 
      END DO
2456
 
      RETURN
2457
 
      END
2458
 
      SUBROUTINE ccsd_t1_6_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
2459
 
     &t)
2460
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
2461
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2462
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2463
 
C     i1 ( h4 h5 h1 p3 )_vt + = -1 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h4 h5 p3 p6 )_v
2464
 
      IMPLICIT NONE
2465
 
#include "global.fh"
2466
 
#include "mafdecls.fh"
2467
 
#include "sym.fh"
2468
 
#include "errquit.fh"
2469
 
#include "tce.fh"
2470
 
      INTEGER d_a
2471
 
      INTEGER k_a_offset
2472
 
      INTEGER d_b
2473
 
      INTEGER k_b_offset
2474
 
      INTEGER d_c
2475
 
      INTEGER k_c_offset
2476
 
      INTEGER NXTASK
2477
 
      INTEGER next
2478
 
      INTEGER nprocs
2479
 
      INTEGER count
2480
 
      INTEGER h4b
2481
 
      INTEGER h5b
2482
 
      INTEGER h1b
2483
 
      INTEGER p3b
2484
 
      INTEGER dimc
2485
 
      INTEGER l_cs
2486
 
      INTEGER k_cs
2487
 
      INTEGER p6b
2488
 
      INTEGER p6b_1
2489
 
      INTEGER h1b_1
2490
 
      INTEGER h4b_2
2491
 
      INTEGER h5b_2
2492
 
      INTEGER p3b_2
2493
 
      INTEGER p6b_2
2494
 
      INTEGER dim_common
2495
 
      INTEGER dima_sort
2496
 
      INTEGER dima
2497
 
      INTEGER dimb_sort
2498
 
      INTEGER dimb
2499
 
      INTEGER l_as
2500
 
      INTEGER k_as
2501
 
      INTEGER l_a
2502
 
      INTEGER k_a
2503
 
      INTEGER l_bs
2504
 
      INTEGER k_bs
2505
 
      INTEGER l_b
2506
 
      INTEGER k_b
2507
 
      INTEGER l_c
2508
 
      INTEGER k_c
2509
 
      EXTERNAL NXTASK
2510
 
      nprocs = GA_NNODES()
2511
 
      count = 0
2512
 
      next = NXTASK(nprocs, 1)
2513
 
      DO h4b = 1,noab
2514
 
      DO h5b = h4b,noab
2515
 
      DO h1b = 1,noab
2516
 
      DO p3b = noab+1,noab+nvab
2517
 
      IF (next.eq.count) THEN
2518
 
      IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1
2519
 
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1).ne.8)) THEN
2520
 
      IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h
2521
 
     &1b-1)+int_mb(k_spin+p3b-1)) THEN
2522
 
      IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb(
2523
 
     &k_sym+h1b-1),int_mb(k_sym+p3b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
2524
 
     &EN
2525
 
      dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra
2526
 
     &nge+h1b-1) * int_mb(k_range+p3b-1)
2527
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_cs,k_cs)) CALL
2528
 
     & ERRQUIT('ccsd_t1_6_2',0,MA_ERR)
2529
 
      CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1)
2530
 
      DO p6b = noab+1,noab+nvab
2531
 
      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2532
 
      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
2533
 
     &EN
2534
 
      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
2535
 
      CALL TCE_RESTRICTED_4(h4b,h5b,p3b,p6b,h4b_2,h5b_2,p3b_2,p6b_2)
2536
 
      dim_common = int_mb(k_range+p6b-1)
2537
 
      dima_sort = int_mb(k_range+h1b-1)
2538
 
      dima = dim_common * dima_sort
2539
 
      dimb_sort = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb
2540
 
     &(k_range+p3b-1)
2541
 
      dimb = dim_common * dimb_sort
2542
 
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2543
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as)) CALL
2544
 
     & ERRQUIT('ccsd_t1_6_2',1,MA_ERR)
2545
 
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
2546
 
     &ccsd_t1_6_2',2,MA_ERR)
2547
 
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
2548
 
     & int_mb(k_a_offset),(h1b_1
2549
 
     & - 1 + noab * (p6b_1 - noab - 1)))
2550
 
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p6b-1)
2551
 
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
2552
 
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t1_6_2',3,MA_ERR)
2553
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_bs,k_bs)) CALL
2554
 
     & ERRQUIT('ccsd_t1_6_2',4,MA_ERR)
2555
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
2556
 
     &ccsd_t1_6_2',5,MA_ERR)
2557
 
      IF ((p6b .lt. p3b)) THEN
2558
 
      if(.not.intorb) then
2559
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
2560
 
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
2561
 
     &+nvab) * (h4b_2 - 1)))))
2562
 
      else
2563
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2564
 
     &(p3b_2
2565
 
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
2566
 
     &+nvab) * (h4b_2 - 1)))),p3b_2,p6b_2,h5b_2,h4b_2)
2567
 
      end if
2568
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h4b-1)
2569
 
     &,int_mb(k_range+h5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p3b-1)
2570
 
     &,4,2,1,3,-1.0d0)
2571
 
      END IF
2572
 
      IF ((p3b .le. p6b)) THEN
2573
 
      if(.not.intorb) then
2574
 
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
2575
 
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
2576
 
     &+nvab) * (h4b_2 - 1)))))
2577
 
      else
2578
 
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
2579
 
     &(p6b_2
2580
 
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab
2581
 
     &+nvab) * (h4b_2 - 1)))),p6b_2,p3b_2,h5b_2,h4b_2)
2582
 
      end if
2583
 
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),
2584
 
     1     int_mb(k_range+h4b-1),int_mb(k_range+h5b-1),
2585
 
     2     int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),3,2,1,4,1.0d0)
2586
 
      END IF
2587
 
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t1_6_2',6,MA_ERR)
2588
 
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,
2589
 
     1     dbl_mb(k_as),dim_common,dbl_mb(k_bs),dim_common,1.0d0,
2590
 
     2     dbl_mb(k_cs),dima_sort)
2591
 
      IF (.not.MA_POP_STACK(l_bs)) CALL ERRQUIT('ccsd_t1_6_2',7,MA_ERR)
2592
 
      IF (.not.MA_POP_STACK(l_as)) CALL ERRQUIT('ccsd_t1_6_2',8,MA_ERR)
2593
 
      END IF
2594
 
      END IF
2595
 
      END IF
2596
 
      END DO
2597
 
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c))
2598
 
     1     CALL ERRQUIT('ccsd_t1_6_2',9,MA_ERR)
2599
 
      CALL TCE_SORT_4(dbl_mb(k_cs),dbl_mb(k_c),
2600
 
     1     int_mb(k_range+p3b-1),int_mb(k_range+h5b-1),
2601
 
     2     int_mb(k_range+h4b-1),int_mb(k_range+h1b-1),3,2,4,1,-1.0d0)
2602
 
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),
2603
 
     1     (p3b - noab - 1 + nvab * (h1b - 1 + noab * 
2604
 
     2     (h5b - 1 + noab * (h4b - 1)))))
2605
 
      IF (.not.MA_POP_STACK(l_c))
2606
 
     1     CALL ERRQUIT('ccsd_t1_6_2',10,MA_ERR)
2607
 
      IF (.not.MA_POP_STACK(l_cs))
2608
 
     1     CALL ERRQUIT('ccsd_t1_6_2',11,MA_ERR)
2609
 
      END IF
2610
 
      END IF
2611
 
      END IF
2612
 
      next = NXTASK(nprocs, 1)
2613
 
      END IF
2614
 
      count = count + 1
2615
 
      END DO
2616
 
      END DO
2617
 
      END DO
2618
 
      END DO
2619
 
      next = NXTASK(-nprocs, 1)
2620
 
      call GA_SYNC()
2621
 
      RETURN
2622
 
      END
2623
 
 
2624
 
 
2625
 
 
2626
 
 
2627
 
 
2628
 
 
2629
 
      SUBROUTINE ccsd_t1_7(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
2630
 
C     $Id: ccsd_t1_loc.F,v 1.1 2008-12-14 01:00:23 jhammond Exp $
2631
 
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
2632
 
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
2633
 
C     i0 ( p2 h1 )_vt + = -1/2 * Sum ( h5 p3 p4 ) * t ( p3 p4 h1 h5 )_t * v ( h5 p2 p3 p4 )_v
2634
 
      IMPLICIT NONE
2635
 
#include "global.fh"
2636
 
#include "mafdecls.fh"
2637
 
#include "sym.fh"
2638
 
#include "errquit.fh"
2639
 
#include "tce.fh"
2640
 
      INTEGER d_a, d_b, d_c
2641
 
      INTEGER k_a_offset, k_b_offset, k_c_offset
2642
 
      INTEGER NXTASK, next, nprocs, count
2643
 
      INTEGER p2b,h1b,p3b,p4b,h5b,p3b_1,p4b_1,h1b_1,h5b_1
2644
 
      INTEGER p2b_2,h5b_2,p3b_2,p4b_2
2645
 
      INTEGER dim_common,dima_sort,dimb_sort,dima,dimb,dimc
2646
 
      INTEGER k_as, l_as, k_bs, l_bs
2647
 
      INTEGER k_a, l_a, k_b, l_b, k_c, l_c
2648
 
      INTEGER nsuperp(2)
2649
 
      INTEGER isuperp
2650
 
      DOUBLE PRECISION alpha
2651
 
      DOUBLE PRECISION FACTORIAL
2652
 
      EXTERNAL NXTASK
2653
 
      EXTERNAL FACTORIAL
2654
 
      nprocs = GA_NNODES()
2655
 
      count = 0
2656
 
      next = NXTASK(nprocs, 1)
2657
 
      DO p2b = noab+1,noab+nvab
2658
 
       DO h1b = 1,noab
2659
 
        IF (next.eq.count) THEN
2660
 
         IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)
2661
 
     1                            +int_mb(k_spin+h1b-1).ne.4)) THEN
2662
 
          IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN
2663
 
           IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) 
2664
 
     1         .eq. ieor(irrep_v,irrep_t)) THEN
2665
 
            dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1)
2666
 
            IF (.not.MA_PUSH_GET(mt_dbl,dimc,'c',l_c,k_c)) 
2667
 
     1           CALL ERRQUIT('ccsd_t1_7',0,MA_ERR)
2668
 
            CALL DFILL(dimc,0.0d0,dbl_mb(k_c),1)
2669
 
            DO p3b = noab+1,noab+nvab
2670
 
             DO p4b = p3b,noab+nvab
2671
 
              DO h5b = 1,noab
2672
 
               IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. 
2673
 
     1             int_mb(k_spin+h1b-1)+int_mb(k_spin+h5b-1)) THEN
2674
 
                IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),
2675
 
     1              ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+h5b-1)))) 
2676
 
     2              .eq. irrep_t) THEN
2677
 
                 CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h5b,
2678
 
     1                p3b_1,p4b_1,h1b_1,h5b_1)
2679
 
                 CALL TCE_RESTRICTED_4(p2b,h5b,p3b,p4b,
2680
 
     1                p2b_2,h5b_2,p3b_2,p4b_2)
2681
 
                 dim_common = int_mb(k_range+p3b-1) 
2682
 
     1                      * int_mb(k_range+p4b-1) 
2683
 
     2                      * int_mb(k_range+h5b-1)
2684
 
                 dima_sort = int_mb(k_range+h1b-1)
2685
 
                 dima = dim_common * dima_sort
2686
 
                 dimb_sort = int_mb(k_range+p2b-1)
2687
 
                 dimb = dim_common * dimb_sort
2688
 
                 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
2689
 
                  IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_as,k_as)) 
2690
 
     1                 CALL ERRQUIT('ccsd_t1_7',1,MA_ERR)
2691
 
                  IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) 
2692
 
     1                 CALL ERRQUIT('ccsd_t1_7',2,MA_ERR)
2693
 
                  IF ((h5b .lt. h1b)) THEN
2694
 
                   CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,
2695
 
     1                  int_mb(k_a_offset),(h1b_1 - 1 + noab * 
2696
 
     2                  (h5b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * 
2697
 
     3                  (p3b_1 - noab - 1)))))
2698
 
                   CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),
2699
 
     1                  int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),
2700
 
     2                  int_mb(k_range+h5b-1),int_mb(k_range+h1b-1),
2701
 
     3                  4,3,2,1,-1.0d0)
2702
 
                  END IF
2703
 
                  IF ((h1b .le. h5b)) THEN
2704
 
                   CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,
2705
 
     1                  int_mb(k_a_offset),(h5b_1 - 1 + noab * 
2706
 
     2                  (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * 
2707
 
     3                  (p3b_1 - noab - 1)))))
2708
 
                   CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),
2709
 
     1                  int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),
2710
 
     2                  int_mb(k_range+h1b-1),int_mb(k_range+h5b-1),
2711
 
     3                  3,4,2,1,1.0d0)
2712
 
                  END IF
2713
 
                  IF (.not.MA_POP_STACK(l_a)) 
2714
 
     1                 CALL ERRQUIT('ccsd_t1_7',3,MA_ERR)
2715
 
                  IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_bs,k_bs)) 
2716
 
     1                 CALL ERRQUIT('ccsd_t1_7',4,MA_ERR)
2717
 
                  IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b))  
2718
 
     1                 CALL ERRQUIT('ccsd_t1_7',5,MA_ERR)
2719
 
                  IF ((h5b .le. p2b)) THEN
2720
 
                   if(.not.intorb) then
2721
 
                    CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,
2722
 
     1                   int_mb(k_b_offset),(p4b_2 - 1 + (noab+nvab) * 
2723
 
     2                   (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + 
2724
 
     3                   (noab+nvab) * (h5b_2 - 1)))))
2725
 
                   else
2726
 
                    CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,
2727
 
     1                   int_mb(k_b_offset),(p4b_2 - 1 + (noab+nvab) * 
2728
 
     2                   (p3b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + 
2729
 
     3                   (noab+nvab) * (h5b_2 - 1)))),
2730
 
     4                   p4b_2,p3b_2,p2b_2,h5b_2)
2731
 
                   end if
2732
 
                   CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),
2733
 
     1                  int_mb(k_range+h5b-1),int_mb(k_range+p2b-1),
2734
 
     2                  int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),
2735
 
     3                  2,1,4,3,1.0d0)
2736
 
                  END IF
2737
 
                  IF (.not.MA_POP_STACK(l_b)) 
2738
 
     1                 CALL ERRQUIT('ccsd_t1_7',6,MA_ERR)
2739
 
                  IF (p3b .eq. p4b) THEN
2740
 
                   alpha = 1.0d0
2741
 
                  ELSE
2742
 
                   alpha = 2.0d0
2743
 
                  END IF
2744
 
                  CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,
2745
 
     1                 alpha,dbl_mb(k_as),dim_common,dbl_mb(k_bs),
2746
 
     2                 dim_common,1.0d0,dbl_mb(k_c),dima_sort)
2747
 
                  IF (.not.MA_POP_STACK(l_bs)) 
2748
 
     1                 CALL ERRQUIT('ccsd_t1_7',7,MA_ERR)
2749
 
                  IF (.not.MA_POP_STACK(l_as)) 
2750
 
     1                 CALL ERRQUIT('ccsd_t1_7',8,MA_ERR)
2751
 
                 END IF
2752
 
                END IF
2753
 
               END IF
2754
 
              END DO
2755
 
             END DO
2756
 
            END DO
2757
 
            CALL DSCAL(int_mb(k_range+p2b-1)*int_mb(k_range+h1b-1),
2758
 
     1           -0.5d0,dbl_mb(k_c),1)
2759
 
            CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,
2760
 
     1           int_mb(k_c_offset),
2761
 
     2           (h1b - 1 + noab * (p2b - noab - 1)))
2762
 
            IF (.not.MA_POP_STACK(l_c))
2763
 
     1           CALL ERRQUIT('ccsd_t1_7',10,MA_ERR)
2764
 
           END IF
2765
 
          END IF
2766
 
         END IF
2767
 
         next = NXTASK(nprocs, 1)
2768
 
        END IF
2769
 
        count = count + 1
2770
 
       END DO
2771
 
      END DO
2772
 
      next = NXTASK(-nprocs, 1)
2773
 
      call GA_SYNC()
2774
 
      RETURN
2775
 
      END