← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/tce/ccsd/icsd_t2.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/icsd_t2.F
 
1
      SUBROUTINE icsd_t2(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,size_t1,size_t2,d_c2,iter)
 
3
c
 
4
c new parameters in procedure call size_t1,size_t2,d_c2
 
5
c d_c2 is assumed to be created before icsd_t2 is called
 
6
c d_c2 is also deleted outside of icsd_t2
 
7
c
 
8
c
 
9
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
10
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
11
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
12
C     i0 ( p3 p4 h1 h2 )_v + = 1 * v ( p3 p4 h1 h2 )_v
 
13
C     i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( h10 ) * t ( p3 h10 )_t * i1 ( h10 p4 h1 h2 )_v
 
14
C         i1 ( h10 p3 h1 h2 )_v + = 1 * v ( h10 p3 h1 h2 )_v
 
15
C         i1 ( h10 p3 h1 h2 )_vt + = 1/2 * Sum ( h11 ) * t ( p3 h11 )_t * i2 ( h10 h11 h1 h2 )_v
 
16
C             i2 ( h10 h11 h1 h2 )_v + = -1 * v ( h10 h11 h1 h2 )_v
 
17
C             i2 ( h10 h11 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i3 ( h10 h11 h2 p5 )_v
 
18
C                 i3 ( h10 h11 h1 p5 )_v + = 1 * v ( h10 h11 h1 p5 )_v
 
19
C                 i3 ( h10 h11 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h10 h11 p5 p6 )_v
 
20
C             i2 ( h10 h11 h1 h2 )_vt + = -1/2 * Sum ( p7 p8 ) * t ( p7 p8 h1 h2 )_t * v ( h10 h11 p7 p8 )_v
 
21
C         i1 ( h10 p3 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h10 p3 h2 p5 )_v
 
22
C             i2 ( h10 p3 h1 p5 )_v + = 1 * v ( h10 p3 h1 p5 )_v
 
23
C             i2 ( h10 p3 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h10 p3 p5 p6 )_v
 
24
C         i1 ( h10 p3 h1 h2 )_ft + = -1 * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i2 ( h10 p5 )_f
 
25
C             i2 ( h10 p5 )_f + = 1 * f ( h10 p5 )_f
 
26
C             i2 ( h10 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h10 p5 p6 )_v
 
27
C         i1 ( h10 p3 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( h7 p9 ) * t ( p3 p9 h1 h7 )_t * i2 ( h7 h10 h2 p9 )_v
 
28
C             i2 ( h7 h10 h1 p9 )_v + = 1 * v ( h7 h10 h1 p9 )_v
 
29
C             i2 ( h7 h10 h1 p9 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h7 h10 p5 p9 )_v
 
30
C         i1 ( h10 p3 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h10 p3 p5 p6 )_v
 
31
C     i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i1 ( p3 p4 h2 p5 )_v
 
32
C         i1 ( p3 p4 h1 p5 )_v + = 1 * v ( p3 p4 h1 p5 )_v
 
33
C         i1 ( p3 p4 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( p3 p4 p5 p6 )_v
 
34
C     i0 ( p3 p4 h1 h2 )_tf + = -1 * P( 2 ) * Sum ( h9 ) * t ( p3 p4 h1 h9 )_t * i1 ( h9 h2 )_f
 
35
C         i1 ( h9 h1 )_f + = 1 * f ( h9 h1 )_f
 
36
C         i1 ( h9 h1 )_ft + = 1 * Sum ( p8 ) * t ( p8 h1 )_t * i2 ( h9 p8 )_f
 
37
C             i2 ( h9 p8 )_f + = 1 * f ( h9 p8 )_f
 
38
C             i2 ( h9 p8 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 p6 p8 )_v
 
39
C         i1 ( h9 h1 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 h1 p6 )_v
 
40
C         i1 ( h9 h1 )_vt + = -1/2 * Sum ( h8 p6 p7 ) * t ( p6 p7 h1 h8 )_t * v ( h8 h9 p6 p7 )_v
 
41
C     i0 ( p3 p4 h1 h2 )_tf + = 1 * P( 2 ) * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i1 ( p4 p5 )_f
 
42
C         i1 ( p3 p5 )_f + = 1 * f ( p3 p5 )_f
 
43
C         i1 ( p3 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 p3 p5 p6 )_v
 
44
C         i1 ( p3 p5 )_vt + = -1/2 * Sum ( h7 h8 p6 ) * t ( p3 p6 h7 h8 )_t * v ( h7 h8 p5 p6 )_v
 
45
C     i0 ( p3 p4 h1 h2 )_vt + = -1/2 * Sum ( h11 h9 ) * t ( p3 p4 h9 h11 )_t * i1 ( h9 h11 h1 h2 )_v
 
46
C         i1 ( h9 h11 h1 h2 )_v + = -1 * v ( h9 h11 h1 h2 )_v
 
47
C         i1 ( h9 h11 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( p8 ) * t ( p8 h1 )_t * i2 ( h9 h11 h2 p8 )_v
 
48
C             i2 ( h9 h11 h1 p8 )_v + = 1 * v ( h9 h11 h1 p8 )_v
 
49
C             i2 ( h9 h11 h1 p8 )_vt + = 1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 h11 p6 p8 )_v
 
50
C         i1 ( h9 h11 h1 h2 )_vt + = -1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 h11 p5 p6 )_v
 
51
C     i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 4 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i1 ( h6 p4 h2 p5 )_v
 
52
C         i1 ( h6 p3 h1 p5 )_v + = 1 * v ( h6 p3 h1 p5 )_v
 
53
C         i1 ( h6 p3 h1 p5 )_vt + = -1 * Sum ( p7 ) * t ( p7 h1 )_t * v ( h6 p3 p5 p7 )_v
 
54
C         i1 ( h6 p3 h1 p5 )_vt + = -1/2 * Sum ( h8 p7 ) * t ( p3 p7 h1 h8 )_t * v ( h6 h8 p5 p7 )_v
 
55
C     i0 ( p3 p4 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( p3 p4 p5 p6 )_v
 
56
      IMPLICIT NONE
 
57
#include "global.fh"
 
58
#include "mafdecls.fh"
 
59
#include "util.fh"
 
60
#include "errquit.fh"
 
61
#include "tce.fh"
 
62
c when local copies of  T1/X1 tensors are used,  d_t1 refers to k_t1_local (kk)
 
63
c local copies of the most important 2-dimensional intermediates
 
64
c icsd_t2_4(...) and icsd_t2_5(...) (kk)
 
65
      INTEGER d_i0
 
66
      INTEGER k_i0_offset
 
67
      INTEGER d_v2
 
68
      INTEGER k_v2_offset
 
69
      INTEGER d_t1
 
70
      INTEGER k_t1_offset
 
71
      INTEGER d_i1
 
72
      INTEGER k_i1_offset
 
73
      INTEGER d_t2
 
74
      INTEGER k_t2_offset
 
75
      INTEGER l_i1_offset
 
76
      INTEGER size_i1
 
77
      INTEGER d_i2
 
78
      INTEGER k_i2_offset
 
79
      INTEGER l_i2_offset
 
80
      INTEGER size_i2
 
81
      INTEGER d_i3
 
82
      INTEGER k_i3_offset
 
83
      INTEGER l_i3_offset
 
84
      INTEGER size_i3
 
85
      INTEGER d_f1
 
86
      INTEGER k_f1_offset
 
87
c PETA
 
88
      integer d_c2
 
89
      integer d_i1_2
 
90
      integer d_i2_2a,d_i2_2b,d_i2_2c,d_i2_2d
 
91
      integer d_i3_2
 
92
      integer d_i1_3
 
93
      integer d_i2_3
 
94
      integer d_i1_4
 
95
      integer d_i2_4
 
96
      integer d_i1_5
 
97
      integer d_i1_6
 
98
      integer d_i2_6
 
99
      integer d_i1_7
 
100
      integer d_i1_vt
 
101
      integer l_i1_2_offset,k_i1_2_offset
 
102
      integer l_i2_2a_offset,k_i2_2a_offset
 
103
      integer l_i2_2b_offset,k_i2_2b_offset
 
104
      integer l_i2_2c_offset,k_i2_2c_offset
 
105
      integer l_i2_2d_offset,k_i2_2d_offset
 
106
      integer l_i3_2_offset,k_i3_2_offset
 
107
      integer l_i1_3_offset,k_i1_3_offset
 
108
      integer l_i2_3_offset,k_i2_3_offset
 
109
      integer l_i1_4_offset,k_i1_4_offset
 
110
      integer l_i2_4_offset,k_i2_4_offset
 
111
      integer l_i1_5_offset,k_i1_5_offset
 
112
      integer l_i1_6_offset,k_i1_6_offset
 
113
      integer l_i2_6_offset,k_i2_6_offset
 
114
      integer l_i1_7_offset,k_i1_7_offset
 
115
      integer l_i1_vt_offset,k_i1_vt_offset
 
116
c
 
117
      integer l_i1_4_local,k_i1_4_local
 
118
      integer l_i1_5_local,k_i1_5_local
 
119
c
 
120
      integer size_i1_2
 
121
      integer size_i2_2a,size_i2_2b,size_i2_2c,size_i2_2d
 
122
      integer size_i3_2
 
123
      integer size_i1_3
 
124
      integer size_i2_3
 
125
      integer size_i1_4
 
126
      integer size_i2_4
 
127
      integer size_i1_5
 
128
      integer size_i1_6
 
129
      integer size_i2_6
 
130
      integer size_i1_7
 
131
      integer size_i1_vt     
 
132
      integer level_x,iter
 
133
      integer size_t1,size_t2
 
134
      integer layer1,layer2,layer3,layer4
 
135
c ----- independent counters -----
 
136
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
137
      integer num_count
 
138
      integer ctx
 
139
      parameter(num_count=41)
 
140
c --------------------------------
 
141
c - T1/X1 LOCALIZATION -------------------
 
142
      integer l_i1_local,k_i1_local
 
143
c ---------------------------------------
 
144
      CHARACTER*255 filename
 
145
      logical nodezero         ! True if node 0
 
146
      double precision cpu     ! CPU sec counter
 
147
      double precision wall    ! WALL sec counter
 
148
c
 
149
      nodezero=(ga_nodeid().eq.0)
 
150
c
 
151
c --------------------------------
 
152
c ALL OFFSET OPENINGS HERE
 
153
      CALL OFFSET_icsd_t2_2_1(l_i1_2_offset,k_i1_2_offset,size_i1_2)
 
154
      CALL OFFSET_icsd_t2_2_2_1(l_i2_2a_offset,k_i2_2a_offset,
 
155
     &size_i2_2a)
 
156
      CALL OFFSET_icsd_t2_2_2_2_1(l_i3_2_offset,k_i3_2_offset,size_i3_2)
 
157
      CALL OFFSET_icsd_t2_2_4_1(l_i2_2c_offset,k_i2_2c_offset,
 
158
     &size_i2_2c)
 
159
      CALL OFFSET_icsd_t2_2_5_1(l_i2_2d_offset,k_i2_2d_offset,
 
160
     &size_i2_2d)
 
161
      CALL OFFSET_icsd_t2_4_1(l_i1_4_offset,k_i1_4_offset,size_i1_4)
 
162
      CALL OFFSET_icsd_t2_4_2_1(l_i2_4_offset,k_i2_4_offset,size_i2_4)
 
163
      CALL OFFSET_icsd_t2_5_1(l_i1_5_offset,k_i1_5_offset,size_i1_5)
 
164
      CALL OFFSET_icsd_t2_6_1(l_i1_6_offset,k_i1_6_offset,size_i1_6)
 
165
      CALL OFFSET_icsd_t2_6_2_1(l_i2_6_offset,k_i2_6_offset,size_i2_6)
 
166
      CALL OFFSET_icsd_t2_7_1(l_i1_7_offset,k_i1_7_offset,size_i1_7)
 
167
      CALL OFFSET_vt1ic_1_1(l_i1_vt_offset,k_i1_vt_offset,size_i1_vt)
 
168
c
 
169
c       if (.not.ma_push_get(mt_dbl,size_i1_4,'loc1',
 
170
c     1  l_i1_4_local,k_i1_4_local)) call errquit('tce:loc1p ',0,MA_ERR)
 
171
c
 
172
c       if (.not.ma_push_get(mt_dbl,size_i1_5,'loc2',
 
173
c     1  l_i1_5_local,k_i1_5_local)) call errquit('tce:loc1p ',0,MA_ERR)
 
174
c
 
175
 
 
176
      CALL TCE_FILENAME('icsd_t2_2_1_i1',filename)
 
177
      CALL CREATEFILE(filename,d_i1_2,size_i1_2)
 
178
 
 
179
      CALL TCE_FILENAME('icsd_t2_2_2_1_i2',filename)
 
180
      CALL CREATEFILE(filename,d_i2_2a,size_i2_2a)
 
181
 
 
182
      CALL TCE_FILENAME('icsd_t2_2_2_2_1_i3',filename)
 
183
      CALL CREATEFILE(filename,d_i3_2,size_i3_2)
 
184
 
 
185
      CALL TCE_FILENAME('icsd_t2_2_4_1_i2',filename)
 
186
      CALL CREATEFILE(filename,d_i2_2c,size_i2_2c)
 
187
 
 
188
      CALL TCE_FILENAME('icsd_t2_2_5_1_i2',filename)
 
189
      CALL CREATEFILE(filename,d_i2_2d,size_i2_2d)
 
190
 
 
191
      CALL TCE_FILENAME('icsd_t2_4_1_i1',filename)
 
192
      CALL CREATEFILE(filename,d_i1_4,size_i1_4)
 
193
 
 
194
      CALL TCE_FILENAME('icsd_t2_4_2_1_i2',filename)
 
195
      CALL CREATEFILE(filename,d_i2_4,size_i2_4)
 
196
 
 
197
      CALL TCE_FILENAME('icsd_t2_5_1_i1',filename)
 
198
      CALL CREATEFILE(filename,d_i1_5,size_i1_5)
 
199
 
 
200
      CALL TCE_FILENAME('icsd_t2_6_1_i1',filename)
 
201
      CALL CREATEFILE(filename,d_i1_6,size_i1_6)
 
202
 
 
203
      CALL TCE_FILENAME('icsd_t2_6_2_1_i2',filename)
 
204
      CALL CREATEFILE(filename,d_i2_6,size_i2_6)
 
205
 
 
206
      CALL TCE_FILENAME('icsd_t2_7_1_i1',filename)
 
207
      CALL CREATEFILE(filename,d_i1_7,size_i1_7)
 
208
 
 
209
      CALL TCE_FILENAME('vt1ic_1_1_i1',filename)
 
210
      CALL CREATEFILE(filename,d_i1_vt,size_i1_vt)
 
211
c
 
212
c
 
213
c
 
214
 
 
215
      if(iter.eq.1) then
 
216
c
 
217
c       layer1=int_mb(k_i0_offset)+int_mb(k_i1_2_offset)+
 
218
c     & int_mb(k_i2_2a_offset)+int_mb(k_i3_2_offset)+
 
219
c     & int_mb(k_i3_2_offset)+int_mb(k_i2_2a_offset)+
 
220
c     & int_mb(k_i2_2c_offset)+int_mb(k_i2_2c_offset)+
 
221
c     & int_mb(k_i2_2d_offset)+int_mb(k_i2_2d_offset)+
 
222
c     & int_mb(k_i1_2_offset)+int_mb(k_i0_offset)+
 
223
c     & int_mb(k_i1_4_offset)+int_mb(k_i2_4_offset)+
 
224
c     & int_mb(k_i2_4_offset)+int_mb(k_i1_4_offset)+
 
225
c     & int_mb(k_i1_4_offset)+int_mb(k_i1_5_offset)+
 
226
c     & int_mb(k_i1_5_offset)+int_mb(k_i1_5_offset)+
 
227
c     & int_mb(k_i1_6_offset)+int_mb(k_i2_6_offset)+
 
228
c     & int_mb(k_i2_6_offset)+int_mb(k_i1_6_offset)+
 
229
c     & int_mb(k_i1_7_offset)+int_mb(k_i1_7_offset)+
 
230
c     & int_mb(k_i1_7_offset)+int_mb(k_i1_vt_offset)+
 
231
c     & int_mb(k_i0_offset)
 
232
c       layer2=int_mb(k_i2_2a_offset)+int_mb(k_i1_2_offset)+
 
233
c     & int_mb(k_i1_2_offset)+int_mb(k_i1_4_offset)+
 
234
c     & int_mb(k_i1_6_offset)+int_mb(k_i0_offset)+
 
235
c     & int_mb(k_i0_offset)
 
236
c       layer3=int_mb(k_i1_2_offset)+int_mb(k_i0_offset)+
 
237
c     & int_mb(k_i0_offset)+int_mb(k_i0_offset)
 
238
c       layer4=int_mb(k_i0_offset)
 
239
c
 
240
      if(nodezero)  then
 
241
c       write(6,100)
 
242
c       write(6,101)'t2_1',int_mb(k_i0_offset)
 
243
c       write(6,101)'t2_2_1',int_mb(k_i1_2_offset)
 
244
c       write(6,101)'t2_2_2_1',int_mb(k_i2_2a_offset)
 
245
c       write(6,101)'t2_2_2_2_1',int_mb(k_i3_2_offset)
 
246
c       write(6,101)'t2_2_2_2_2',int_mb(k_i3_2_offset)
 
247
c       write(6,101)'t2_2_2_2',int_mb(k_i2_2a_offset)
 
248
c       write(6,101)'t2_2_2_3',int_mb(k_i2_2a_offset)
 
249
c       write(6,101)'t2_2_2',int_mb(k_i1_2_offset)
 
250
c       write(6,101)'t2_2_4_1',int_mb(k_i2_2c_offset)
 
251
c       write(6,101)'t2_2_4_2',int_mb(k_i2_2c_offset)
 
252
c       write(6,101)'t2_2_4',int_mb(k_i1_2_offset)
 
253
c       write(6,101)'t2_2_5_1',int_mb(k_i2_2d_offset)
 
254
c       write(6,101)'t2_2_5_2',int_mb(k_i2_2d_offset)
 
255
c       write(6,101)'t2_2_5',int_mb(k_i1_2_offset)
 
256
c       write(6,101)'t2_2_6',int_mb(k_i1_2_offset)
 
257
c       write(6,101)'t2_2',int_mb(k_i0_offset)
 
258
c       write(6,101)'t2_3x',int_mb(k_i0_offset)
 
259
c       write(6,101)'t2_4_1',int_mb(k_i1_4_offset)
 
260
c       write(6,101)'t2_4_2_1',int_mb(k_i2_4_offset)
 
261
c       write(6,101)'t2_4_2_2',int_mb(k_i2_4_offset)
 
262
c       write(6,101)'t2_4_2',int_mb(k_i1_4_offset)
 
263
c       write(6,101)'t2_4_3',int_mb(k_i1_4_offset)
 
264
c       write(6,101)'t2_4_4',int_mb(k_i1_4_offset)
 
265
c       write(6,101)'t2_4',int_mb(k_i0_offset)
 
266
c       write(6,101)'t2_5_1',int_mb(k_i1_5_offset)
 
267
c       write(6,101)'t2_5_2',int_mb(k_i1_5_offset)
 
268
c       write(6,101)'t2_5_3',int_mb(k_i1_5_offset)
 
269
c       write(6,101)'t2_5',int_mb(k_i0_offset)
 
270
c       write(6,101)'t2_6_1',int_mb(k_i1_6_offset)
 
271
c       write(6,101)'t2_6_2_1',int_mb(k_i2_6_offset)
 
272
c       write(6,101)'t2_6_2_2',int_mb(k_i2_6_offset)
 
273
c       write(6,101)'t2_6_2',int_mb(k_i1_6_offset)
 
274
c       write(6,101)'t2_6_3',int_mb(k_i1_6_offset)
 
275
c       write(6,101)'t2_6',int_mb(k_i0_offset)
 
276
c       write(6,101)'t2_7_1',int_mb(k_i1_7_offset)
 
277
c       write(6,101)'t2_7_2',int_mb(k_i1_7_offset)
 
278
c       write(6,101)'t2_7_3',int_mb(k_i1_7_offset)
 
279
c       write(6,101)'t2_7',int_mb(k_i0_offset)
 
280
c       write(6,101)'vt1ic_1_2',int_mb(k_i1_vt_offset)
 
281
c       write(6,101)'vt1ic_1',int_mb(k_i0_offset)
 
282
c       write(6,101)'t2_8',int_mb(k_i0_offset)
 
283
c       write(6,*)'                          '
 
284
c       write(6,102)
 
285
c       write(6,101)'layer 1',layer1
 
286
c       write(6,101)'layer 2',layer2
 
287
c       write(6,101)'layer 3',layer3
 
288
c       write(6,101)'layer 4',layer4
 
289
       write(6,103)
 
290
       call util_flush(6)
 
291
      end if
 
292
      end if
 
293
c
 
294
 100  format('SEMI-SERIAL EXECUTION OF T2')
 
295
 101  format(2x,a12,3x,i12)
 
296
 102  format('TASK POOL FOR VARIOUS T2 LAYERS')
 
297
 103  format('CCSD_T2_NTS --- OK')
 
298
c
 
299
 
 
300
c
 
301
c counters are opened here
 
302
c
 
303
      call nxt_ctx_create(num_count, ctx)
 
304
c
 
305
c
 
306
      do level_x=1,4    ! -----------------
 
307
c
 
308
      if(level_x.eq.1) then
 
309
      CALL icsd_t2_1(d_v2,k_v2_offset,d_i0,k_i0_offset,ctx,1)
 
310
      end if
 
311
c
 
312
 
 
313
 
 
314
 
 
315
 
 
316
 
 
317
c
 
318
      if(level_x.eq.1) then
 
319
      CALL icsd_t2_2_1(d_v2,k_v2_offset,d_i1_2,k_i1_2_offset,ctx,2)
 
320
      end if
 
321
c
 
322
      if(level_x.eq.1) then
 
323
      CALL icsd_t2_2_2_1(d_v2,k_v2_offset,d_i2_2a,k_i2_2a_offset,ctx,3)
 
324
      end if
 
325
c
 
326
      if(level_x.eq.1) then 
 
327
      CALL icsd_t2_2_2_2_1(d_v2,k_v2_offset,d_i3_2,k_i3_2_offset,ctx,4)
 
328
      end if
 
329
c
 
330
      if(level_x.eq.1) then
 
331
      CALL icsd_t2_2_2_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i3_2,
 
332
     &k_i3_2_offset,ctx,5)
 
333
      end if
 
334
c
 
335
      if(level_x.eq.2) then
 
336
      CALL icsd_t2_2_2_2(d_t1,k_t1_offset,d_i3_2,k_i3_2_offset,
 
337
     &d_i2_2a,k_i2_2a_offset,ctx,6)
 
338
      end if
 
339
c
 
340
      if(level_x.eq.1) then
 
341
      CALL icsd_t2_2_2_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i2_2a,
 
342
     &k_i2_2a_offset,ctx,7)
 
343
      end if
 
344
c
 
345
      if(level_x.eq.3) then
 
346
      CALL icsd_t2_2_2(d_t1,k_t1_offset,d_i2_2a,k_i2_2a_offset,
 
347
     &d_i1_2,k_i1_2_offset,ctx,8)
 
348
      end if
 
349
c
 
350
      if(level_x.eq.1) then
 
351
      CALL icsd_t2_2_4_1(d_f1,k_f1_offset,d_i2_2c,k_i2_2c_offset,
 
352
     &ctx,9)
 
353
      end if
 
354
c
 
355
      if(level_x.eq.1) then
 
356
      CALL icsd_t2_2_4_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2_2c,
 
357
     &k_i2_2c_offset,ctx,10)
 
358
      end if
 
359
c
 
360
      if(level_x.eq.2) then
 
361
      CALL icsd_t2_2_4(d_t2,k_t2_offset,d_i2_2c,k_i2_2c_offset,d_i1_2,
 
362
     &k_i1_2_offset,ctx,11)
 
363
      end if
 
364
c
 
365
      if(level_x.eq.1) then
 
366
      CALL icsd_t2_2_5_1(d_v2,k_v2_offset,d_i2_2d,k_i2_2d_offset,ctx,12)
 
367
      end if
 
368
c
 
369
      if(level_x.eq.1) then  
 
370
      CALL icsd_t2_2_5_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2_2d,
 
371
     &k_i2_2d_offset,ctx,13)
 
372
      end if
 
373
c
 
374
      if(level_x.eq.2) then
 
375
      CALL icsd_t2_2_5(d_t2,k_t2_offset,d_i2_2d,k_i2_2d_offset,d_i1_2,
 
376
     &k_i1_2_offset,ctx,14)
 
377
      end if
 
378
c
 
379
      if(level_x.eq.1) then
 
380
      CALL icsd_t2_2_6(d_c2,k_t2_offset,d_v2,k_v2_offset,
 
381
     &d_i1_2,k_i1_2_offset,ctx,15)
 
382
      end if
 
383
c
 
384
      if(level_x.eq.4) then
 
385
      CALL icsd_t2_2(d_t1,k_t1_offset,d_i1_2,k_i1_2_offset,
 
386
     &d_i0,k_i0_offset,ctx,16)
 
387
      end if
 
388
 
 
389
 
 
390
 
 
391
 
 
392
 
 
393
 
 
394
 
 
395
 
 
396
c
 
397
      if(level_x.eq.1) then
 
398
      CALL licsd_t2_3x(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i0,
 
399
     &k_i0_offset,ctx,17)
 
400
      end if
 
401
c
 
402
      if(level_x.eq.1) then
 
403
      CALL icsd_t2_4_1(d_f1,k_f1_offset,d_i1_4,k_i1_4_offset,ctx,18)
 
404
      end if
 
405
c
 
406
      if(level_x.eq.1) then
 
407
      CALL icsd_t2_4_2_1(d_f1,k_f1_offset,d_i2_4,k_i2_4_offset,ctx,19)
 
408
      end if
 
409
c
 
410
      if(level_x.eq.1) then
 
411
      CALL icsd_t2_4_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2_4,
 
412
     &k_i2_4_offset,ctx,20)
 
413
      end if
 
414
c
 
415
      if(level_x.eq.2) then 
 
416
      CALL icsd_t2_4_2(d_t1,k_t1_offset,d_i2_4,k_i2_4_offset,d_i1_4,
 
417
     &k_i1_4_offset,ctx,21)
 
418
      end if
 
419
c
 
420
c      IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('icsd_t2',-1,MA_E
 
421
c     &RR)
 
422
c
 
423
      if(level_x.eq.1) then
 
424
      CALL icsd_t2_4_3(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1_4,
 
425
     &k_i1_4_offset,ctx,22)
 
426
      end if
 
427
c
 
428
      if(level_x.eq.1) then 
 
429
      CALL icsd_t2_4_4(d_t2,k_t2_offset,d_v2,k_v2_offset,
 
430
     &d_i1_4,k_i1_4_offset,ctx,23)
 
431
      end if
 
432
c
 
433
c - T1/X1 LOCALIZATION ----------
 
434
c        if (.not.MA_PUSH_GET(mt_dbl,size_i1,'i1_local',
 
435
c     1      l_i1_local,k_i1_local))
 
436
c     1      call errquit('i1_local',1,MA_ERR)
 
437
c        call ma_zero(dbl_mb(k_i1_local),size_i1)
 
438
c    copy d_t1 ==> l_t1_local
 
439
c        call ga_get(d_i1,1,size_i1,1,1,dbl_mb(k_i1_local),1)
 
440
c -------------------------------
 
441
ccx      CALL icsd_t2_4(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
 
442
c
 
443
c
 
444
      if(level_x.eq.3) then
 
445
      CALL icsd_t2_4(d_t2,k_t2_offset,d_i1_4,k_i1_4_offset,
 
446
     &              d_i0,k_i0_offset,ctx,24)
 
447
      end if
 
448
c
 
449
      if(level_x.eq.1) then 
 
450
      CALL icsd_t2_5_1(d_f1,k_f1_offset,d_i1_5,k_i1_5_offset,ctx,25)
 
451
      end if
 
452
c
 
453
      if(level_x.eq.1) then
 
454
      CALL icsd_t2_5_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1_5,
 
455
     &k_i1_5_offset,ctx,26)
 
456
      end if
 
457
c
 
458
      if(level_x.eq.1) then
 
459
      CALL icsd_t2_5_3(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i1_5,
 
460
     &k_i1_5_offset,ctx,27)
 
461
      end if
 
462
c
 
463
c - T1/X1 LOCALIZATION ----------
 
464
c        if (.not.MA_PUSH_GET(mt_dbl,size_i1,'i1_local',
 
465
c     1      l_i1_local,k_i1_local))
 
466
c     1      call errquit('i1_local',1,MA_ERR)
 
467
c        call ma_zero(dbl_mb(k_i1_local),size_i1)
 
468
cc    copy d_t1 ==> l_t1_local
 
469
c        call ga_get(d_i1,1,size_i1,1,1,dbl_mb(k_i1_local),1)
 
470
c -------------------------------
 
471
ccx      CALL icsd_t2_5(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
 
472
c
 
473
      if(level_x.eq.2) then
 
474
      CALL icsd_t2_5(d_t2,k_t2_offset,d_i1_5,k_i1_5_offset,
 
475
     &               d_i0,k_i0_offset,ctx,28)
 
476
      end if
 
477
c
 
478
      if(level_x.eq.1) then
 
479
      CALL icsd_t2_6_1(d_v2,k_v2_offset,d_i1_6,k_i1_6_offset,ctx,29)
 
480
      end if
 
481
c
 
482
      if(level_x.eq.1) then
 
483
      CALL icsd_t2_6_2_1(d_v2,k_v2_offset,d_i2_6,k_i2_6_offset,ctx,30)
 
484
      end if
 
485
c
 
486
      if(level_x.eq.1) then
 
487
      CALL icsd_t2_6_2_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i2_6,
 
488
     &k_i2_6_offset,ctx,31)
 
489
      end if
 
490
c
 
491
      if(level_x.eq.2) then
 
492
      CALL icsd_t2_6_2(d_t1,k_t1_offset,d_i2_6,k_i2_6_offset,
 
493
     &d_i1_6,k_i1_6_offset,ctx,32)
 
494
      end if
 
495
c
 
496
      if(level_x.eq.1) then
 
497
      CALL icsd_t2_6_3(d_t2,k_t2_offset,d_v2,k_v2_offset,
 
498
     &d_i1_6,k_i1_6_offset,ctx,33)
 
499
      end if
 
500
c
 
501
      if(level_x.eq.3) then
 
502
      CALL icsd_t2_6(d_t2,k_t2_offset,d_i1_6,k_i1_6_offset,d_i0,
 
503
     &k_i0_offset,ctx,34)
 
504
      end if
 
505
c
 
506
      if(level_x.eq.1) then
 
507
      CALL icsd_t2_7_1(d_v2,k_v2_offset,d_i1_7,k_i1_7_offset,ctx,35)
 
508
      end if
 
509
c
 
510
      if(level_x.eq.1) then
 
511
      CALL icsd_t2_7_2(d_t1,k_t1_offset,d_v2,k_v2_offset,
 
512
     &d_i1_7,k_i1_7_offset,ctx,36)
 
513
      end if
 
514
c
 
515
      if(level_x.eq.1) then
 
516
      CALL icsd_t2_7_3(d_t2,k_t2_offset,d_v2,k_v2_offset,
 
517
     &d_i1_7,k_i1_7_offset,ctx,37)
 
518
      end if
 
519
c
 
520
      if(level_x.eq.2) then
 
521
      CALL icsd_t2_7(d_t2,k_t2_offset,d_i1_7,k_i1_7_offset,
 
522
     &d_i0,k_i0_offset,ctx,38)
 
523
      end if
 
524
c
 
525
c
 
526
      if(level_x.eq.1) then
 
527
      CALL vt1ic_1_2(d_t1,k_t1_offset,d_v2,k_v2_offset,
 
528
     &d_i1_vt,k_i1_vt_offset,ctx,39)
 
529
      end if
 
530
c
 
531
      if(level_x.eq.2) then
 
532
      CALL vt1ic_1(d_t1,k_t1_offset,d_i1_vt,k_i1_vt_offset,
 
533
     &d_i0,k_i0_offset,ctx,40)
 
534
      end if
 
535
c
 
536
c
 
537
      if(level_x.eq.1) then 
 
538
      CALL icsd_t2_8(d_c2,k_t2_offset,d_v2,k_v2_offset,
 
539
     &d_i0,k_i0_offset,ctx,41)
 
540
      end if
 
541
c
 
542
cc        if(level_x.eq.1) then
 
543
c -----------------------------------
 
544
c      localize 2 intermediates
 
545
c -----------------------------------
 
546
c
 
547
cc        call ga_sync()
 
548
c
 
549
cc        call ma_zero(dbl_mb(k_i1_4_local),size_i1_4)
 
550
cc        call ga_get(d_i1_4,1,size_i1_4,1,1,dbl_mb(k_i1_4_local),1)
 
551
c
 
552
cc        call ma_zero(dbl_mb(k_i1_5_local),size_i1_5)
 
553
cc        call ga_get(d_i1_5,1,size_i1_5,1,1,dbl_mb(k_i1_5_local),1)
 
554
cc        end if
 
555
 
 
556
        call ga_sync()
 
557
 
 
558
      enddo ! -- level_x --------
 
559
c counters are closed here
 
560
      call nxt_ctx_destroy(ctx)
 
561
c
 
562
c closing files
 
563
c
 
564
      call deletefile(d_i1_vt)
 
565
      call deletefile(d_i1_7)
 
566
      call deletefile(d_i2_6)
 
567
      call deletefile(d_i1_6)
 
568
      call deletefile(d_i1_5)
 
569
      call deletefile(d_i2_4)
 
570
      call deletefile(d_i1_4)
 
571
      call deletefile(d_i2_2d)
 
572
      call deletefile(d_i2_2c)
 
573
      call deletefile(d_i3_2)
 
574
      call deletefile(d_i2_2a)
 
575
      call deletefile(d_i1_2)
 
576
c
 
577
c closing all OFFSETS
 
578
c
 
579
c      IF (.not.MA_POP_STACK(l_i1_5_local))
 
580
c     & CALL ERRQUIT('l_-1',-1,MA_ERR)
 
581
c      IF (.not.MA_POP_STACK(l_i1_4_local))
 
582
c     & CALL ERRQUIT('l_0',-1,MA_ERR)
 
583
      IF (.not.MA_POP_STACK(l_i1_vt_offset))
 
584
     & CALL ERRQUIT('l_1',-1,MA_ERR)
 
585
      IF (.not.MA_POP_STACK(l_i1_7_offset))
 
586
     & CALL ERRQUIT('l_2',-1,MA_ERR)
 
587
      IF (.not.MA_POP_STACK(l_i2_6_offset))
 
588
     & CALL ERRQUIT('l_3',-1,MA_ERR)
 
589
      IF (.not.MA_POP_STACK(l_i1_6_offset))
 
590
     & CALL ERRQUIT('l_4',-1,MA_ERR)
 
591
      IF (.not.MA_POP_STACK(l_i1_5_offset))
 
592
     & CALL ERRQUIT('l_5',-1,MA_ERR)
 
593
      IF (.not.MA_POP_STACK(l_i2_4_offset))
 
594
     & CALL ERRQUIT('l_6',-1,MA_ERR)
 
595
      IF (.not.MA_POP_STACK(l_i1_4_offset))
 
596
     & CALL ERRQUIT('l_7',-1,MA_ERR)
 
597
      IF (.not.MA_POP_STACK(l_i2_2d_offset))
 
598
     & CALL ERRQUIT('l_8',-1,MA_ERR)
 
599
      IF (.not.MA_POP_STACK(l_i2_2c_offset))
 
600
     & CALL ERRQUIT('l_9',-1,MA_ERR)
 
601
      IF (.not.MA_POP_STACK(l_i3_2_offset))
 
602
     & CALL ERRQUIT('l_10',-1,MA_ERR) 
 
603
      IF (.not.MA_POP_STACK(l_i2_2a_offset))
 
604
     & CALL ERRQUIT('l_11',-1,MA_ERR)
 
605
      IF (.not.MA_POP_STACK(l_i1_2_offset))
 
606
     & CALL ERRQUIT('l_12',-1,MA_ERR)
 
607
c
 
608
c
 
609
c
 
610
      RETURN
 
611
      END
 
612
      SUBROUTINE icsd_t2_1(d_a,k_a_offset,d_c,k_c_offset,ctx,icounter)
 
613
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
614
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
615
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
616
C     i0 ( p3 p4 h1 h2 )_v + = 1 * v ( p3 p4 h1 h2 )_v
 
617
      IMPLICIT NONE
 
618
#include "global.fh"
 
619
#include "mafdecls.fh"
 
620
#include "sym.fh"
 
621
#include "errquit.fh"
 
622
#include "tce.fh"
 
623
      INTEGER d_a
 
624
      INTEGER k_a_offset
 
625
      INTEGER d_c
 
626
      INTEGER k_c_offset
 
627
c old way      INTEGER NXTASK
 
628
c -------------------------
 
629
      INTEGER ctx,icounter
 
630
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
631
c -------------------------
 
632
      INTEGER next
 
633
      INTEGER nprocs
 
634
      INTEGER count
 
635
      INTEGER p3b
 
636
      INTEGER p4b
 
637
      INTEGER h1b
 
638
      INTEGER h2b
 
639
      INTEGER dimc
 
640
      INTEGER p3b_1
 
641
      INTEGER p4b_1
 
642
      INTEGER h1b_1
 
643
      INTEGER h2b_1
 
644
      INTEGER dim_common
 
645
      INTEGER dima_sort
 
646
      INTEGER dima
 
647
      INTEGER l_a_sort
 
648
      INTEGER k_a_sort
 
649
      INTEGER l_a
 
650
      INTEGER k_a
 
651
      INTEGER l_c
 
652
      INTEGER k_c
 
653
c old way      EXTERNAL NXTASK
 
654
      nprocs = GA_NNODES()
 
655
      count = 0
 
656
c old way      next = NXTASK(nprocs, 1)
 
657
c --- new way ----
 
658
      call nxt_ctx_next(ctx, icounter, next)
 
659
c ----------------
 
660
      DO p3b = noab+1,noab+nvab
 
661
      DO p4b = p3b,noab+nvab
 
662
      DO h1b = 1,noab
 
663
      DO h2b = h1b,noab
 
664
      IF (next.eq.count) THEN
 
665
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
666
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
667
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
668
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
669
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
670
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
 
671
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
672
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
673
      CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h2b,p3b_1,p4b_1,h1b_1,h2b_1)
 
674
      dim_common = 1
 
675
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb
 
676
     &(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
677
      dima = dim_common * dima_sort
 
678
      IF (dima .gt. 0) THEN
 
679
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
680
     & ERRQUIT('icsd_t2_1',0,MA_ERR)
 
681
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
682
     &icsd_t2_1',1,MA_ERR)
 
683
      if(.not.intorb) then
 
684
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
685
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p4b_1 - 1 + (noab
 
686
     &+nvab) * (p3b_1 - 1)))))
 
687
      else
 
688
      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
 
689
     &(h2b_1
 
690
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p4b_1 - 1 + (noab
 
691
     &+nvab) * (p3b_1 - 1)))),h2b_1,h1b_1,p4b_1,p3b_1)
 
692
      end if
 
693
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
694
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
695
     &,4,3,2,1,1.0d0)
 
696
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_1',2,MA_ERR)
 
697
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
698
     &icsd_t2_1',3,MA_ERR)
 
699
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
700
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
701
     &,4,3,2,1,1.0d0)
 
702
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
703
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
704
     & - 1)))))
 
705
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_1',4,MA_ERR)
 
706
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_1',5,MA_ERR
 
707
     &)
 
708
      END IF
 
709
      END IF
 
710
      END IF
 
711
      END IF
 
712
c old way      next = NXTASK(nprocs, 1)
 
713
c --- new way ----
 
714
      call nxt_ctx_next(ctx, icounter, next)
 
715
c ----------------
 
716
      END IF
 
717
      count = count + 1
 
718
      END DO
 
719
      END DO
 
720
      END DO
 
721
      END DO
 
722
c old way      next = NXTASK(-nprocs, 1)
 
723
c old way      call GA_SYNC()
 
724
      RETURN
 
725
      END
 
726
      SUBROUTINE icsd_t2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset,
 
727
     &ctx,icounter)
 
728
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
729
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
730
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
731
C     i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( h10 ) * t ( p3 h10 )_t * i1 ( h10 p4 h1 h2 )_v
 
732
      IMPLICIT NONE
 
733
#include "global.fh"
 
734
#include "mafdecls.fh"
 
735
#include "sym.fh"
 
736
#include "errquit.fh"
 
737
#include "tce.fh"
 
738
      INTEGER d_a
 
739
      INTEGER k_a_offset
 
740
      INTEGER d_b
 
741
      INTEGER k_b_offset
 
742
      INTEGER d_c
 
743
      INTEGER k_c_offset
 
744
c old way      INTEGER NXTASK
 
745
      INTEGER next
 
746
      INTEGER nprocs
 
747
      INTEGER count
 
748
      INTEGER p3b
 
749
      INTEGER p4b
 
750
      INTEGER h1b
 
751
      INTEGER h2b
 
752
      INTEGER dimc
 
753
      INTEGER l_c_sort
 
754
      INTEGER k_c_sort
 
755
c -------------------------
 
756
      INTEGER ctx,icounter
 
757
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
758
c -------------------------
 
759
      INTEGER h10b
 
760
      INTEGER p3b_1
 
761
      INTEGER h10b_1
 
762
      INTEGER p4b_2
 
763
      INTEGER h10b_2
 
764
      INTEGER h1b_2
 
765
      INTEGER h2b_2
 
766
      INTEGER dim_common
 
767
      INTEGER dima_sort
 
768
      INTEGER dima
 
769
      INTEGER dimb_sort
 
770
      INTEGER dimb
 
771
      INTEGER l_a_sort
 
772
      INTEGER k_a_sort
 
773
      INTEGER l_a
 
774
      INTEGER k_a
 
775
      INTEGER l_b_sort
 
776
      INTEGER k_b_sort
 
777
      INTEGER l_b
 
778
      INTEGER k_b
 
779
      INTEGER l_c
 
780
      INTEGER k_c
 
781
c old way      EXTERNAL NXTASK
 
782
      nprocs = GA_NNODES()
 
783
      count = 0
 
784
c old way      next = NXTASK(nprocs, 1)
 
785
c --- new way ----
 
786
      call nxt_ctx_next(ctx, icounter, next)
 
787
c ----------------
 
788
      DO p3b = noab+1,noab+nvab
 
789
      DO p4b = noab+1,noab+nvab
 
790
      DO h1b = 1,noab
 
791
      DO h2b = h1b,noab
 
792
      IF (next.eq.count) THEN
 
793
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
794
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
795
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
796
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
797
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
798
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
799
     &EN
 
800
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
801
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
802
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
803
     & ERRQUIT('icsd_t2_2',0,MA_ERR)
 
804
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
805
      DO h10b = 1,noab
 
806
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h10b-1)) THEN
 
807
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h10b-1)) .eq. irrep_t) T
 
808
     &HEN
 
809
      CALL TCE_RESTRICTED_2(p3b,h10b,p3b_1,h10b_1)
 
810
      CALL TCE_RESTRICTED_4(p4b,h10b,h1b,h2b,p4b_2,h10b_2,h1b_2,h2b_2)
 
811
      dim_common = int_mb(k_range+h10b-1)
 
812
      dima_sort = int_mb(k_range+p3b-1)
 
813
      dima = dim_common * dima_sort
 
814
      dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1) * int_mb
 
815
     &(k_range+h2b-1)
 
816
      dimb = dim_common * dimb_sort
 
817
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
818
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
819
     & ERRQUIT('icsd_t2_2',1,MA_ERR)
 
820
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
821
     &icsd_t2_2',2,MA_ERR)
 
822
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
823
     & int_mb(k_a_offset),(h10b_
 
824
     &1 - 1 + noab * (p3b_1 - noab - 1)))
 
825
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
826
     &,int_mb(k_range+h10b-1),1,2,1.0d0)
 
827
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2',3,MA_ERR)
 
828
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
829
     & ERRQUIT('icsd_t2_2',4,MA_ERR)
 
830
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
831
     &icsd_t2_2',5,MA_ERR)
 
832
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
 
833
     & - 1 + noab * (h1b_2 - 1 + noab * (h10b_2 - 1 + noab * (p4b_2 - no
 
834
     &ab - 1)))))
 
835
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
 
836
     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
 
837
     &),4,3,1,2,1.0d0)
 
838
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2',6,MA_ERR)
 
839
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
840
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
841
     &t),dima_sort)
 
842
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2',7,MA_ERR
 
843
     &)
 
844
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2',8,MA_ERR
 
845
     &)
 
846
      END IF
 
847
      END IF
 
848
      END IF
 
849
      END DO
 
850
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
851
     &icsd_t2_2',9,MA_ERR)
 
852
      IF ((p3b .le. p4b)) THEN
 
853
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
854
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
855
     &,4,3,2,1,-1.0d0)
 
856
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
857
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
858
     & - 1)))))
 
859
      END IF
 
860
      IF ((p4b .le. p3b)) THEN
 
861
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
862
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
863
     &,3,4,2,1,1.0d0)
 
864
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
865
     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
 
866
     & - 1)))))
 
867
      END IF
 
868
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2',10,MA_ERR)
 
869
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2',11,MA_ER
 
870
     &R)
 
871
      END IF
 
872
      END IF
 
873
      END IF
 
874
c old way      next = NXTASK(nprocs, 1)
 
875
c --- new way ----
 
876
      call nxt_ctx_next(ctx, icounter, next)
 
877
c ----------------
 
878
      END IF
 
879
      count = count + 1
 
880
      END DO
 
881
      END DO
 
882
      END DO
 
883
      END DO
 
884
c old way      next = NXTASK(-nprocs, 1)
 
885
c old way      call GA_SYNC()
 
886
      RETURN
 
887
      END
 
888
      SUBROUTINE icsd_t2_2_1(d_a,k_a_offset,d_c,k_c_offset,ctx,icounter)
 
889
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
890
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
891
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
892
C     i1 ( h10 p3 h1 h2 )_v + = 1 * v ( h10 p3 h1 h2 )_v
 
893
      IMPLICIT NONE
 
894
#include "global.fh"
 
895
#include "mafdecls.fh"
 
896
#include "sym.fh"
 
897
#include "errquit.fh"
 
898
#include "tce.fh"
 
899
      INTEGER d_a
 
900
      INTEGER k_a_offset
 
901
      INTEGER d_c
 
902
      INTEGER k_c_offset
 
903
c old way      INTEGER NXTASK
 
904
      INTEGER next
 
905
      INTEGER nprocs
 
906
      INTEGER count
 
907
c -------------------------
 
908
      INTEGER ctx,icounter
 
909
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
910
c -------------------------
 
911
      INTEGER p3b
 
912
      INTEGER h10b
 
913
      INTEGER h1b
 
914
      INTEGER h2b
 
915
      INTEGER dimc
 
916
      INTEGER p3b_1
 
917
      INTEGER h10b_1
 
918
      INTEGER h1b_1
 
919
      INTEGER h2b_1
 
920
      INTEGER dim_common
 
921
      INTEGER dima_sort
 
922
      INTEGER dima
 
923
      INTEGER l_a_sort
 
924
      INTEGER k_a_sort
 
925
      INTEGER l_a
 
926
      INTEGER k_a
 
927
      INTEGER l_c
 
928
      INTEGER k_c
 
929
c old way      EXTERNAL NXTASK
 
930
      nprocs = GA_NNODES()
 
931
      count = 0
 
932
c old way      next = NXTASK(nprocs, 1)
 
933
c --- new way ----
 
934
      call nxt_ctx_next(ctx, icounter, next)
 
935
c ----------------
 
936
      DO p3b = noab+1,noab+nvab
 
937
      DO h10b = 1,noab
 
938
      DO h1b = 1,noab
 
939
      DO h2b = h1b,noab
 
940
      IF (next.eq.count) THEN
 
941
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
 
942
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
943
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
944
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
945
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
946
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
 
947
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
 
948
     &ange+h1b-1) * int_mb(k_range+h2b-1)
 
949
      CALL TCE_RESTRICTED_4(p3b,h10b,h1b,h2b,p3b_1,h10b_1,h1b_1,h2b_1)
 
950
      dim_common = 1
 
951
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_m
 
952
     &b(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
953
      dima = dim_common * dima_sort
 
954
      IF (dima .gt. 0) THEN
 
955
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
956
     & ERRQUIT('icsd_t2_2_1',0,MA_ERR)
 
957
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
958
     &icsd_t2_2_1',1,MA_ERR)
 
959
      IF ((h10b .le. p3b)) THEN
 
960
      if(.not.intorb) then
 
961
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
962
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
 
963
     &+nvab) * (h10b_1 - 1)))))
 
964
      else
 
965
      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
 
966
     &(h2b_1
 
967
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
 
968
     &+nvab) * (h10b_1 - 1)))),h2b_1,h1b_1,p3b_1,h10b_1)
 
969
      end if
 
970
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1
 
971
     &),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
 
972
     &),4,3,1,2,1.0d0)
 
973
      END IF
 
974
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_1',2,MA_ERR)
 
975
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
976
     &icsd_t2_2_1',3,MA_ERR)
 
977
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
978
     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+p3b-1
 
979
     &),4,3,2,1,1.0d0)
 
980
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
981
     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
 
982
     &)))
 
983
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_1',4,MA_ERR)
 
984
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_1',5,MA_E
 
985
     &RR)
 
986
      END IF
 
987
      END IF
 
988
      END IF
 
989
      END IF
 
990
c old way      next = NXTASK(nprocs, 1)
 
991
c --- new way ----
 
992
      call nxt_ctx_next(ctx, icounter, next)
 
993
c ----------------
 
994
      END IF
 
995
      count = count + 1
 
996
      END DO
 
997
      END DO
 
998
      END DO
 
999
      END DO
 
1000
c old way      next = NXTASK(-nprocs, 1)
 
1001
c old way      call GA_SYNC()
 
1002
      RETURN
 
1003
      END
 
1004
      SUBROUTINE OFFSET_icsd_t2_2_1(l_a_offset,k_a_offset,size)
 
1005
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
1006
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
1007
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
1008
C     i1 ( h10 p3 h1 h2 )_v
 
1009
      IMPLICIT NONE
 
1010
#include "global.fh"
 
1011
#include "mafdecls.fh"
 
1012
#include "sym.fh"
 
1013
#include "errquit.fh"
 
1014
#include "tce.fh"
 
1015
      INTEGER l_a_offset
 
1016
      INTEGER k_a_offset
 
1017
      INTEGER size
 
1018
      INTEGER length
 
1019
      INTEGER addr
 
1020
      INTEGER p3b
 
1021
      INTEGER h10b
 
1022
      INTEGER h1b
 
1023
      INTEGER h2b
 
1024
      length = 0
 
1025
      DO p3b = noab+1,noab+nvab
 
1026
      DO h10b = 1,noab
 
1027
      DO h1b = 1,noab
 
1028
      DO h2b = h1b,noab
 
1029
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+
 
1030
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
1031
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb
 
1032
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
 
1033
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-
 
1034
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
1035
      length = length + 1
 
1036
      END IF
 
1037
      END IF
 
1038
      END IF
 
1039
      END DO
 
1040
      END DO
 
1041
      END DO
 
1042
      END DO
 
1043
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
1044
     &set)) CALL ERRQUIT('icsd_t2_2_1',0,MA_ERR)
 
1045
      int_mb(k_a_offset) = length
 
1046
      addr = 0
 
1047
      size = 0
 
1048
      DO p3b = noab+1,noab+nvab
 
1049
      DO h10b = 1,noab
 
1050
      DO h1b = 1,noab
 
1051
      DO h2b = h1b,noab
 
1052
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+
 
1053
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
1054
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb
 
1055
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
 
1056
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-
 
1057
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
1058
      addr = addr + 1
 
1059
      int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h10b
 
1060
     & - 1 + noab * (p3b - noab - 1)))
 
1061
      int_mb(k_a_offset+length+addr) = size
 
1062
      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int
 
1063
     &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
1064
      END IF
 
1065
      END IF
 
1066
      END IF
 
1067
      END DO
 
1068
      END DO
 
1069
      END DO
 
1070
      END DO
 
1071
      RETURN
 
1072
      END
 
1073
      SUBROUTINE icsd_t2_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
1074
     &t,ctx,icounter)
 
1075
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
1076
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
1077
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
1078
C     i1 ( h10 p3 h1 h2 )_vt + = 1/2 * Sum ( h11 ) * t ( p3 h11 )_t * i2 ( h10 h11 h1 h2 )_v
 
1079
      IMPLICIT NONE
 
1080
#include "global.fh"
 
1081
#include "mafdecls.fh"
 
1082
#include "sym.fh"
 
1083
#include "errquit.fh"
 
1084
#include "tce.fh"
 
1085
      INTEGER d_a
 
1086
      INTEGER k_a_offset
 
1087
      INTEGER d_b
 
1088
      INTEGER k_b_offset
 
1089
      INTEGER d_c
 
1090
      INTEGER k_c_offset
 
1091
c old way      INTEGER NXTASK
 
1092
c -------------------------
 
1093
      INTEGER ctx,icounter
 
1094
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
1095
c -------------------------
 
1096
      INTEGER next
 
1097
      INTEGER nprocs
 
1098
      INTEGER count
 
1099
      INTEGER p3b
 
1100
      INTEGER h10b
 
1101
      INTEGER h1b
 
1102
      INTEGER h2b
 
1103
      INTEGER dimc
 
1104
      INTEGER l_c_sort
 
1105
      INTEGER k_c_sort
 
1106
      INTEGER h11b
 
1107
      INTEGER p3b_1
 
1108
      INTEGER h11b_1
 
1109
      INTEGER h10b_2
 
1110
      INTEGER h11b_2
 
1111
      INTEGER h1b_2
 
1112
      INTEGER h2b_2
 
1113
      INTEGER dim_common
 
1114
      INTEGER dima_sort
 
1115
      INTEGER dima
 
1116
      INTEGER dimb_sort
 
1117
      INTEGER dimb
 
1118
      INTEGER l_a_sort
 
1119
      INTEGER k_a_sort
 
1120
      INTEGER l_a
 
1121
      INTEGER k_a
 
1122
      INTEGER l_b_sort
 
1123
      INTEGER k_b_sort
 
1124
      INTEGER l_b
 
1125
      INTEGER k_b
 
1126
      INTEGER l_c
 
1127
      INTEGER k_c
 
1128
c old way      EXTERNAL NXTASK
 
1129
      nprocs = GA_NNODES()
 
1130
      count = 0
 
1131
c old way      next = NXTASK(nprocs, 1)
 
1132
c --- new way ----
 
1133
      call nxt_ctx_next(ctx, icounter, next)
 
1134
c ----------------
 
1135
      DO p3b = noab+1,noab+nvab
 
1136
      DO h10b = 1,noab
 
1137
      DO h1b = 1,noab
 
1138
      DO h2b = h1b,noab
 
1139
      IF (next.eq.count) THEN
 
1140
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
 
1141
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
1142
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
1143
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
1144
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
1145
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T
 
1146
     &HEN
 
1147
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
 
1148
     &ange+h1b-1) * int_mb(k_range+h2b-1)
 
1149
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
1150
     & ERRQUIT('icsd_t2_2_2',0,MA_ERR)
 
1151
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
1152
      DO h11b = 1,noab
 
1153
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h11b-1)) THEN
 
1154
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h11b-1)) .eq. irrep_t) T
 
1155
     &HEN
 
1156
      CALL TCE_RESTRICTED_2(p3b,h11b,p3b_1,h11b_1)
 
1157
      CALL TCE_RESTRICTED_4(h10b,h11b,h1b,h2b,h10b_2,h11b_2,h1b_2,h2b_2)
 
1158
      dim_common = int_mb(k_range+h11b-1)
 
1159
      dima_sort = int_mb(k_range+p3b-1)
 
1160
      dima = dim_common * dima_sort
 
1161
      dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h1b-1) * int_m
 
1162
     &b(k_range+h2b-1)
 
1163
      dimb = dim_common * dimb_sort
 
1164
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
1165
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
1166
     & ERRQUIT('icsd_t2_2_2',1,MA_ERR)
 
1167
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
1168
     &icsd_t2_2_2',2,MA_ERR)
 
1169
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
1170
     & int_mb(k_a_offset),(h11b_
 
1171
     &1 - 1 + noab * (p3b_1 - noab - 1)))
 
1172
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
1173
     &,int_mb(k_range+h11b-1),1,2,1.0d0)
 
1174
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_2',3,MA_ERR)
 
1175
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
1176
     & ERRQUIT('icsd_t2_2_2',4,MA_ERR)
 
1177
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
1178
     &icsd_t2_2_2',5,MA_ERR)
 
1179
      IF ((h11b .lt. h10b)) THEN
 
1180
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
 
1181
     & - 1 + noab * (h1b_2 - 1 + noab * (h10b_2 - 1 + noab * (h11b_2 - 1
 
1182
     &)))))
 
1183
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h11b-1
 
1184
     &),int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-
 
1185
     &1),4,3,2,1,-1.0d0)
 
1186
      END IF
 
1187
      IF ((h10b .le. h11b)) THEN
 
1188
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
 
1189
     & - 1 + noab * (h1b_2 - 1 + noab * (h11b_2 - 1 + noab * (h10b_2 - 1
 
1190
     &)))))
 
1191
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
1192
     &),int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-
 
1193
     &1),4,3,1,2,1.0d0)
 
1194
      END IF
 
1195
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_2',6,MA_ERR)
 
1196
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
1197
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
1198
     &t),dima_sort)
 
1199
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_2',7,MA_E
 
1200
     &RR)
 
1201
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_2',8,MA_E
 
1202
     &RR)
 
1203
      END IF
 
1204
      END IF
 
1205
      END IF
 
1206
      END DO
 
1207
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
1208
     &icsd_t2_2_2',9,MA_ERR)
 
1209
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
1210
     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+p3b-1
 
1211
     &),4,3,2,1,1.0d0/2.0d0)
 
1212
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
1213
     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
 
1214
     &)))
 
1215
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_2',10,MA_ERR)
 
1216
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_2',11,MA_
 
1217
     &ERR)
 
1218
      END IF
 
1219
      END IF
 
1220
      END IF
 
1221
c old way      next = NXTASK(nprocs, 1)
 
1222
c --- new way ----
 
1223
      call nxt_ctx_next(ctx, icounter, next)
 
1224
c ----------------
 
1225
      END IF
 
1226
      count = count + 1
 
1227
      END DO
 
1228
      END DO
 
1229
      END DO
 
1230
      END DO
 
1231
c old way      next = NXTASK(-nprocs, 1)
 
1232
c old way      call GA_SYNC()
 
1233
      RETURN
 
1234
      END
 
1235
      SUBROUTINE icsd_t2_2_2_1(d_a,k_a_offset,d_c,k_c_offset,
 
1236
     & ctx,icounter)
 
1237
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
1238
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
1239
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
1240
C     i2 ( h10 h11 h1 h2 )_v + = -1 * v ( h10 h11 h1 h2 )_v
 
1241
      IMPLICIT NONE
 
1242
#include "global.fh"
 
1243
#include "mafdecls.fh"
 
1244
#include "sym.fh"
 
1245
#include "errquit.fh"
 
1246
#include "tce.fh"
 
1247
      INTEGER d_a
 
1248
      INTEGER k_a_offset
 
1249
      INTEGER d_c
 
1250
      INTEGER k_c_offset
 
1251
c old way      INTEGER NXTASK
 
1252
c -------------------------
 
1253
      INTEGER ctx,icounter
 
1254
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
1255
c -------------------------
 
1256
      INTEGER next
 
1257
      INTEGER nprocs
 
1258
      INTEGER count
 
1259
      INTEGER h10b
 
1260
      INTEGER h11b
 
1261
      INTEGER h1b
 
1262
      INTEGER h2b
 
1263
      INTEGER dimc
 
1264
      INTEGER h10b_1
 
1265
      INTEGER h11b_1
 
1266
      INTEGER h1b_1
 
1267
      INTEGER h2b_1
 
1268
      INTEGER dim_common
 
1269
      INTEGER dima_sort
 
1270
      INTEGER dima
 
1271
      INTEGER l_a_sort
 
1272
      INTEGER k_a_sort
 
1273
      INTEGER l_a
 
1274
      INTEGER k_a
 
1275
      INTEGER l_c
 
1276
      INTEGER k_c
 
1277
c old way      EXTERNAL NXTASK
 
1278
      nprocs = GA_NNODES()
 
1279
      count = 0
 
1280
c old way      next = NXTASK(nprocs, 1)
 
1281
c --- new way ----
 
1282
      call nxt_ctx_next(ctx, icounter, next)
 
1283
c ----------------
 
1284
      DO h10b = 1,noab
 
1285
      DO h11b = h10b,noab
 
1286
      DO h1b = 1,noab
 
1287
      DO h2b = h1b,noab
 
1288
      IF (next.eq.count) THEN
 
1289
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b
 
1290
     &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
1291
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin
 
1292
     &+h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
1293
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m
 
1294
     &b(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
 
1295
      dimc = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_mb(k_
 
1296
     &range+h1b-1) * int_mb(k_range+h2b-1)
 
1297
      CALL TCE_RESTRICTED_4(h10b,h11b,h1b,h2b,h10b_1,h11b_1,h1b_1,h2b_1)
 
1298
      dim_common = 1
 
1299
      dima_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_
 
1300
     &mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
1301
      dima = dim_common * dima_sort
 
1302
      IF (dima .gt. 0) THEN
 
1303
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
1304
     & ERRQUIT('icsd_t2_2_2_1',0,MA_ERR)
 
1305
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
1306
     &icsd_t2_2_2_1',1,MA_ERR)
 
1307
      if(.not.intorb) then
 
1308
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
1309
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa
 
1310
     &b+nvab) * (h10b_1 - 1)))))
 
1311
      else
 
1312
      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
 
1313
     &(h2b_1
 
1314
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa
 
1315
     &b+nvab) * (h10b_1 - 1)))),h2b_1,h1b_1,h11b_1,h10b_1)
 
1316
      end if
 
1317
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1
 
1318
     &),int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-
 
1319
     &1),4,3,2,1,1.0d0)
 
1320
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_2_1',2,MA_ERR)
 
1321
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
1322
     &icsd_t2_2_2_1',3,MA_ERR)
 
1323
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
1324
     &,int_mb(k_range+h1b-1),int_mb(k_range+h11b-1),int_mb(k_range+h10b-
 
1325
     &1),4,3,2,1,-1.0d0)
 
1326
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
1327
     & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h10b - 1)))))
 
1328
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_2_1',4,MA_ERR)
 
1329
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_2_1',5,MA
 
1330
     &_ERR)
 
1331
      END IF
 
1332
      END IF
 
1333
      END IF
 
1334
      END IF
 
1335
c old way      next = NXTASK(nprocs, 1)
 
1336
c --- new way ----
 
1337
      call nxt_ctx_next(ctx, icounter, next)
 
1338
c ----------------
 
1339
      END IF
 
1340
      count = count + 1
 
1341
      END DO
 
1342
      END DO
 
1343
      END DO
 
1344
      END DO
 
1345
c old way      next = NXTASK(-nprocs, 1)
 
1346
c old way      call GA_SYNC()
 
1347
      RETURN
 
1348
      END
 
1349
      SUBROUTINE OFFSET_icsd_t2_2_2_1(l_a_offset,k_a_offset,size)
 
1350
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
1351
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
1352
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
1353
C     i2 ( h10 h11 h1 h2 )_v
 
1354
      IMPLICIT NONE
 
1355
#include "global.fh"
 
1356
#include "mafdecls.fh"
 
1357
#include "sym.fh"
 
1358
#include "errquit.fh"
 
1359
#include "tce.fh"
 
1360
      INTEGER l_a_offset
 
1361
      INTEGER k_a_offset
 
1362
      INTEGER size
 
1363
      INTEGER length
 
1364
      INTEGER addr
 
1365
      INTEGER h10b
 
1366
      INTEGER h11b
 
1367
      INTEGER h1b
 
1368
      INTEGER h2b
 
1369
      length = 0
 
1370
      DO h10b = 1,noab
 
1371
      DO h11b = h10b,noab
 
1372
      DO h1b = 1,noab
 
1373
      DO h2b = h1b,noab
 
1374
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin
 
1375
     &+h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
1376
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m
 
1377
     &b(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
 
1378
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b
 
1379
     &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
1380
      length = length + 1
 
1381
      END IF
 
1382
      END IF
 
1383
      END IF
 
1384
      END DO
 
1385
      END DO
 
1386
      END DO
 
1387
      END DO
 
1388
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
1389
     &set)) CALL ERRQUIT('icsd_t2_2_2_1',0,MA_ERR)
 
1390
      int_mb(k_a_offset) = length
 
1391
      addr = 0
 
1392
      size = 0
 
1393
      DO h10b = 1,noab
 
1394
      DO h11b = h10b,noab
 
1395
      DO h1b = 1,noab
 
1396
      DO h2b = h1b,noab
 
1397
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin
 
1398
     &+h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
1399
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m
 
1400
     &b(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
 
1401
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b
 
1402
     &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
1403
      addr = addr + 1
 
1404
      int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h11b
 
1405
     & - 1 + noab * (h10b - 1)))
 
1406
      int_mb(k_a_offset+length+addr) = size
 
1407
      size = size + int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * in
 
1408
     &t_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
1409
      END IF
 
1410
      END IF
 
1411
      END IF
 
1412
      END DO
 
1413
      END DO
 
1414
      END DO
 
1415
      END DO
 
1416
      RETURN
 
1417
      END
 
1418
      SUBROUTINE icsd_t2_2_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
 
1419
     &set,ctx,icounter)
 
1420
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
1421
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
1422
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
1423
C     i2 ( h10 h11 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i3 ( h10 h11 h2 p5 )_v
 
1424
      IMPLICIT NONE
 
1425
#include "global.fh"
 
1426
#include "mafdecls.fh"
 
1427
#include "sym.fh"
 
1428
#include "errquit.fh"
 
1429
#include "tce.fh"
 
1430
      INTEGER d_a
 
1431
      INTEGER k_a_offset
 
1432
      INTEGER d_b
 
1433
      INTEGER k_b_offset
 
1434
      INTEGER d_c
 
1435
      INTEGER k_c_offset
 
1436
c old way      INTEGER NXTASK
 
1437
c -------------------------
 
1438
      INTEGER ctx,icounter
 
1439
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
1440
c -------------------------
 
1441
      INTEGER next
 
1442
      INTEGER nprocs
 
1443
      INTEGER count
 
1444
      INTEGER h10b
 
1445
      INTEGER h11b
 
1446
      INTEGER h1b
 
1447
      INTEGER h2b
 
1448
      INTEGER dimc
 
1449
      INTEGER l_c_sort
 
1450
      INTEGER k_c_sort
 
1451
      INTEGER p5b
 
1452
      INTEGER p5b_1
 
1453
      INTEGER h1b_1
 
1454
      INTEGER h10b_2
 
1455
      INTEGER h11b_2
 
1456
      INTEGER h2b_2
 
1457
      INTEGER p5b_2
 
1458
      INTEGER dim_common
 
1459
      INTEGER dima_sort
 
1460
      INTEGER dima
 
1461
      INTEGER dimb_sort
 
1462
      INTEGER dimb
 
1463
      INTEGER l_a_sort
 
1464
      INTEGER k_a_sort
 
1465
      INTEGER l_a
 
1466
      INTEGER k_a
 
1467
      INTEGER l_b_sort
 
1468
      INTEGER k_b_sort
 
1469
      INTEGER l_b
 
1470
      INTEGER k_b
 
1471
      INTEGER l_c
 
1472
      INTEGER k_c
 
1473
c old way      EXTERNAL NXTASK
 
1474
      nprocs = GA_NNODES()
 
1475
      count = 0
 
1476
c old way      next = NXTASK(nprocs, 1)
 
1477
c --- new way ----
 
1478
      call nxt_ctx_next(ctx, icounter, next)
 
1479
c ----------------
 
1480
      DO h10b = 1,noab
 
1481
      DO h11b = h10b,noab
 
1482
      DO h1b = 1,noab
 
1483
      DO h2b = 1,noab
 
1484
      IF (next.eq.count) THEN
 
1485
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b
 
1486
     &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
1487
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin
 
1488
     &+h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
1489
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m
 
1490
     &b(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) 
 
1491
     &THEN
 
1492
      dimc = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_mb(k_
 
1493
     &range+h1b-1) * int_mb(k_range+h2b-1)
 
1494
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
1495
     & ERRQUIT('icsd_t2_2_2_2',0,MA_ERR)
 
1496
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
1497
      DO p5b = noab+1,noab+nvab
 
1498
      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
1499
      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
1500
     &EN
 
1501
      CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1)
 
1502
      CALL TCE_RESTRICTED_4(h10b,h11b,h2b,p5b,h10b_2,h11b_2,h2b_2,p5b_2)
 
1503
      dim_common = int_mb(k_range+p5b-1)
 
1504
      dima_sort = int_mb(k_range+h1b-1)
 
1505
      dima = dim_common * dima_sort
 
1506
      dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_
 
1507
     &mb(k_range+h2b-1)
 
1508
      dimb = dim_common * dimb_sort
 
1509
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
1510
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
1511
     & ERRQUIT('icsd_t2_2_2_2',1,MA_ERR)
 
1512
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
1513
     &icsd_t2_2_2_2',2,MA_ERR)
 
1514
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
1515
     & int_mb(k_a_offset),(h1b_1
 
1516
     & - 1 + noab * (p5b_1 - noab - 1)))
 
1517
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
1518
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
1519
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_2_2',3,MA_ERR)
 
1520
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
1521
     & ERRQUIT('icsd_t2_2_2_2',4,MA_ERR)
 
1522
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
1523
     &icsd_t2_2_2_2',5,MA_ERR)
 
1524
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
1525
     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h11b_2 - 1 + noab * (h10
 
1526
     &b_2 - 1)))))
 
1527
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
1528
     &),int_mb(k_range+h11b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-
 
1529
     &1),3,2,1,4,1.0d0)
 
1530
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_2_2',6,MA_ERR)
 
1531
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
1532
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
1533
     &t),dima_sort)
 
1534
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_2_2',7,MA
 
1535
     &_ERR)
 
1536
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_2_2',8,MA
 
1537
     &_ERR)
 
1538
      END IF
 
1539
      END IF
 
1540
      END IF
 
1541
      END DO
 
1542
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
1543
     &icsd_t2_2_2_2',9,MA_ERR)
 
1544
      IF ((h1b .le. h2b)) THEN
 
1545
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
1546
     &,int_mb(k_range+h11b-1),int_mb(k_range+h10b-1),int_mb(k_range+h1b-
 
1547
     &1),3,2,4,1,1.0d0)
 
1548
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
1549
     & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h10b - 1)))))
 
1550
      END IF
 
1551
      IF ((h2b .le. h1b)) THEN
 
1552
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
1553
     &,int_mb(k_range+h11b-1),int_mb(k_range+h10b-1),int_mb(k_range+h1b-
 
1554
     &1),3,2,1,4,-1.0d0)
 
1555
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
1556
     & 1 + noab * (h2b - 1 + noab * (h11b - 1 + noab * (h10b - 1)))))
 
1557
      END IF
 
1558
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_2_2',10,MA_ERR
 
1559
     &)
 
1560
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_2_2',11,M
 
1561
     &A_ERR)
 
1562
      END IF
 
1563
      END IF
 
1564
      END IF
 
1565
c old way      next = NXTASK(nprocs, 1)
 
1566
c --- new way ----
 
1567
      call nxt_ctx_next(ctx, icounter, next)
 
1568
c ----------------
 
1569
      END IF
 
1570
      count = count + 1
 
1571
      END DO
 
1572
      END DO
 
1573
      END DO
 
1574
      END DO
 
1575
c old way      next = NXTASK(-nprocs, 1)
 
1576
c old way      call GA_SYNC()
 
1577
      RETURN
 
1578
      END
 
1579
      SUBROUTINE icsd_t2_2_2_2_1(d_a,k_a_offset,d_c,k_c_offset,
 
1580
     &ctx,icounter)
 
1581
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
1582
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
1583
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
1584
C     i3 ( h10 h11 h1 p5 )_v + = 1 * v ( h10 h11 h1 p5 )_v
 
1585
      IMPLICIT NONE
 
1586
#include "global.fh"
 
1587
#include "mafdecls.fh"
 
1588
#include "sym.fh"
 
1589
#include "errquit.fh"
 
1590
#include "tce.fh"
 
1591
      INTEGER d_a
 
1592
      INTEGER k_a_offset
 
1593
      INTEGER d_c
 
1594
      INTEGER k_c_offset
 
1595
c old way      INTEGER NXTASK
 
1596
c -------------------------
 
1597
      INTEGER ctx,icounter
 
1598
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
1599
c -------------------------
 
1600
      INTEGER next
 
1601
      INTEGER nprocs
 
1602
      INTEGER count
 
1603
      INTEGER h10b
 
1604
      INTEGER h11b
 
1605
      INTEGER h1b
 
1606
      INTEGER p5b
 
1607
      INTEGER dimc
 
1608
      INTEGER h10b_1
 
1609
      INTEGER h11b_1
 
1610
      INTEGER h1b_1
 
1611
      INTEGER p5b_1
 
1612
      INTEGER dim_common
 
1613
      INTEGER dima_sort
 
1614
      INTEGER dima
 
1615
      INTEGER l_a_sort
 
1616
      INTEGER k_a_sort
 
1617
      INTEGER l_a
 
1618
      INTEGER k_a
 
1619
      INTEGER l_c
 
1620
      INTEGER k_c
 
1621
c old way      EXTERNAL NXTASK
 
1622
      nprocs = GA_NNODES()
 
1623
      count = 0
 
1624
c old way      next = NXTASK(nprocs, 1)
 
1625
c --- new way ----
 
1626
      call nxt_ctx_next(ctx, icounter, next)
 
1627
c ----------------
 
1628
      DO h10b = 1,noab
 
1629
      DO h11b = h10b,noab
 
1630
      DO h1b = 1,noab
 
1631
      DO p5b = noab+1,noab+nvab
 
1632
      IF (next.eq.count) THEN
 
1633
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b
 
1634
     &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
1635
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin
 
1636
     &+h1b-1)+int_mb(k_spin+p5b-1)) THEN
 
1637
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m
 
1638
     &b(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
1639
      dimc = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_mb(k_
 
1640
     &range+h1b-1) * int_mb(k_range+p5b-1)
 
1641
      CALL TCE_RESTRICTED_4(h10b,h11b,h1b,p5b,h10b_1,h11b_1,h1b_1,p5b_1)
 
1642
      dim_common = 1
 
1643
      dima_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_
 
1644
     &mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
 
1645
      dima = dim_common * dima_sort
 
1646
      IF (dima .gt. 0) THEN
 
1647
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
1648
     & ERRQUIT('icsd_t2_2_2_2_1',0,MA_ERR)
 
1649
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
1650
     &icsd_t2_2_2_2_1',1,MA_ERR)
 
1651
      IF ((h1b .le. p5b)) THEN
 
1652
      if(.not.intorb) then
 
1653
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
 
1654
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa
 
1655
     &b+nvab) * (h10b_1 - 1)))))
 
1656
      else
 
1657
      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
 
1658
     &(p5b_1
 
1659
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa
 
1660
     &b+nvab) * (h10b_1 - 1)))),p5b_1,h1b_1,h11b_1,h10b_1)
 
1661
      end if
 
1662
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1
 
1663
     &),int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-
 
1664
     &1),4,3,2,1,1.0d0)
 
1665
      END IF
 
1666
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_2_2_1',2,MA_ER
 
1667
     &R)
 
1668
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
1669
     &icsd_t2_2_2_2_1',3,MA_ERR)
 
1670
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
1671
     &,int_mb(k_range+h1b-1),int_mb(k_range+h11b-1),int_mb(k_range+h10b-
 
1672
     &1),4,3,2,1,1.0d0)
 
1673
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
1674
     & noab - 1 + nvab * (h1b - 1 + noab * (h11b - 1 + noab * (h10b - 1)
 
1675
     &))))
 
1676
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_2_2_1',4,MA_ER
 
1677
     &R)
 
1678
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_2_2_1',5,
 
1679
     &MA_ERR)
 
1680
      END IF
 
1681
      END IF
 
1682
      END IF
 
1683
      END IF
 
1684
c old way      next = NXTASK(nprocs, 1)
 
1685
c --- new way ----
 
1686
      call nxt_ctx_next(ctx, icounter, next)
 
1687
c ----------------
 
1688
      END IF
 
1689
      count = count + 1
 
1690
      END DO
 
1691
      END DO
 
1692
      END DO
 
1693
      END DO
 
1694
c old way      next = NXTASK(-nprocs, 1)
 
1695
c old way      call GA_SYNC()
 
1696
      RETURN
 
1697
      END
 
1698
      SUBROUTINE OFFSET_icsd_t2_2_2_2_1(l_a_offset,k_a_offset,size)
 
1699
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
1700
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
1701
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
1702
C     i3 ( h10 h11 h1 p5 )_v
 
1703
      IMPLICIT NONE
 
1704
#include "global.fh"
 
1705
#include "mafdecls.fh"
 
1706
#include "sym.fh"
 
1707
#include "errquit.fh"
 
1708
#include "tce.fh"
 
1709
      INTEGER l_a_offset
 
1710
      INTEGER k_a_offset
 
1711
      INTEGER size
 
1712
      INTEGER length
 
1713
      INTEGER addr
 
1714
      INTEGER h10b
 
1715
      INTEGER h11b
 
1716
      INTEGER h1b
 
1717
      INTEGER p5b
 
1718
      length = 0
 
1719
      DO h10b = 1,noab
 
1720
      DO h11b = h10b,noab
 
1721
      DO h1b = 1,noab
 
1722
      DO p5b = noab+1,noab+nvab
 
1723
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin
 
1724
     &+h1b-1)+int_mb(k_spin+p5b-1)) THEN
 
1725
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m
 
1726
     &b(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
1727
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b
 
1728
     &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
1729
      length = length + 1
 
1730
      END IF
 
1731
      END IF
 
1732
      END IF
 
1733
      END DO
 
1734
      END DO
 
1735
      END DO
 
1736
      END DO
 
1737
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
1738
     &set)) CALL ERRQUIT('icsd_t2_2_2_2_1',0,MA_ERR)
 
1739
      int_mb(k_a_offset) = length
 
1740
      addr = 0
 
1741
      size = 0
 
1742
      DO h10b = 1,noab
 
1743
      DO h11b = h10b,noab
 
1744
      DO h1b = 1,noab
 
1745
      DO p5b = noab+1,noab+nvab
 
1746
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin
 
1747
     &+h1b-1)+int_mb(k_spin+p5b-1)) THEN
 
1748
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m
 
1749
     &b(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
1750
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b
 
1751
     &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
1752
      addr = addr + 1
 
1753
      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 
 
1754
     &* (h11b - 1 + noab * (h10b - 1)))
 
1755
      int_mb(k_a_offset+length+addr) = size
 
1756
      size = size + int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * in
 
1757
     &t_mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
 
1758
      END IF
 
1759
      END IF
 
1760
      END IF
 
1761
      END DO
 
1762
      END DO
 
1763
      END DO
 
1764
      END DO
 
1765
      RETURN
 
1766
      END
 
1767
      SUBROUTINE icsd_t2_2_2_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o
 
1768
     &ffset,ctx,icounter)
 
1769
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
1770
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
1771
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
1772
C     i3 ( h10 h11 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h10 h11 p5 p6 )_v
 
1773
      IMPLICIT NONE
 
1774
#include "global.fh"
 
1775
#include "mafdecls.fh"
 
1776
#include "sym.fh"
 
1777
#include "errquit.fh"
 
1778
#include "tce.fh"
 
1779
      INTEGER d_a
 
1780
      INTEGER k_a_offset
 
1781
      INTEGER d_b
 
1782
      INTEGER k_b_offset
 
1783
      INTEGER d_c
 
1784
      INTEGER k_c_offset
 
1785
c old way      INTEGER NXTASK
 
1786
c -------------------------
 
1787
      INTEGER ctx,icounter
 
1788
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
1789
c -------------------------
 
1790
      INTEGER next
 
1791
      INTEGER nprocs
 
1792
      INTEGER count
 
1793
      INTEGER h10b
 
1794
      INTEGER h11b
 
1795
      INTEGER h1b
 
1796
      INTEGER p5b
 
1797
      INTEGER dimc
 
1798
      INTEGER l_c_sort
 
1799
      INTEGER k_c_sort
 
1800
      INTEGER p6b
 
1801
      INTEGER p6b_1
 
1802
      INTEGER h1b_1
 
1803
      INTEGER h10b_2
 
1804
      INTEGER h11b_2
 
1805
      INTEGER p5b_2
 
1806
      INTEGER p6b_2
 
1807
      INTEGER dim_common
 
1808
      INTEGER dima_sort
 
1809
      INTEGER dima
 
1810
      INTEGER dimb_sort
 
1811
      INTEGER dimb
 
1812
      INTEGER l_a_sort
 
1813
      INTEGER k_a_sort
 
1814
      INTEGER l_a
 
1815
      INTEGER k_a
 
1816
      INTEGER l_b_sort
 
1817
      INTEGER k_b_sort
 
1818
      INTEGER l_b
 
1819
      INTEGER k_b
 
1820
      INTEGER l_c
 
1821
      INTEGER k_c
 
1822
c old way      EXTERNAL NXTASK
 
1823
      nprocs = GA_NNODES()
 
1824
      count = 0
 
1825
c old way      next = NXTASK(nprocs, 1)
 
1826
c --- new way ----
 
1827
      call nxt_ctx_next(ctx, icounter, next)
 
1828
c ----------------
 
1829
      DO h10b = 1,noab
 
1830
      DO h11b = h10b,noab
 
1831
      DO h1b = 1,noab
 
1832
      DO p5b = noab+1,noab+nvab
 
1833
      IF (next.eq.count) THEN
 
1834
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b
 
1835
     &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
1836
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin
 
1837
     &+h1b-1)+int_mb(k_spin+p5b-1)) THEN
 
1838
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m
 
1839
     &b(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) 
 
1840
     &THEN
 
1841
      dimc = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_mb(k_
 
1842
     &range+h1b-1) * int_mb(k_range+p5b-1)
 
1843
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
1844
     & ERRQUIT('icsd_t2_2_2_2_2',0,MA_ERR)
 
1845
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
1846
      DO p6b = noab+1,noab+nvab
 
1847
      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
1848
      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
1849
     &EN
 
1850
      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
 
1851
      CALL TCE_RESTRICTED_4(h10b,h11b,p5b,p6b,h10b_2,h11b_2,p5b_2,p6b_2)
 
1852
      dim_common = int_mb(k_range+p6b-1)
 
1853
      dima_sort = int_mb(k_range+h1b-1)
 
1854
      dima = dim_common * dima_sort
 
1855
      dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_
 
1856
     &mb(k_range+p5b-1)
 
1857
      dimb = dim_common * dimb_sort
 
1858
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
1859
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
1860
     & ERRQUIT('icsd_t2_2_2_2_2',1,MA_ERR)
 
1861
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
1862
     &icsd_t2_2_2_2_2',2,MA_ERR)
 
1863
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
1864
     & int_mb(k_a_offset),(h1b_1
 
1865
     & - 1 + noab * (p6b_1 - noab - 1)))
 
1866
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
1867
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
1868
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_2_2_2',3,MA_ER
 
1869
     &R)
 
1870
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
1871
     & ERRQUIT('icsd_t2_2_2_2_2',4,MA_ERR)
 
1872
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
1873
     &icsd_t2_2_2_2_2',5,MA_ERR)
 
1874
      IF ((p6b .lt. p5b)) THEN
 
1875
      if(.not.intorb) then
 
1876
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
1877
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
1878
     &b+nvab) * (h10b_2 - 1)))))
 
1879
      else
 
1880
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
1881
     &(p5b_2
 
1882
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
1883
     &b+nvab) * (h10b_2 - 1)))),p5b_2,p6b_2,h11b_2,h10b_2)
 
1884
      end if
 
1885
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
1886
     &),int_mb(k_range+h11b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-
 
1887
     &1),4,2,1,3,-1.0d0)
 
1888
      END IF
 
1889
      IF ((p5b .le. p6b)) THEN
 
1890
      if(.not.intorb) then
 
1891
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
1892
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
1893
     &b+nvab) * (h10b_2 - 1)))))
 
1894
      else
 
1895
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
1896
     &(p6b_2
 
1897
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
1898
     &b+nvab) * (h10b_2 - 1)))),p6b_2,p5b_2,h11b_2,h10b_2)
 
1899
      end if
 
1900
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
1901
     &),int_mb(k_range+h11b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-
 
1902
     &1),3,2,1,4,1.0d0)
 
1903
      END IF
 
1904
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_2_2_2',6,MA_ER
 
1905
     &R)
 
1906
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
1907
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
1908
     &t),dima_sort)
 
1909
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_2_2_2',7,
 
1910
     &MA_ERR)
 
1911
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_2_2_2',8,
 
1912
     &MA_ERR)
 
1913
      END IF
 
1914
      END IF
 
1915
      END IF
 
1916
      END DO
 
1917
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
1918
     &icsd_t2_2_2_2_2',9,MA_ERR)
 
1919
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
1920
     &,int_mb(k_range+h11b-1),int_mb(k_range+h10b-1),int_mb(k_range+h1b-
 
1921
     &1),3,2,4,1,-1.0d0/2.0d0)
 
1922
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
1923
     & noab - 1 + nvab * (h1b - 1 + noab * (h11b - 1 + noab * (h10b - 1)
 
1924
     &))))
 
1925
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_2_2_2',10,MA_E
 
1926
     &RR)
 
1927
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_2_2_2',11
 
1928
     &,MA_ERR)
 
1929
      END IF
 
1930
      END IF
 
1931
      END IF
 
1932
c old way      next = NXTASK(nprocs, 1)
 
1933
c --- new way ----
 
1934
      call nxt_ctx_next(ctx, icounter, next)
 
1935
c ----------------
 
1936
      END IF
 
1937
      count = count + 1
 
1938
      END DO
 
1939
      END DO
 
1940
      END DO
 
1941
      END DO
 
1942
c old way      next = NXTASK(-nprocs, 1)
 
1943
c old way      call GA_SYNC()
 
1944
      RETURN
 
1945
      END
 
1946
      SUBROUTINE icsd_t2_2_2_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
 
1947
     &set,ctx,icounter)
 
1948
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
1949
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
1950
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
1951
C     i2 ( h10 h11 h1 h2 )_vt + = -1/2 * Sum ( p7 p8 ) * t ( p7 p8 h1 h2 )_t * v ( h10 h11 p7 p8 )_v
 
1952
      IMPLICIT NONE
 
1953
#include "global.fh"
 
1954
#include "mafdecls.fh"
 
1955
#include "sym.fh"
 
1956
#include "errquit.fh"
 
1957
#include "tce.fh"
 
1958
      INTEGER d_a
 
1959
      INTEGER k_a_offset
 
1960
      INTEGER d_b
 
1961
      INTEGER k_b_offset
 
1962
      INTEGER d_c
 
1963
      INTEGER k_c_offset
 
1964
c old way      INTEGER NXTASK
 
1965
c -------------------------
 
1966
      INTEGER ctx,icounter
 
1967
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
1968
c -------------------------
 
1969
      INTEGER next
 
1970
      INTEGER nprocs
 
1971
      INTEGER count
 
1972
      INTEGER h10b
 
1973
      INTEGER h11b
 
1974
      INTEGER h1b
 
1975
      INTEGER h2b
 
1976
      INTEGER dimc
 
1977
      INTEGER l_c_sort
 
1978
      INTEGER k_c_sort
 
1979
      INTEGER p7b
 
1980
      INTEGER p8b
 
1981
      INTEGER p7b_1
 
1982
      INTEGER p8b_1
 
1983
      INTEGER h1b_1
 
1984
      INTEGER h2b_1
 
1985
      INTEGER h10b_2
 
1986
      INTEGER h11b_2
 
1987
      INTEGER p7b_2
 
1988
      INTEGER p8b_2
 
1989
      INTEGER dim_common
 
1990
      INTEGER dima_sort
 
1991
      INTEGER dima
 
1992
      INTEGER dimb_sort
 
1993
      INTEGER dimb
 
1994
      INTEGER l_a_sort
 
1995
      INTEGER k_a_sort
 
1996
      INTEGER l_a
 
1997
      INTEGER k_a
 
1998
      INTEGER l_b_sort
 
1999
      INTEGER k_b_sort
 
2000
      INTEGER l_b
 
2001
      INTEGER k_b
 
2002
      INTEGER nsuperp(2)
 
2003
      INTEGER isuperp
 
2004
      INTEGER l_c
 
2005
      INTEGER k_c
 
2006
      DOUBLE PRECISION FACTORIAL
 
2007
c old way      EXTERNAL NXTASK
 
2008
      EXTERNAL FACTORIAL
 
2009
      nprocs = GA_NNODES()
 
2010
      count = 0
 
2011
c old way      next = NXTASK(nprocs, 1)
 
2012
c --- new way ----
 
2013
      call nxt_ctx_next(ctx, icounter, next)
 
2014
c ----------------
 
2015
      DO h10b = 1,noab
 
2016
      DO h11b = h10b,noab
 
2017
      DO h1b = 1,noab
 
2018
      DO h2b = h1b,noab
 
2019
      IF (next.eq.count) THEN
 
2020
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b
 
2021
     &-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
2022
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin
 
2023
     &+h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
2024
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_m
 
2025
     &b(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) 
 
2026
     &THEN
 
2027
      dimc = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) * int_mb(k_
 
2028
     &range+h1b-1) * int_mb(k_range+h2b-1)
 
2029
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
2030
     & ERRQUIT('icsd_t2_2_2_3',0,MA_ERR)
 
2031
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
2032
      DO p7b = noab+1,noab+nvab
 
2033
      DO p8b = p7b,noab+nvab
 
2034
      IF (int_mb(k_spin+p7b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
 
2035
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
2036
      IF (ieor(int_mb(k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
 
2037
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
 
2038
      CALL TCE_RESTRICTED_4(p7b,p8b,h1b,h2b,p7b_1,p8b_1,h1b_1,h2b_1)
 
2039
      CALL TCE_RESTRICTED_4(h10b,h11b,p7b,p8b,h10b_2,h11b_2,p7b_2,p8b_2)
 
2040
      dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+p8b-1)
 
2041
      dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
2042
      dima = dim_common * dima_sort
 
2043
      dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1)
 
2044
      dimb = dim_common * dimb_sort
 
2045
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
2046
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
2047
     & ERRQUIT('icsd_t2_2_2_3',1,MA_ERR)
 
2048
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
2049
     &icsd_t2_2_2_3',2,MA_ERR)
 
2050
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
2051
     & - 1 + noab * (h1b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p7b_
 
2052
     &1 - noab - 1)))))
 
2053
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
 
2054
     &,int_mb(k_range+p8b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
2055
     &,4,3,2,1,1.0d0)
 
2056
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_2_3',3,MA_ERR)
 
2057
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
2058
     & ERRQUIT('icsd_t2_2_2_3',4,MA_ERR)
 
2059
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
2060
     &icsd_t2_2_2_3',5,MA_ERR)
 
2061
      if(.not.intorb) then
 
2062
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
 
2063
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
2064
     &b+nvab) * (h10b_2 - 1)))))
 
2065
      else
 
2066
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
2067
     &(p8b_2
 
2068
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
2069
     &b+nvab) * (h10b_2 - 1)))),p8b_2,p7b_2,h11b_2,h10b_2)
 
2070
      end if
 
2071
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
2072
     &),int_mb(k_range+h11b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-
 
2073
     &1),2,1,4,3,1.0d0)
 
2074
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_2_3',6,MA_ERR)
 
2075
      nsuperp(1) = 1
 
2076
      nsuperp(2) = 1
 
2077
      isuperp = 1
 
2078
      IF (p7b .eq. p8b) THEN
 
2079
      nsuperp(isuperp) = nsuperp(isuperp) + 1
 
2080
      ELSE
 
2081
      isuperp = isuperp + 1
 
2082
      END IF
 
2083
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
 
2084
     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
 
2085
     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
 
2086
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_2_3',7,MA
 
2087
     &_ERR)
 
2088
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_2_3',8,MA
 
2089
     &_ERR)
 
2090
      END IF
 
2091
      END IF
 
2092
      END IF
 
2093
      END DO
 
2094
      END DO
 
2095
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
2096
     &icsd_t2_2_2_3',9,MA_ERR)
 
2097
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h11b-1
 
2098
     &),int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-
 
2099
     &1),2,1,4,3,-1.0d0/2.0d0)
 
2100
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
2101
     & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h10b - 1)))))
 
2102
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_2_3',10,MA_ERR
 
2103
     &)
 
2104
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_2_3',11,M
 
2105
     &A_ERR)
 
2106
      END IF
 
2107
      END IF
 
2108
      END IF
 
2109
c old way      next = NXTASK(nprocs, 1)
 
2110
c --- new way ----
 
2111
      call nxt_ctx_next(ctx, icounter, next)
 
2112
c ----------------
 
2113
      END IF
 
2114
      count = count + 1
 
2115
      END DO
 
2116
      END DO
 
2117
      END DO
 
2118
      END DO
 
2119
c old way      next = NXTASK(-nprocs, 1)
 
2120
c old way      call GA_SYNC()
 
2121
      RETURN
 
2122
      END
 
2123
      SUBROUTINE icsd_t2_2_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
2124
     &t,ctx,icounter)
 
2125
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
2126
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
2127
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
2128
C     i1 ( h10 p3 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h10 p3 h2 p5 )_v
 
2129
      IMPLICIT NONE
 
2130
#include "global.fh"
 
2131
#include "mafdecls.fh"
 
2132
#include "sym.fh"
 
2133
#include "errquit.fh"
 
2134
#include "tce.fh"
 
2135
      INTEGER d_a
 
2136
      INTEGER k_a_offset
 
2137
      INTEGER d_b
 
2138
      INTEGER k_b_offset
 
2139
      INTEGER d_c
 
2140
      INTEGER k_c_offset
 
2141
c old way      INTEGER NXTASK
 
2142
c -------------------------
 
2143
      INTEGER ctx,icounter
 
2144
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
2145
c -------------------------
 
2146
      INTEGER next
 
2147
      INTEGER nprocs
 
2148
      INTEGER count
 
2149
      INTEGER p3b
 
2150
      INTEGER h10b
 
2151
      INTEGER h1b
 
2152
      INTEGER h2b
 
2153
      INTEGER dimc
 
2154
      INTEGER l_c_sort
 
2155
      INTEGER k_c_sort
 
2156
      INTEGER p5b
 
2157
      INTEGER p5b_1
 
2158
      INTEGER h1b_1
 
2159
      INTEGER p3b_2
 
2160
      INTEGER h10b_2
 
2161
      INTEGER h2b_2
 
2162
      INTEGER p5b_2
 
2163
      INTEGER dim_common
 
2164
      INTEGER dima_sort
 
2165
      INTEGER dima
 
2166
      INTEGER dimb_sort
 
2167
      INTEGER dimb
 
2168
      INTEGER l_a_sort
 
2169
      INTEGER k_a_sort
 
2170
      INTEGER l_a
 
2171
      INTEGER k_a
 
2172
      INTEGER l_b_sort
 
2173
      INTEGER k_b_sort
 
2174
      INTEGER l_b
 
2175
      INTEGER k_b
 
2176
      INTEGER l_c
 
2177
      INTEGER k_c
 
2178
c old way      EXTERNAL NXTASK
 
2179
      nprocs = GA_NNODES()
 
2180
      count = 0
 
2181
c old way      next = NXTASK(nprocs, 1)
 
2182
c --- new way ----
 
2183
      call nxt_ctx_next(ctx, icounter, next)
 
2184
c ----------------
 
2185
      DO p3b = noab+1,noab+nvab
 
2186
      DO h10b = 1,noab
 
2187
      DO h1b = 1,noab
 
2188
      DO h2b = 1,noab
 
2189
      IF (next.eq.count) THEN
 
2190
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
 
2191
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
2192
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
2193
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
2194
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
2195
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T
 
2196
     &HEN
 
2197
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
 
2198
     &ange+h1b-1) * int_mb(k_range+h2b-1)
 
2199
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
2200
     & ERRQUIT('icsd_t2_2_3',0,MA_ERR)
 
2201
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
2202
      DO p5b = noab+1,noab+nvab
 
2203
      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
2204
      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
2205
     &EN
 
2206
      CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1)
 
2207
      CALL TCE_RESTRICTED_4(p3b,h10b,h2b,p5b,p3b_2,h10b_2,h2b_2,p5b_2)
 
2208
      dim_common = int_mb(k_range+p5b-1)
 
2209
      dima_sort = int_mb(k_range+h1b-1)
 
2210
      dima = dim_common * dima_sort
 
2211
      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_m
 
2212
     &b(k_range+h2b-1)
 
2213
      dimb = dim_common * dimb_sort
 
2214
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
2215
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
2216
     & ERRQUIT('icsd_t2_2_3',1,MA_ERR)
 
2217
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
2218
     &icsd_t2_2_3',2,MA_ERR)
 
2219
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
2220
     & int_mb(k_a_offset),(h1b_1
 
2221
     & - 1 + noab * (p5b_1 - noab - 1)))
 
2222
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
2223
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
2224
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_3',3,MA_ERR)
 
2225
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
2226
     & ERRQUIT('icsd_t2_2_3',4,MA_ERR)
 
2227
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
2228
     &icsd_t2_2_3',5,MA_ERR)
 
2229
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
2230
     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h10b_2 - 1 + noab * (p3b
 
2231
     &_2 - noab - 1)))))
 
2232
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1)
 
2233
     &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1
 
2234
     &),3,2,1,4,1.0d0)
 
2235
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_3',6,MA_ERR)
 
2236
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
2237
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
2238
     &t),dima_sort)
 
2239
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_3',7,MA_E
 
2240
     &RR)
 
2241
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_3',8,MA_E
 
2242
     &RR)
 
2243
      END IF
 
2244
      END IF
 
2245
      END IF
 
2246
      END DO
 
2247
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
2248
     &icsd_t2_2_3',9,MA_ERR)
 
2249
      IF ((h1b .le. h2b)) THEN
 
2250
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
2251
     &,int_mb(k_range+h10b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1
 
2252
     &),3,2,4,1,-1.0d0)
 
2253
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
2254
     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
 
2255
     &)))
 
2256
      END IF
 
2257
      IF ((h2b .le. h1b)) THEN
 
2258
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
2259
     &,int_mb(k_range+h10b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1
 
2260
     &),3,2,1,4,1.0d0)
 
2261
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
2262
     & 1 + noab * (h2b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
 
2263
     &)))
 
2264
      END IF
 
2265
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_3',10,MA_ERR)
 
2266
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_3',11,MA_
 
2267
     &ERR)
 
2268
      END IF
 
2269
      END IF
 
2270
      END IF
 
2271
c old way      next = NXTASK(nprocs, 1)
 
2272
c --- new way ----
 
2273
      call nxt_ctx_next(ctx, icounter, next)
 
2274
c ----------------
 
2275
      END IF
 
2276
      count = count + 1
 
2277
      END DO
 
2278
      END DO
 
2279
      END DO
 
2280
      END DO
 
2281
c old way      next = NXTASK(-nprocs, 1)
 
2282
c old way      call GA_SYNC()
 
2283
      RETURN
 
2284
      END
 
2285
      SUBROUTINE icsd_t2_2_3_1(d_a,k_a_offset,d_c,k_c_offset,
 
2286
     &ctx,icounter)
 
2287
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
2288
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
2289
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
2290
C     i2 ( h10 p3 h1 p5 )_v + = 1 * v ( h10 p3 h1 p5 )_v
 
2291
      IMPLICIT NONE
 
2292
#include "global.fh"
 
2293
#include "mafdecls.fh"
 
2294
#include "sym.fh"
 
2295
#include "errquit.fh"
 
2296
#include "tce.fh"
 
2297
      INTEGER d_a
 
2298
      INTEGER k_a_offset
 
2299
      INTEGER d_c
 
2300
      INTEGER k_c_offset
 
2301
c old way      INTEGER NXTASK
 
2302
c -------------------------
 
2303
      INTEGER ctx,icounter
 
2304
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
2305
c -------------------------
 
2306
      INTEGER next
 
2307
      INTEGER nprocs
 
2308
      INTEGER count
 
2309
      INTEGER p3b
 
2310
      INTEGER h10b
 
2311
      INTEGER h1b
 
2312
      INTEGER p5b
 
2313
      INTEGER dimc
 
2314
      INTEGER p3b_1
 
2315
      INTEGER h10b_1
 
2316
      INTEGER h1b_1
 
2317
      INTEGER p5b_1
 
2318
      INTEGER dim_common
 
2319
      INTEGER dima_sort
 
2320
      INTEGER dima
 
2321
      INTEGER l_a_sort
 
2322
      INTEGER k_a_sort
 
2323
      INTEGER l_a
 
2324
      INTEGER k_a
 
2325
      INTEGER l_c
 
2326
      INTEGER k_c
 
2327
c old way      EXTERNAL NXTASK
 
2328
      nprocs = GA_NNODES()
 
2329
      count = 0
 
2330
c old way      next = NXTASK(nprocs, 1)
 
2331
c --- new way ----
 
2332
      call nxt_ctx_next(ctx, icounter, next)
 
2333
c ----------------
 
2334
      DO p3b = noab+1,noab+nvab
 
2335
      DO h10b = 1,noab
 
2336
      DO h1b = 1,noab
 
2337
      DO p5b = noab+1,noab+nvab
 
2338
      IF (next.eq.count) THEN
 
2339
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
 
2340
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
2341
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
2342
     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
 
2343
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
2344
     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
2345
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
 
2346
     &ange+h1b-1) * int_mb(k_range+p5b-1)
 
2347
      CALL TCE_RESTRICTED_4(p3b,h10b,h1b,p5b,p3b_1,h10b_1,h1b_1,p5b_1)
 
2348
      dim_common = 1
 
2349
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_m
 
2350
     &b(k_range+h1b-1) * int_mb(k_range+p5b-1)
 
2351
      dima = dim_common * dima_sort
 
2352
      IF (dima .gt. 0) THEN
 
2353
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
2354
     & ERRQUIT('icsd_t2_2_3_1',0,MA_ERR)
 
2355
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
2356
     &icsd_t2_2_3_1',1,MA_ERR)
 
2357
      IF ((h10b .le. p3b) .and. (h1b .le. p5b)) THEN
 
2358
      if(.not.intorb) then
 
2359
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
 
2360
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
 
2361
     &+nvab) * (h10b_1 - 1)))))
 
2362
      else
 
2363
      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
 
2364
     &(p5b_1
 
2365
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
 
2366
     &+nvab) * (h10b_1 - 1)))),p5b_1,h1b_1,p3b_1,h10b_1)
 
2367
      end if
 
2368
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1
 
2369
     &),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1
 
2370
     &),4,3,1,2,1.0d0)
 
2371
      END IF
 
2372
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_3_1',2,MA_ERR)
 
2373
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
2374
     &icsd_t2_2_3_1',3,MA_ERR)
 
2375
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
2376
     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+p3b-1
 
2377
     &),4,3,2,1,1.0d0)
 
2378
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
2379
     & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noa
 
2380
     &b - 1)))))
 
2381
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_3_1',4,MA_ERR)
 
2382
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_3_1',5,MA
 
2383
     &_ERR)
 
2384
      END IF
 
2385
      END IF
 
2386
      END IF
 
2387
      END IF
 
2388
c old way      next = NXTASK(nprocs, 1)
 
2389
c --- new way ----
 
2390
      call nxt_ctx_next(ctx, icounter, next)
 
2391
c ----------------
 
2392
      END IF
 
2393
      count = count + 1
 
2394
      END DO
 
2395
      END DO
 
2396
      END DO
 
2397
      END DO
 
2398
c old way      next = NXTASK(-nprocs, 1)
 
2399
c old way      call GA_SYNC()
 
2400
      RETURN
 
2401
      END
 
2402
      SUBROUTINE OFFSET_icsd_t2_2_3_1(l_a_offset,k_a_offset,size)
 
2403
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
2404
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
2405
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
2406
C     i2 ( h10 p3 h1 p5 )_v
 
2407
      IMPLICIT NONE
 
2408
#include "global.fh"
 
2409
#include "mafdecls.fh"
 
2410
#include "sym.fh"
 
2411
#include "errquit.fh"
 
2412
#include "tce.fh"
 
2413
      INTEGER l_a_offset
 
2414
      INTEGER k_a_offset
 
2415
      INTEGER size
 
2416
      INTEGER length
 
2417
      INTEGER addr
 
2418
      INTEGER p3b
 
2419
      INTEGER h10b
 
2420
      INTEGER h1b
 
2421
      INTEGER p5b
 
2422
      length = 0
 
2423
      DO p3b = noab+1,noab+nvab
 
2424
      DO h10b = 1,noab
 
2425
      DO h1b = 1,noab
 
2426
      DO p5b = noab+1,noab+nvab
 
2427
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+
 
2428
     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
 
2429
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb
 
2430
     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
2431
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-
 
2432
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
2433
      length = length + 1
 
2434
      END IF
 
2435
      END IF
 
2436
      END IF
 
2437
      END DO
 
2438
      END DO
 
2439
      END DO
 
2440
      END DO
 
2441
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
2442
     &set)) CALL ERRQUIT('icsd_t2_2_3_1',0,MA_ERR)
 
2443
      int_mb(k_a_offset) = length
 
2444
      addr = 0
 
2445
      size = 0
 
2446
      DO p3b = noab+1,noab+nvab
 
2447
      DO h10b = 1,noab
 
2448
      DO h1b = 1,noab
 
2449
      DO p5b = noab+1,noab+nvab
 
2450
      IF (int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+
 
2451
     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
 
2452
      IF (ieor(int_mb(k_sym+h10b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb
 
2453
     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
2454
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p3b-
 
2455
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
2456
      addr = addr + 1
 
2457
      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 
 
2458
     &* (h10b - 1 + noab * (p3b - noab - 1)))
 
2459
      int_mb(k_a_offset+length+addr) = size
 
2460
      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int
 
2461
     &_mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
 
2462
      END IF
 
2463
      END IF
 
2464
      END IF
 
2465
      END DO
 
2466
      END DO
 
2467
      END DO
 
2468
      END DO
 
2469
      RETURN
 
2470
      END
 
2471
      SUBROUTINE icsd_t2_2_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
 
2472
     &set,ctx,icounter)
 
2473
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
2474
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
2475
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
2476
C     i2 ( h10 p3 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h10 p3 p5 p6 )_v
 
2477
      IMPLICIT NONE
 
2478
#include "global.fh"
 
2479
#include "mafdecls.fh"
 
2480
#include "sym.fh"
 
2481
#include "errquit.fh"
 
2482
#include "tce.fh"
 
2483
      INTEGER d_a
 
2484
      INTEGER k_a_offset
 
2485
      INTEGER d_b
 
2486
      INTEGER k_b_offset
 
2487
      INTEGER d_c
 
2488
      INTEGER k_c_offset
 
2489
c old way      INTEGER NXTASK
 
2490
c -------------------------
 
2491
      INTEGER ctx,icounter
 
2492
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
2493
c -------------------------
 
2494
      INTEGER next
 
2495
      INTEGER nprocs
 
2496
      INTEGER count
 
2497
      INTEGER p3b
 
2498
      INTEGER h10b
 
2499
      INTEGER h1b
 
2500
      INTEGER p5b
 
2501
      INTEGER dimc
 
2502
      INTEGER l_c_sort
 
2503
      INTEGER k_c_sort
 
2504
      INTEGER p6b
 
2505
      INTEGER p6b_1
 
2506
      INTEGER h1b_1
 
2507
      INTEGER p3b_2
 
2508
      INTEGER h10b_2
 
2509
      INTEGER p5b_2
 
2510
      INTEGER p6b_2
 
2511
      INTEGER dim_common
 
2512
      INTEGER dima_sort
 
2513
      INTEGER dima
 
2514
      INTEGER dimb_sort
 
2515
      INTEGER dimb
 
2516
      INTEGER l_a_sort
 
2517
      INTEGER k_a_sort
 
2518
      INTEGER l_a
 
2519
      INTEGER k_a
 
2520
      INTEGER l_b_sort
 
2521
      INTEGER k_b_sort
 
2522
      INTEGER l_b
 
2523
      INTEGER k_b
 
2524
      INTEGER l_c
 
2525
      INTEGER k_c
 
2526
c old way      EXTERNAL NXTASK
 
2527
      nprocs = GA_NNODES()
 
2528
      count = 0
 
2529
c old way      next = NXTASK(nprocs, 1)
 
2530
c --- new way ----
 
2531
      call nxt_ctx_next(ctx, icounter, next)
 
2532
c ----------------
 
2533
      DO p3b = noab+1,noab+nvab
 
2534
      DO h10b = 1,noab
 
2535
      DO h1b = 1,noab
 
2536
      DO p5b = noab+1,noab+nvab
 
2537
      IF (next.eq.count) THEN
 
2538
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
 
2539
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
2540
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
2541
     &h1b-1)+int_mb(k_spin+p5b-1)) THEN
 
2542
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
2543
     &(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) T
 
2544
     &HEN
 
2545
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
 
2546
     &ange+h1b-1) * int_mb(k_range+p5b-1)
 
2547
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
2548
     & ERRQUIT('icsd_t2_2_3_2',0,MA_ERR)
 
2549
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
2550
      DO p6b = noab+1,noab+nvab
 
2551
      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
2552
      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
2553
     &EN
 
2554
      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
 
2555
      CALL TCE_RESTRICTED_4(p3b,h10b,p5b,p6b,p3b_2,h10b_2,p5b_2,p6b_2)
 
2556
      dim_common = int_mb(k_range+p6b-1)
 
2557
      dima_sort = int_mb(k_range+h1b-1)
 
2558
      dima = dim_common * dima_sort
 
2559
      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_m
 
2560
     &b(k_range+p5b-1)
 
2561
      dimb = dim_common * dimb_sort
 
2562
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
2563
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
2564
     & ERRQUIT('icsd_t2_2_3_2',1,MA_ERR)
 
2565
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
2566
     &icsd_t2_2_3_2',2,MA_ERR)
 
2567
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
2568
     & int_mb(k_a_offset),(h1b_1
 
2569
     & - 1 + noab * (p6b_1 - noab - 1)))
 
2570
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
2571
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
2572
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_3_2',3,MA_ERR)
 
2573
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
2574
     & ERRQUIT('icsd_t2_2_3_2',4,MA_ERR)
 
2575
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
2576
     &icsd_t2_2_3_2',5,MA_ERR)
 
2577
      IF ((h10b .le. p3b) .and. (p6b .lt. p5b)) THEN
 
2578
      if(.not.intorb) then
 
2579
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
2580
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
2581
     &+nvab) * (h10b_2 - 1)))))
 
2582
      else
 
2583
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
2584
     &(p5b_2
 
2585
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
2586
     &+nvab) * (h10b_2 - 1)))),p5b_2,p6b_2,p3b_2,h10b_2)
 
2587
      end if
 
2588
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
2589
     &),int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1
 
2590
     &),4,1,2,3,-1.0d0)
 
2591
      END IF
 
2592
      IF ((h10b .le. p3b) .and. (p5b .le. p6b)) THEN
 
2593
      if(.not.intorb) then
 
2594
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
2595
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
2596
     &+nvab) * (h10b_2 - 1)))))
 
2597
      else
 
2598
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
2599
     &(p6b_2
 
2600
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
2601
     &+nvab) * (h10b_2 - 1)))),p6b_2,p5b_2,p3b_2,h10b_2)
 
2602
      end if
 
2603
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
2604
     &),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
 
2605
     &),3,1,2,4,1.0d0)
 
2606
      END IF
 
2607
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_3_2',6,MA_ERR)
 
2608
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
2609
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
2610
     &t),dima_sort)
 
2611
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_3_2',7,MA
 
2612
     &_ERR)
 
2613
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_3_2',8,MA
 
2614
     &_ERR)
 
2615
      END IF
 
2616
      END IF
 
2617
      END IF
 
2618
      END DO
 
2619
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
2620
     &icsd_t2_2_3_2',9,MA_ERR)
 
2621
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
2622
     &,int_mb(k_range+h10b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1
 
2623
     &),3,2,4,1,-1.0d0/2.0d0)
 
2624
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
2625
     & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noa
 
2626
     &b - 1)))))
 
2627
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_3_2',10,MA_ERR
 
2628
     &)
 
2629
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_3_2',11,M
 
2630
     &A_ERR)
 
2631
      END IF
 
2632
      END IF
 
2633
      END IF
 
2634
c old way      next = NXTASK(nprocs, 1)
 
2635
c --- new way ----
 
2636
      call nxt_ctx_next(ctx, icounter, next)
 
2637
c ----------------
 
2638
      END IF
 
2639
      count = count + 1
 
2640
      END DO
 
2641
      END DO
 
2642
      END DO
 
2643
      END DO
 
2644
c old way      next = NXTASK(-nprocs, 1)
 
2645
c old way      call GA_SYNC()
 
2646
      RETURN
 
2647
      END
 
2648
      SUBROUTINE icsd_t2_2_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
2649
     &t,ctx,icounter)
 
2650
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
2651
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
2652
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
2653
C     i1 ( h10 p3 h1 h2 )_ft + = -1 * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i2 ( h10 p5 )_f
 
2654
      IMPLICIT NONE
 
2655
#include "global.fh"
 
2656
#include "mafdecls.fh"
 
2657
#include "sym.fh"
 
2658
#include "errquit.fh"
 
2659
#include "tce.fh"
 
2660
      INTEGER d_a
 
2661
      INTEGER k_a_offset
 
2662
      INTEGER d_b
 
2663
      INTEGER k_b_offset
 
2664
      INTEGER d_c
 
2665
      INTEGER k_c_offset
 
2666
c old way      INTEGER NXTASK
 
2667
c -------------------------
 
2668
      INTEGER ctx,icounter
 
2669
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
2670
c -------------------------
 
2671
      INTEGER next
 
2672
      INTEGER nprocs
 
2673
      INTEGER count
 
2674
      INTEGER p3b
 
2675
      INTEGER h10b
 
2676
      INTEGER h1b
 
2677
      INTEGER h2b
 
2678
      INTEGER dimc
 
2679
      INTEGER l_c_sort
 
2680
      INTEGER k_c_sort
 
2681
      INTEGER p5b
 
2682
      INTEGER p3b_1
 
2683
      INTEGER p5b_1
 
2684
      INTEGER h1b_1
 
2685
      INTEGER h2b_1
 
2686
      INTEGER h10b_2
 
2687
      INTEGER p5b_2
 
2688
      INTEGER dim_common
 
2689
      INTEGER dima_sort
 
2690
      INTEGER dima
 
2691
      INTEGER dimb_sort
 
2692
      INTEGER dimb
 
2693
      INTEGER l_a_sort
 
2694
      INTEGER k_a_sort
 
2695
      INTEGER l_a
 
2696
      INTEGER k_a
 
2697
      INTEGER l_b_sort
 
2698
      INTEGER k_b_sort
 
2699
      INTEGER l_b
 
2700
      INTEGER k_b
 
2701
      INTEGER l_c
 
2702
      INTEGER k_c
 
2703
c old way      EXTERNAL NXTASK
 
2704
      nprocs = GA_NNODES()
 
2705
      count = 0
 
2706
c old way      next = NXTASK(nprocs, 1)
 
2707
c --- new way ----
 
2708
      call nxt_ctx_next(ctx, icounter, next)
 
2709
c ----------------
 
2710
      DO p3b = noab+1,noab+nvab
 
2711
      DO h10b = 1,noab
 
2712
      DO h1b = 1,noab
 
2713
      DO h2b = h1b,noab
 
2714
      IF (next.eq.count) THEN
 
2715
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
 
2716
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
2717
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
2718
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
2719
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
2720
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_f,irrep_t)) T
 
2721
     &HEN
 
2722
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
 
2723
     &ange+h1b-1) * int_mb(k_range+h2b-1)
 
2724
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
2725
     & ERRQUIT('icsd_t2_2_4',0,MA_ERR)
 
2726
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
2727
      DO p5b = noab+1,noab+nvab
 
2728
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
 
2729
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
2730
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
 
2731
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
 
2732
      CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h2b,p3b_1,p5b_1,h1b_1,h2b_1)
 
2733
      CALL TCE_RESTRICTED_2(h10b,p5b,h10b_2,p5b_2)
 
2734
      dim_common = int_mb(k_range+p5b-1)
 
2735
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb
 
2736
     &(k_range+h2b-1)
 
2737
      dima = dim_common * dima_sort
 
2738
      dimb_sort = int_mb(k_range+h10b-1)
 
2739
      dimb = dim_common * dimb_sort
 
2740
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
2741
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
2742
     & ERRQUIT('icsd_t2_2_4',1,MA_ERR)
 
2743
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
2744
     &icsd_t2_2_4',2,MA_ERR)
 
2745
      IF ((p5b .lt. p3b)) THEN
 
2746
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
2747
     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
 
2748
     &1 - noab - 1)))))
 
2749
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
2750
     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
2751
     &,4,3,2,1,-1.0d0)
 
2752
      END IF
 
2753
      IF ((p3b .le. p5b)) THEN
 
2754
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
2755
     & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
 
2756
     &1 - noab - 1)))))
 
2757
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
2758
     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
2759
     &,4,3,1,2,1.0d0)
 
2760
      END IF
 
2761
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_4',3,MA_ERR)
 
2762
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
2763
     & ERRQUIT('icsd_t2_2_4',4,MA_ERR)
 
2764
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
2765
     &icsd_t2_2_4',5,MA_ERR)
 
2766
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
2767
     & - noab - 1 + nvab * (h10b_2 - 1)))
 
2768
      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
2769
     &),int_mb(k_range+p5b-1),1,2,1.0d0)
 
2770
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_4',6,MA_ERR)
 
2771
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
2772
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
2773
     &t),dima_sort)
 
2774
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_4',7,MA_E
 
2775
     &RR)
 
2776
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_4',8,MA_E
 
2777
     &RR)
 
2778
      END IF
 
2779
      END IF
 
2780
      END IF
 
2781
      END DO
 
2782
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
2783
     &icsd_t2_2_4',9,MA_ERR)
 
2784
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1
 
2785
     &),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1
 
2786
     &),4,1,3,2,-1.0d0)
 
2787
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
2788
     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
 
2789
     &)))
 
2790
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_4',10,MA_ERR)
 
2791
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_4',11,MA_
 
2792
     &ERR)
 
2793
      END IF
 
2794
      END IF
 
2795
      END IF
 
2796
c old way      next = NXTASK(nprocs, 1)
 
2797
c --- new way ----
 
2798
      call nxt_ctx_next(ctx, icounter, next)
 
2799
c ----------------
 
2800
      END IF
 
2801
      count = count + 1
 
2802
      END DO
 
2803
      END DO
 
2804
      END DO
 
2805
      END DO
 
2806
c old way      next = NXTASK(-nprocs, 1)
 
2807
c old way      call GA_SYNC()
 
2808
      RETURN
 
2809
      END
 
2810
      SUBROUTINE icsd_t2_2_4_1(d_a,k_a_offset,d_c,k_c_offset,
 
2811
     &ctx,icounter)
 
2812
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
2813
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
2814
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
2815
C     i2 ( h10 p5 )_f + = 1 * f ( h10 p5 )_f
 
2816
      IMPLICIT NONE
 
2817
#include "global.fh"
 
2818
#include "mafdecls.fh"
 
2819
#include "sym.fh"
 
2820
#include "errquit.fh"
 
2821
#include "tce.fh"
 
2822
      INTEGER d_a
 
2823
      INTEGER k_a_offset
 
2824
      INTEGER d_c
 
2825
      INTEGER k_c_offset
 
2826
c old way      INTEGER NXTASK
 
2827
c -------------------------
 
2828
      INTEGER ctx,icounter
 
2829
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
2830
c -------------------------
 
2831
      INTEGER next
 
2832
      INTEGER nprocs
 
2833
      INTEGER count
 
2834
      INTEGER h10b
 
2835
      INTEGER p5b
 
2836
      INTEGER dimc
 
2837
      INTEGER h10b_1
 
2838
      INTEGER p5b_1
 
2839
      INTEGER dim_common
 
2840
      INTEGER dima_sort
 
2841
      INTEGER dima
 
2842
      INTEGER l_a_sort
 
2843
      INTEGER k_a_sort
 
2844
      INTEGER l_a
 
2845
      INTEGER k_a
 
2846
      INTEGER l_c
 
2847
      INTEGER k_c
 
2848
c old way      EXTERNAL NXTASK
 
2849
      nprocs = GA_NNODES()
 
2850
      count = 0
 
2851
c old way      next = NXTASK(nprocs, 1)
 
2852
c --- new way ----
 
2853
      call nxt_ctx_next(ctx, icounter, next)
 
2854
c ----------------
 
2855
      DO h10b = 1,noab
 
2856
      DO p5b = noab+1,noab+nvab
 
2857
      IF (next.eq.count) THEN
 
2858
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b-
 
2859
     &1).ne.4)) THEN
 
2860
      IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
2861
      IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T
 
2862
     &HEN
 
2863
      dimc = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1)
 
2864
      CALL TCE_RESTRICTED_2(h10b,p5b,h10b_1,p5b_1)
 
2865
      dim_common = 1
 
2866
      dima_sort = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1)
 
2867
      dima = dim_common * dima_sort
 
2868
      IF (dima .gt. 0) THEN
 
2869
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
2870
     & ERRQUIT('icsd_t2_2_4_1',0,MA_ERR)
 
2871
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
2872
     &icsd_t2_2_4_1',1,MA_ERR)
 
2873
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
 
2874
     & - 1 + (noab+nvab) * (h10b_1 - 1)))
 
2875
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h10b-1
 
2876
     &),int_mb(k_range+p5b-1),2,1,1.0d0)
 
2877
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_4_1',2,MA_ERR)
 
2878
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
2879
     &icsd_t2_2_4_1',3,MA_ERR)
 
2880
      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
2881
     &,int_mb(k_range+h10b-1),2,1,1.0d0)
 
2882
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
2883
     & noab - 1 + nvab * (h10b - 1)))
 
2884
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_4_1',4,MA_ERR)
 
2885
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_4_1',5,MA
 
2886
     &_ERR)
 
2887
      END IF
 
2888
      END IF
 
2889
      END IF
 
2890
      END IF
 
2891
c old way      next = NXTASK(nprocs, 1)
 
2892
c --- new way ----
 
2893
      call nxt_ctx_next(ctx, icounter, next)
 
2894
c ----------------
 
2895
      END IF
 
2896
      count = count + 1
 
2897
      END DO
 
2898
      END DO
 
2899
c old way      next = NXTASK(-nprocs, 1)
 
2900
c old way      call GA_SYNC()
 
2901
      RETURN
 
2902
      END
 
2903
      SUBROUTINE OFFSET_icsd_t2_2_4_1(l_a_offset,k_a_offset,size)
 
2904
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
2905
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
2906
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
2907
C     i2 ( h10 p5 )_f
 
2908
      IMPLICIT NONE
 
2909
#include "global.fh"
 
2910
#include "mafdecls.fh"
 
2911
#include "sym.fh"
 
2912
#include "errquit.fh"
 
2913
#include "tce.fh"
 
2914
      INTEGER l_a_offset
 
2915
      INTEGER k_a_offset
 
2916
      INTEGER size
 
2917
      INTEGER length
 
2918
      INTEGER addr
 
2919
      INTEGER h10b
 
2920
      INTEGER p5b
 
2921
      length = 0
 
2922
      DO h10b = 1,noab
 
2923
      DO p5b = noab+1,noab+nvab
 
2924
      IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
2925
      IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T
 
2926
     &HEN
 
2927
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b-
 
2928
     &1).ne.4)) THEN
 
2929
      length = length + 1
 
2930
      END IF
 
2931
      END IF
 
2932
      END IF
 
2933
      END DO
 
2934
      END DO
 
2935
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
2936
     &set)) CALL ERRQUIT('icsd_t2_2_4_1',0,MA_ERR)
 
2937
      int_mb(k_a_offset) = length
 
2938
      addr = 0
 
2939
      size = 0
 
2940
      DO h10b = 1,noab
 
2941
      DO p5b = noab+1,noab+nvab
 
2942
      IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
2943
      IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) T
 
2944
     &HEN
 
2945
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b-
 
2946
     &1).ne.4)) THEN
 
2947
      addr = addr + 1
 
2948
      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h10b - 1)
 
2949
      int_mb(k_a_offset+length+addr) = size
 
2950
      size = size + int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1)
 
2951
      END IF
 
2952
      END IF
 
2953
      END IF
 
2954
      END DO
 
2955
      END DO
 
2956
      RETURN
 
2957
      END
 
2958
      SUBROUTINE icsd_t2_2_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
 
2959
     &set,ctx,icounter)
 
2960
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
2961
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
2962
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
2963
C     i2 ( h10 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h10 p5 p6 )_v
 
2964
      IMPLICIT NONE
 
2965
#include "global.fh"
 
2966
#include "mafdecls.fh"
 
2967
#include "sym.fh"
 
2968
#include "errquit.fh"
 
2969
#include "tce.fh"
 
2970
      INTEGER d_a
 
2971
      INTEGER k_a_offset
 
2972
      INTEGER d_b
 
2973
      INTEGER k_b_offset
 
2974
      INTEGER d_c
 
2975
      INTEGER k_c_offset
 
2976
c old way      INTEGER NXTASK
 
2977
c -------------------------
 
2978
      INTEGER ctx,icounter
 
2979
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
2980
c -------------------------
 
2981
      INTEGER next
 
2982
      INTEGER nprocs
 
2983
      INTEGER count
 
2984
      INTEGER h10b
 
2985
      INTEGER p5b
 
2986
      INTEGER dimc
 
2987
      INTEGER l_c_sort
 
2988
      INTEGER k_c_sort
 
2989
      INTEGER p6b
 
2990
      INTEGER h7b
 
2991
      INTEGER p6b_1
 
2992
      INTEGER h7b_1
 
2993
      INTEGER h10b_2
 
2994
      INTEGER h7b_2
 
2995
      INTEGER p5b_2
 
2996
      INTEGER p6b_2
 
2997
      INTEGER dim_common
 
2998
      INTEGER dima_sort
 
2999
      INTEGER dima
 
3000
      INTEGER dimb_sort
 
3001
      INTEGER dimb
 
3002
      INTEGER l_a_sort
 
3003
      INTEGER k_a_sort
 
3004
      INTEGER l_a
 
3005
      INTEGER k_a
 
3006
      INTEGER l_b_sort
 
3007
      INTEGER k_b_sort
 
3008
      INTEGER l_b
 
3009
      INTEGER k_b
 
3010
      INTEGER l_c
 
3011
      INTEGER k_c
 
3012
c old way      EXTERNAL NXTASK
 
3013
      nprocs = GA_NNODES()
 
3014
      count = 0
 
3015
c old way      next = NXTASK(nprocs, 1)
 
3016
c --- new way ----
 
3017
      call nxt_ctx_next(ctx, icounter, next)
 
3018
c ----------------
 
3019
      DO h10b = 1,noab
 
3020
      DO p5b = noab+1,noab+nvab
 
3021
      IF (next.eq.count) THEN
 
3022
      IF ((.not.restricted).or.(int_mb(k_spin+h10b-1)+int_mb(k_spin+p5b-
 
3023
     &1).ne.4)) THEN
 
3024
      IF (int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
3025
      IF (ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep
 
3026
     &_v,irrep_t)) THEN
 
3027
      dimc = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1)
 
3028
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
3029
     & ERRQUIT('icsd_t2_2_4_2',0,MA_ERR)
 
3030
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
3031
      DO p6b = noab+1,noab+nvab
 
3032
      DO h7b = 1,noab
 
3033
      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN
 
3034
      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH
 
3035
     &EN
 
3036
      CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1)
 
3037
      CALL TCE_RESTRICTED_4(h10b,h7b,p5b,p6b,h10b_2,h7b_2,p5b_2,p6b_2)
 
3038
      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1)
 
3039
      dima_sort = 1
 
3040
      dima = dim_common * dima_sort
 
3041
      dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+p5b-1)
 
3042
      dimb = dim_common * dimb_sort
 
3043
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
3044
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
3045
     & ERRQUIT('icsd_t2_2_4_2',1,MA_ERR)
 
3046
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
3047
     &icsd_t2_2_4_2',2,MA_ERR)
 
3048
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
3049
     & int_mb(k_a_offset),(h7b_1
 
3050
     & - 1 + noab * (p6b_1 - noab - 1)))
 
3051
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
3052
     &,int_mb(k_range+h7b-1),2,1,1.0d0)
 
3053
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_4_2',3,MA_ERR)
 
3054
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
3055
     & ERRQUIT('icsd_t2_2_4_2',4,MA_ERR)
 
3056
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
3057
     &icsd_t2_2_4_2',5,MA_ERR)
 
3058
      IF ((h7b .le. h10b) .and. (p6b .lt. p5b)) THEN
 
3059
      if(.not.intorb) then
 
3060
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
3061
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
 
3062
     &b+nvab) * (h7b_2 - 1)))))
 
3063
      else
 
3064
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
3065
     &(p5b_2
 
3066
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
 
3067
     &b+nvab) * (h7b_2 - 1)))),p5b_2,p6b_2,h10b_2,h7b_2)
 
3068
      end if
 
3069
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
3070
     &,int_mb(k_range+h10b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1
 
3071
     &),4,2,1,3,-1.0d0)
 
3072
      END IF
 
3073
      IF ((h7b .le. h10b) .and. (p5b .le. p6b)) THEN
 
3074
      if(.not.intorb) then
 
3075
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
3076
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
 
3077
     &b+nvab) * (h7b_2 - 1)))))
 
3078
      else
 
3079
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
3080
     &(p6b_2
 
3081
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
 
3082
     &b+nvab) * (h7b_2 - 1)))),p6b_2,p5b_2,h10b_2,h7b_2)
 
3083
      end if
 
3084
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
3085
     &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
 
3086
     &),3,2,1,4,1.0d0)
 
3087
      END IF
 
3088
      IF ((h10b .lt. h7b) .and. (p6b .lt. p5b)) THEN
 
3089
      if(.not.intorb) then
 
3090
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
3091
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
 
3092
     &+nvab) * (h10b_2 - 1)))))
 
3093
      else
 
3094
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
3095
     &(p5b_2
 
3096
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
 
3097
     &+nvab) * (h10b_2 - 1)))),p5b_2,p6b_2,h7b_2,h10b_2)
 
3098
      end if
 
3099
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
3100
     &),int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1
 
3101
     &),4,1,2,3,1.0d0)
 
3102
      END IF
 
3103
      IF ((h10b .lt. h7b) .and. (p5b .le. p6b)) THEN
 
3104
      if(.not.intorb) then
 
3105
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
3106
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
 
3107
     &+nvab) * (h10b_2 - 1)))))
 
3108
      else
 
3109
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
3110
     &(p6b_2
 
3111
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
 
3112
     &+nvab) * (h10b_2 - 1)))),p6b_2,p5b_2,h7b_2,h10b_2)
 
3113
      end if
 
3114
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
3115
     &),int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
 
3116
     &),3,1,2,4,-1.0d0)
 
3117
      END IF
 
3118
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_4_2',6,MA_ERR)
 
3119
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
3120
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
3121
     &t),dima_sort)
 
3122
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_4_2',7,MA
 
3123
     &_ERR)
 
3124
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_4_2',8,MA
 
3125
     &_ERR)
 
3126
      END IF
 
3127
      END IF
 
3128
      END IF
 
3129
      END DO
 
3130
      END DO
 
3131
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
3132
     &icsd_t2_2_4_2',9,MA_ERR)
 
3133
      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
3134
     &,int_mb(k_range+h10b-1),2,1,-1.0d0)
 
3135
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
3136
     & noab - 1 + nvab * (h10b - 1)))
 
3137
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_4_2',10,MA_ERR
 
3138
     &)
 
3139
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_4_2',11,M
 
3140
     &A_ERR)
 
3141
      END IF
 
3142
      END IF
 
3143
      END IF
 
3144
c old way      next = NXTASK(nprocs, 1)
 
3145
c --- new way ----
 
3146
      call nxt_ctx_next(ctx, icounter, next)
 
3147
c ----------------
 
3148
      END IF
 
3149
      count = count + 1
 
3150
      END DO
 
3151
      END DO
 
3152
c old way      next = NXTASK(-nprocs, 1)
 
3153
c old way      call GA_SYNC()
 
3154
      RETURN
 
3155
      END
 
3156
      SUBROUTINE icsd_t2_2_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
3157
     &t,ctx,icounter)
 
3158
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
3159
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
3160
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
3161
C     i1 ( h10 p3 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( h7 p9 ) * t ( p3 p9 h1 h7 )_t * i2 ( h7 h10 h2 p9 )_v
 
3162
      IMPLICIT NONE
 
3163
#include "global.fh"
 
3164
#include "mafdecls.fh"
 
3165
#include "sym.fh"
 
3166
#include "errquit.fh"
 
3167
#include "tce.fh"
 
3168
      INTEGER d_a
 
3169
      INTEGER k_a_offset
 
3170
      INTEGER d_b
 
3171
      INTEGER k_b_offset
 
3172
      INTEGER d_c
 
3173
      INTEGER k_c_offset
 
3174
c old way      INTEGER NXTASK
 
3175
c -------------------------
 
3176
      INTEGER ctx,icounter
 
3177
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
3178
c -------------------------
 
3179
      INTEGER next
 
3180
      INTEGER nprocs
 
3181
      INTEGER count
 
3182
      INTEGER p3b
 
3183
      INTEGER h10b
 
3184
      INTEGER h1b
 
3185
      INTEGER h2b
 
3186
      INTEGER dimc
 
3187
      INTEGER l_c_sort
 
3188
      INTEGER k_c_sort
 
3189
      INTEGER p9b
 
3190
      INTEGER h7b
 
3191
      INTEGER p3b_1
 
3192
      INTEGER p9b_1
 
3193
      INTEGER h1b_1
 
3194
      INTEGER h7b_1
 
3195
      INTEGER h10b_2
 
3196
      INTEGER h7b_2
 
3197
      INTEGER h2b_2
 
3198
      INTEGER p9b_2
 
3199
      INTEGER dim_common
 
3200
      INTEGER dima_sort
 
3201
      INTEGER dima
 
3202
      INTEGER dimb_sort
 
3203
      INTEGER dimb
 
3204
      INTEGER l_a_sort
 
3205
      INTEGER k_a_sort
 
3206
      INTEGER l_a
 
3207
      INTEGER k_a
 
3208
      INTEGER l_b_sort
 
3209
      INTEGER k_b_sort
 
3210
      INTEGER l_b
 
3211
      INTEGER k_b
 
3212
      INTEGER l_c
 
3213
      INTEGER k_c
 
3214
c old way      EXTERNAL NXTASK
 
3215
      nprocs = GA_NNODES()
 
3216
      count = 0
 
3217
c old way      next = NXTASK(nprocs, 1)
 
3218
c --- new way ----
 
3219
      call nxt_ctx_next(ctx, icounter, next)
 
3220
c ----------------
 
3221
      DO p3b = noab+1,noab+nvab
 
3222
      DO h10b = 1,noab
 
3223
      DO h1b = 1,noab
 
3224
      DO h2b = 1,noab
 
3225
      IF (next.eq.count) THEN
 
3226
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
 
3227
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
3228
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
3229
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
3230
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
3231
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T
 
3232
     &HEN
 
3233
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
 
3234
     &ange+h1b-1) * int_mb(k_range+h2b-1)
 
3235
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
3236
     & ERRQUIT('icsd_t2_2_5',0,MA_ERR)
 
3237
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
3238
      DO p9b = noab+1,noab+nvab
 
3239
      DO h7b = 1,noab
 
3240
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h
 
3241
     &1b-1)+int_mb(k_spin+h7b-1)) THEN
 
3242
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p9b-1),ieor(int_mb(
 
3243
     &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_t) THEN
 
3244
      CALL TCE_RESTRICTED_4(p3b,p9b,h1b,h7b,p3b_1,p9b_1,h1b_1,h7b_1)
 
3245
      CALL TCE_RESTRICTED_4(h10b,h7b,h2b,p9b,h10b_2,h7b_2,h2b_2,p9b_2)
 
3246
      dim_common = int_mb(k_range+p9b-1) * int_mb(k_range+h7b-1)
 
3247
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
 
3248
      dima = dim_common * dima_sort
 
3249
      dimb_sort = int_mb(k_range+h10b-1) * int_mb(k_range+h2b-1)
 
3250
      dimb = dim_common * dimb_sort
 
3251
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
3252
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
3253
     & ERRQUIT('icsd_t2_2_5',1,MA_ERR)
 
3254
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
3255
     &icsd_t2_2_5',2,MA_ERR)
 
3256
      IF ((p9b .lt. p3b) .and. (h7b .lt. h1b)) THEN
 
3257
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
3258
     & - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p9b_
 
3259
     &1 - noab - 1)))))
 
3260
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1)
 
3261
     &,int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1)
 
3262
     &,4,2,3,1,1.0d0)
 
3263
      END IF
 
3264
      IF ((p9b .lt. p3b) .and. (h1b .le. h7b)) THEN
 
3265
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
 
3266
     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p9b_
 
3267
     &1 - noab - 1)))))
 
3268
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1)
 
3269
     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1)
 
3270
     &,3,2,4,1,-1.0d0)
 
3271
      END IF
 
3272
      IF ((p3b .le. p9b) .and. (h7b .lt. h1b)) THEN
 
3273
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
3274
     & - 1 + noab * (h7b_1 - 1 + noab * (p9b_1 - noab - 1 + nvab * (p3b_
 
3275
     &1 - noab - 1)))))
 
3276
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
3277
     &,int_mb(k_range+p9b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1)
 
3278
     &,4,1,3,2,-1.0d0)
 
3279
      END IF
 
3280
      IF ((p3b .le. p9b) .and. (h1b .le. h7b)) THEN
 
3281
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1
 
3282
     & - 1 + noab * (h1b_1 - 1 + noab * (p9b_1 - noab - 1 + nvab * (p3b_
 
3283
     &1 - noab - 1)))))
 
3284
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
3285
     &,int_mb(k_range+p9b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1)
 
3286
     &,3,1,4,2,1.0d0)
 
3287
      END IF
 
3288
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_5',3,MA_ERR)
 
3289
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
3290
     & ERRQUIT('icsd_t2_2_5',4,MA_ERR)
 
3291
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
3292
     &icsd_t2_2_5',5,MA_ERR)
 
3293
      IF ((h7b .le. h10b)) THEN
 
3294
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
 
3295
     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h10b_2 - 1 + noab * (h7b
 
3296
     &_2 - 1)))))
 
3297
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
3298
     &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+p9b-1
 
3299
     &),3,2,1,4,1.0d0)
 
3300
      END IF
 
3301
      IF ((h10b .lt. h7b)) THEN
 
3302
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
 
3303
     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (h10b
 
3304
     &_2 - 1)))))
 
3305
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
3306
     &),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),int_mb(k_range+p9b-1
 
3307
     &),3,1,2,4,-1.0d0)
 
3308
      END IF
 
3309
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_5',6,MA_ERR)
 
3310
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
3311
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
3312
     &t),dima_sort)
 
3313
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_5',7,MA_E
 
3314
     &RR)
 
3315
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_5',8,MA_E
 
3316
     &RR)
 
3317
      END IF
 
3318
      END IF
 
3319
      END IF
 
3320
      END DO
 
3321
      END DO
 
3322
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
3323
     &icsd_t2_2_5',9,MA_ERR)
 
3324
      IF ((h1b .le. h2b)) THEN
 
3325
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
3326
     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1
 
3327
     &),4,2,3,1,1.0d0)
 
3328
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
3329
     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
 
3330
     &)))
 
3331
      END IF
 
3332
      IF ((h2b .le. h1b)) THEN
 
3333
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
3334
     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1
 
3335
     &),4,2,1,3,-1.0d0)
 
3336
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
3337
     & 1 + noab * (h2b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
 
3338
     &)))
 
3339
      END IF
 
3340
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_5',10,MA_ERR)
 
3341
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_5',11,MA_
 
3342
     &ERR)
 
3343
      END IF
 
3344
      END IF
 
3345
      END IF
 
3346
c old way      next = NXTASK(nprocs, 1)
 
3347
c --- new way ----
 
3348
      call nxt_ctx_next(ctx, icounter, next)
 
3349
c ----------------
 
3350
      END IF
 
3351
      count = count + 1
 
3352
      END DO
 
3353
      END DO
 
3354
      END DO
 
3355
      END DO
 
3356
c old way      next = NXTASK(-nprocs, 1)
 
3357
c old way      call GA_SYNC()
 
3358
      RETURN
 
3359
      END
 
3360
      SUBROUTINE icsd_t2_2_5_1(d_a,k_a_offset,d_c,k_c_offset,
 
3361
     &ctx,icounter)
 
3362
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
3363
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
3364
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
3365
C     i2 ( h7 h10 h1 p9 )_v + = 1 * v ( h7 h10 h1 p9 )_v
 
3366
      IMPLICIT NONE
 
3367
#include "global.fh"
 
3368
#include "mafdecls.fh"
 
3369
#include "sym.fh"
 
3370
#include "errquit.fh"
 
3371
#include "tce.fh"
 
3372
      INTEGER d_a
 
3373
      INTEGER k_a_offset
 
3374
      INTEGER d_c
 
3375
      INTEGER k_c_offset
 
3376
c old way      INTEGER NXTASK
 
3377
c -------------------------
 
3378
      INTEGER ctx,icounter
 
3379
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
3380
c -------------------------
 
3381
      INTEGER next
 
3382
      INTEGER nprocs
 
3383
      INTEGER count
 
3384
      INTEGER h7b
 
3385
      INTEGER h10b
 
3386
      INTEGER h1b
 
3387
      INTEGER p9b
 
3388
      INTEGER dimc
 
3389
      INTEGER h7b_1
 
3390
      INTEGER h10b_1
 
3391
      INTEGER h1b_1
 
3392
      INTEGER p9b_1
 
3393
      INTEGER dim_common
 
3394
      INTEGER dima_sort
 
3395
      INTEGER dima
 
3396
      INTEGER l_a_sort
 
3397
      INTEGER k_a_sort
 
3398
      INTEGER l_a
 
3399
      INTEGER k_a
 
3400
      INTEGER l_c
 
3401
      INTEGER k_c
 
3402
c old way      EXTERNAL NXTASK
 
3403
      nprocs = GA_NNODES()
 
3404
      count = 0
 
3405
c old way      next = NXTASK(nprocs, 1)
 
3406
c --- new way ----
 
3407
      call nxt_ctx_next(ctx, icounter, next)
 
3408
c ----------------
 
3409
      DO h7b = 1,noab
 
3410
      DO h10b = h7b,noab
 
3411
      DO h1b = 1,noab
 
3412
      DO p9b = noab+1,noab+nvab
 
3413
      IF (next.eq.count) THEN
 
3414
      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-
 
3415
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN
 
3416
      IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
3417
     &h1b-1)+int_mb(k_spin+p9b-1)) THEN
 
3418
      IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
3419
     &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN
 
3420
      dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
 
3421
     &ange+h1b-1) * int_mb(k_range+p9b-1)
 
3422
      CALL TCE_RESTRICTED_4(h7b,h10b,h1b,p9b,h7b_1,h10b_1,h1b_1,p9b_1)
 
3423
      dim_common = 1
 
3424
      dima_sort = int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int_m
 
3425
     &b(k_range+h1b-1) * int_mb(k_range+p9b-1)
 
3426
      dima = dim_common * dima_sort
 
3427
      IF (dima .gt. 0) THEN
 
3428
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
3429
     & ERRQUIT('icsd_t2_2_5_1',0,MA_ERR)
 
3430
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
3431
     &icsd_t2_2_5_1',1,MA_ERR)
 
3432
      IF ((h1b .le. p9b)) THEN
 
3433
      if(.not.intorb) then
 
3434
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p9b_1
 
3435
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
 
3436
     &b+nvab) * (h7b_1 - 1)))))
 
3437
      else
 
3438
      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
 
3439
     &(p9b_1
 
3440
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h10b_1 - 1 + (noa
 
3441
     &b+nvab) * (h7b_1 - 1)))),p9b_1,h1b_1,h10b_1,h7b_1)
 
3442
      end if
 
3443
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1)
 
3444
     &,int_mb(k_range+h10b-1),int_mb(k_range+h1b-1),int_mb(k_range+p9b-1
 
3445
     &),4,3,2,1,1.0d0)
 
3446
      END IF
 
3447
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_5_1',2,MA_ERR)
 
3448
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
3449
     &icsd_t2_2_5_1',3,MA_ERR)
 
3450
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p9b-1)
 
3451
     &,int_mb(k_range+h1b-1),int_mb(k_range+h10b-1),int_mb(k_range+h7b-1
 
3452
     &),4,3,2,1,1.0d0)
 
3453
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b -
 
3454
     & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h7b - 1))
 
3455
     &)))
 
3456
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_5_1',4,MA_ERR)
 
3457
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_5_1',5,MA
 
3458
     &_ERR)
 
3459
      END IF
 
3460
      END IF
 
3461
      END IF
 
3462
      END IF
 
3463
c old way      next = NXTASK(nprocs, 1)
 
3464
c --- new way ----
 
3465
      call nxt_ctx_next(ctx, icounter, next)
 
3466
c ----------------
 
3467
      END IF
 
3468
      count = count + 1
 
3469
      END DO
 
3470
      END DO
 
3471
      END DO
 
3472
      END DO
 
3473
c old way      next = NXTASK(-nprocs, 1)
 
3474
c old way      call GA_SYNC()
 
3475
      RETURN
 
3476
      END
 
3477
      SUBROUTINE OFFSET_icsd_t2_2_5_1(l_a_offset,k_a_offset,size)
 
3478
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
3479
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
3480
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
3481
C     i2 ( h7 h10 h1 p9 )_v
 
3482
      IMPLICIT NONE
 
3483
#include "global.fh"
 
3484
#include "mafdecls.fh"
 
3485
#include "sym.fh"
 
3486
#include "errquit.fh"
 
3487
#include "tce.fh"
 
3488
      INTEGER l_a_offset
 
3489
      INTEGER k_a_offset
 
3490
      INTEGER size
 
3491
      INTEGER length
 
3492
      INTEGER addr
 
3493
      INTEGER h7b
 
3494
      INTEGER h10b
 
3495
      INTEGER h1b
 
3496
      INTEGER p9b
 
3497
      length = 0
 
3498
      DO h7b = 1,noab
 
3499
      DO h10b = h7b,noab
 
3500
      DO h1b = 1,noab
 
3501
      DO p9b = noab+1,noab+nvab
 
3502
      IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
3503
     &h1b-1)+int_mb(k_spin+p9b-1)) THEN
 
3504
      IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
3505
     &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN
 
3506
      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-
 
3507
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN
 
3508
      length = length + 1
 
3509
      END IF
 
3510
      END IF
 
3511
      END IF
 
3512
      END DO
 
3513
      END DO
 
3514
      END DO
 
3515
      END DO
 
3516
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
3517
     &set)) CALL ERRQUIT('icsd_t2_2_5_1',0,MA_ERR)
 
3518
      int_mb(k_a_offset) = length
 
3519
      addr = 0
 
3520
      size = 0
 
3521
      DO h7b = 1,noab
 
3522
      DO h10b = h7b,noab
 
3523
      DO h1b = 1,noab
 
3524
      DO p9b = noab+1,noab+nvab
 
3525
      IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
3526
     &h1b-1)+int_mb(k_spin+p9b-1)) THEN
 
3527
      IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
3528
     &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. irrep_v) THEN
 
3529
      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-
 
3530
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN
 
3531
      addr = addr + 1
 
3532
      int_mb(k_a_offset+addr) = p9b - noab - 1 + nvab * (h1b - 1 + noab 
 
3533
     &* (h10b - 1 + noab * (h7b - 1)))
 
3534
      int_mb(k_a_offset+length+addr) = size
 
3535
      size = size + int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int
 
3536
     &_mb(k_range+h1b-1) * int_mb(k_range+p9b-1)
 
3537
      END IF
 
3538
      END IF
 
3539
      END IF
 
3540
      END DO
 
3541
      END DO
 
3542
      END DO
 
3543
      END DO
 
3544
      RETURN
 
3545
      END
 
3546
      SUBROUTINE icsd_t2_2_5_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
 
3547
     &set,ctx,icounter)
 
3548
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
3549
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
3550
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
3551
C     i2 ( h7 h10 h1 p9 )_vt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * v ( h7 h10 p5 p9 )_v
 
3552
      IMPLICIT NONE
 
3553
#include "global.fh"
 
3554
#include "mafdecls.fh"
 
3555
#include "sym.fh"
 
3556
#include "errquit.fh"
 
3557
#include "tce.fh"
 
3558
      INTEGER d_a
 
3559
      INTEGER k_a_offset
 
3560
      INTEGER d_b
 
3561
      INTEGER k_b_offset
 
3562
      INTEGER d_c
 
3563
      INTEGER k_c_offset
 
3564
c old way      INTEGER NXTASK
 
3565
c -------------------------
 
3566
      INTEGER ctx,icounter
 
3567
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
3568
c -------------------------
 
3569
      INTEGER next
 
3570
      INTEGER nprocs
 
3571
      INTEGER count
 
3572
      INTEGER h7b
 
3573
      INTEGER h10b
 
3574
      INTEGER h1b
 
3575
      INTEGER p9b
 
3576
      INTEGER dimc
 
3577
      INTEGER l_c_sort
 
3578
      INTEGER k_c_sort
 
3579
      INTEGER p5b
 
3580
      INTEGER p5b_1
 
3581
      INTEGER h1b_1
 
3582
      INTEGER h7b_2
 
3583
      INTEGER h10b_2
 
3584
      INTEGER p9b_2
 
3585
      INTEGER p5b_2
 
3586
      INTEGER dim_common
 
3587
      INTEGER dima_sort
 
3588
      INTEGER dima
 
3589
      INTEGER dimb_sort
 
3590
      INTEGER dimb
 
3591
      INTEGER l_a_sort
 
3592
      INTEGER k_a_sort
 
3593
      INTEGER l_a
 
3594
      INTEGER k_a
 
3595
      INTEGER l_b_sort
 
3596
      INTEGER k_b_sort
 
3597
      INTEGER l_b
 
3598
      INTEGER k_b
 
3599
      INTEGER l_c
 
3600
      INTEGER k_c
 
3601
c old way      EXTERNAL NXTASK
 
3602
      nprocs = GA_NNODES()
 
3603
      count = 0
 
3604
c old way      next = NXTASK(nprocs, 1)
 
3605
c --- new way ----
 
3606
      call nxt_ctx_next(ctx, icounter, next)
 
3607
c ----------------
 
3608
      DO h7b = 1,noab
 
3609
      DO h10b = h7b,noab
 
3610
      DO h1b = 1,noab
 
3611
      DO p9b = noab+1,noab+nvab
 
3612
      IF (next.eq.count) THEN
 
3613
      IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-
 
3614
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN
 
3615
      IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
3616
     &h1b-1)+int_mb(k_spin+p9b-1)) THEN
 
3617
      IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
3618
     &(k_sym+h1b-1),int_mb(k_sym+p9b-1)))) .eq. ieor(irrep_v,irrep_t)) T
 
3619
     &HEN
 
3620
      dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
 
3621
     &ange+h1b-1) * int_mb(k_range+p9b-1)
 
3622
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
3623
     & ERRQUIT('icsd_t2_2_5_2',0,MA_ERR)
 
3624
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
3625
      DO p5b = noab+1,noab+nvab
 
3626
      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
3627
      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
3628
     &EN
 
3629
      CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1)
 
3630
      CALL TCE_RESTRICTED_4(h7b,h10b,p9b,p5b,h7b_2,h10b_2,p9b_2,p5b_2)
 
3631
      dim_common = int_mb(k_range+p5b-1)
 
3632
      dima_sort = int_mb(k_range+h1b-1)
 
3633
      dima = dim_common * dima_sort
 
3634
      dimb_sort = int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int_m
 
3635
     &b(k_range+p9b-1)
 
3636
      dimb = dim_common * dimb_sort
 
3637
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
3638
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
3639
     & ERRQUIT('icsd_t2_2_5_2',1,MA_ERR)
 
3640
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
3641
     &icsd_t2_2_5_2',2,MA_ERR)
 
3642
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
3643
     & int_mb(k_a_offset),(h1b_1
 
3644
     & - 1 + noab * (p5b_1 - noab - 1)))
 
3645
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
3646
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
3647
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_5_2',3,MA_ERR)
 
3648
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
3649
     & ERRQUIT('icsd_t2_2_5_2',4,MA_ERR)
 
3650
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
3651
     &icsd_t2_2_5_2',5,MA_ERR)
 
3652
      IF ((p5b .le. p9b)) THEN
 
3653
      if(.not.intorb) then
 
3654
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2
 
3655
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
 
3656
     &b+nvab) * (h7b_2 - 1)))))
 
3657
      else
 
3658
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
3659
     &(p9b_2
 
3660
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
 
3661
     &b+nvab) * (h7b_2 - 1)))),p9b_2,p5b_2,h10b_2,h7b_2)
 
3662
      end if
 
3663
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
3664
     &,int_mb(k_range+h10b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1
 
3665
     &),4,2,1,3,1.0d0)
 
3666
      END IF
 
3667
      IF ((p9b .lt. p5b)) THEN
 
3668
      if(.not.intorb) then
 
3669
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
3670
     & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
 
3671
     &b+nvab) * (h7b_2 - 1)))))
 
3672
      else
 
3673
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
3674
     &(p5b_2
 
3675
     & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa
 
3676
     &b+nvab) * (h7b_2 - 1)))),p5b_2,p9b_2,h10b_2,h7b_2)
 
3677
      end if
 
3678
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
3679
     &,int_mb(k_range+h10b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1
 
3680
     &),3,2,1,4,-1.0d0)
 
3681
      END IF
 
3682
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_5_2',6,MA_ERR)
 
3683
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
3684
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
3685
     &t),dima_sort)
 
3686
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_5_2',7,MA
 
3687
     &_ERR)
 
3688
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_5_2',8,MA
 
3689
     &_ERR)
 
3690
      END IF
 
3691
      END IF
 
3692
      END IF
 
3693
      END DO
 
3694
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
3695
     &icsd_t2_2_5_2',9,MA_ERR)
 
3696
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p9b-1)
 
3697
     &,int_mb(k_range+h10b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1
 
3698
     &),3,2,4,1,1.0d0)
 
3699
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b -
 
3700
     & noab - 1 + nvab * (h1b - 1 + noab * (h10b - 1 + noab * (h7b - 1))
 
3701
     &)))
 
3702
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_5_2',10,MA_ERR
 
3703
     &)
 
3704
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_5_2',11,M
 
3705
     &A_ERR)
 
3706
      END IF
 
3707
      END IF
 
3708
      END IF
 
3709
c old way      next = NXTASK(nprocs, 1)
 
3710
c --- new way ----
 
3711
      call nxt_ctx_next(ctx, icounter, next)
 
3712
c ----------------
 
3713
      END IF
 
3714
      count = count + 1
 
3715
      END DO
 
3716
      END DO
 
3717
      END DO
 
3718
      END DO
 
3719
c old way      next = NXTASK(-nprocs, 1)
 
3720
c old way      call GA_SYNC()
 
3721
      RETURN
 
3722
      END
 
3723
      SUBROUTINE icsd_t2_2_6(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
3724
     &t,ctx,icounter)
 
3725
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
3726
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
3727
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
3728
C     i1 ( h10 p3 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h10 p3 p5 p6 )_v
 
3729
      IMPLICIT NONE
 
3730
#include "global.fh"
 
3731
#include "mafdecls.fh"
 
3732
#include "sym.fh"
 
3733
#include "errquit.fh"
 
3734
#include "tce.fh"
 
3735
      INTEGER d_a
 
3736
      INTEGER k_a_offset
 
3737
      INTEGER d_b
 
3738
      INTEGER k_b_offset
 
3739
      INTEGER d_c
 
3740
      INTEGER k_c_offset
 
3741
c old way      INTEGER NXTASK
 
3742
c -------------------------
 
3743
      INTEGER ctx,icounter
 
3744
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
3745
c -------------------------
 
3746
      INTEGER next
 
3747
      INTEGER nprocs
 
3748
      INTEGER count
 
3749
      INTEGER p3b
 
3750
      INTEGER h10b
 
3751
      INTEGER h1b
 
3752
      INTEGER h2b
 
3753
      INTEGER dimc
 
3754
      INTEGER l_c_sort
 
3755
      INTEGER k_c_sort
 
3756
      INTEGER p5b
 
3757
      INTEGER p6b
 
3758
      INTEGER p5b_1
 
3759
      INTEGER p6b_1
 
3760
      INTEGER h1b_1
 
3761
      INTEGER h2b_1
 
3762
      INTEGER p3b_2
 
3763
      INTEGER h10b_2
 
3764
      INTEGER p5b_2
 
3765
      INTEGER p6b_2
 
3766
      INTEGER dim_common
 
3767
      INTEGER dima_sort
 
3768
      INTEGER dima
 
3769
      INTEGER dimb_sort
 
3770
      INTEGER dimb
 
3771
      INTEGER l_a_sort
 
3772
      INTEGER k_a_sort
 
3773
      INTEGER l_a
 
3774
      INTEGER k_a
 
3775
      INTEGER l_b_sort
 
3776
      INTEGER k_b_sort
 
3777
      INTEGER l_b
 
3778
      INTEGER k_b
 
3779
      INTEGER nsuperp(2)
 
3780
      INTEGER isuperp
 
3781
      INTEGER l_c
 
3782
      INTEGER k_c
 
3783
      DOUBLE PRECISION FACTORIAL
 
3784
c old way      EXTERNAL NXTASK
 
3785
      EXTERNAL FACTORIAL
 
3786
      nprocs = GA_NNODES()
 
3787
      count = 0
 
3788
c old way      next = NXTASK(nprocs, 1)
 
3789
c --- new way ----
 
3790
      call nxt_ctx_next(ctx, icounter, next)
 
3791
c ----------------
 
3792
      DO p3b = noab+1,noab+nvab
 
3793
      DO h10b = 1,noab
 
3794
      DO h1b = 1,noab
 
3795
      DO h2b = h1b,noab
 
3796
      IF (next.eq.count) THEN
 
3797
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-
 
3798
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
3799
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+
 
3800
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
3801
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb
 
3802
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T
 
3803
     &HEN
 
3804
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1) * int_mb(k_r
 
3805
     &ange+h1b-1) * int_mb(k_range+h2b-1)
 
3806
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
3807
     & ERRQUIT('icsd_t2_2_6',0,MA_ERR)
 
3808
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
3809
      DO p5b = noab+1,noab+nvab
 
3810
      DO p6b = p5b,noab+nvab
 
3811
      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h
 
3812
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
3813
      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb(
 
3814
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
 
3815
      CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1)
 
3816
      CALL TCE_RESTRICTED_4(p3b,h10b,p5b,p6b,p3b_2,h10b_2,p5b_2,p6b_2)
 
3817
      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1)
 
3818
      dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
3819
      dima = dim_common * dima_sort
 
3820
      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h10b-1)
 
3821
      dimb = dim_common * dimb_sort
 
3822
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
3823
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
3824
     & ERRQUIT('icsd_t2_2_6',1,MA_ERR)
 
3825
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
3826
     &icsd_t2_2_6',2,MA_ERR)
 
3827
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
3828
     & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_
 
3829
     &1 - noab - 1)))))
 
3830
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
3831
     &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
3832
     &,4,3,2,1,1.0d0)
 
3833
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_2_6',3,MA_ERR)
 
3834
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
3835
     & ERRQUIT('icsd_t2_2_6',4,MA_ERR)
 
3836
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
3837
     &icsd_t2_2_6',5,MA_ERR)
 
3838
      IF ((h10b .le. p3b)) THEN
 
3839
      if(.not.intorb) then
 
3840
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
3841
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
3842
     &+nvab) * (h10b_2 - 1)))))
 
3843
      else
 
3844
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
3845
     &(p6b_2
 
3846
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
3847
     &+nvab) * (h10b_2 - 1)))),p6b_2,p5b_2,p3b_2,h10b_2)
 
3848
      end if
 
3849
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1
 
3850
     &),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
 
3851
     &),1,2,4,3,1.0d0)
 
3852
      END IF
 
3853
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_2_6',6,MA_ERR)
 
3854
      nsuperp(1) = 1
 
3855
      nsuperp(2) = 1
 
3856
      isuperp = 1
 
3857
      IF (p5b .eq. p6b) THEN
 
3858
      nsuperp(isuperp) = nsuperp(isuperp) + 1
 
3859
      ELSE
 
3860
      isuperp = isuperp + 1
 
3861
      END IF
 
3862
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
 
3863
     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
 
3864
     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
 
3865
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_2_6',7,MA_E
 
3866
     &RR)
 
3867
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_2_6',8,MA_E
 
3868
     &RR)
 
3869
      END IF
 
3870
      END IF
 
3871
      END IF
 
3872
      END DO
 
3873
      END DO
 
3874
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
3875
     &icsd_t2_2_6',9,MA_ERR)
 
3876
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h10b-1
 
3877
     &),int_mb(k_range+p3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1
 
3878
     &),2,1,4,3,1.0d0/2.0d0)
 
3879
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
3880
     & 1 + noab * (h1b - 1 + noab * (h10b - 1 + noab * (p3b - noab - 1))
 
3881
     &)))
 
3882
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_2_6',10,MA_ERR)
 
3883
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_2_6',11,MA_
 
3884
     &ERR)
 
3885
      END IF
 
3886
      END IF
 
3887
      END IF
 
3888
c old way      next = NXTASK(nprocs, 1)
 
3889
c --- new way ----
 
3890
      call nxt_ctx_next(ctx, icounter, next)
 
3891
c ----------------
 
3892
      END IF
 
3893
      count = count + 1
 
3894
      END DO
 
3895
      END DO
 
3896
      END DO
 
3897
      END DO
 
3898
c old way      next = NXTASK(-nprocs, 1)
 
3899
c old way      call GA_SYNC()
 
3900
      RETURN
 
3901
      END
 
3902
      SUBROUTINE icsd_t2_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset,
 
3903
     &ctx,icounter)
 
3904
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
3905
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
3906
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
3907
C     i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i1 ( p3 p4 h2 p5 )_v
 
3908
      IMPLICIT NONE
 
3909
#include "global.fh"
 
3910
#include "mafdecls.fh"
 
3911
#include "sym.fh"
 
3912
#include "errquit.fh"
 
3913
#include "tce.fh"
 
3914
      INTEGER d_a
 
3915
      INTEGER k_a_offset
 
3916
      INTEGER d_b
 
3917
      INTEGER k_b_offset
 
3918
      INTEGER d_c
 
3919
      INTEGER k_c_offset
 
3920
c old way      INTEGER NXTASK
 
3921
c -------------------------
 
3922
      INTEGER ctx,icounter
 
3923
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
3924
c -------------------------
 
3925
      INTEGER next
 
3926
      INTEGER nprocs
 
3927
      INTEGER count
 
3928
      INTEGER p3b
 
3929
      INTEGER p4b
 
3930
      INTEGER h1b
 
3931
      INTEGER h2b
 
3932
      INTEGER dimc
 
3933
      INTEGER l_c_sort
 
3934
      INTEGER k_c_sort
 
3935
      INTEGER p5b
 
3936
      INTEGER p5b_1
 
3937
      INTEGER h1b_1
 
3938
      INTEGER p3b_2
 
3939
      INTEGER p4b_2
 
3940
      INTEGER h2b_2
 
3941
      INTEGER p5b_2
 
3942
      INTEGER dim_common
 
3943
      INTEGER dima_sort
 
3944
      INTEGER dima
 
3945
      INTEGER dimb_sort
 
3946
      INTEGER dimb
 
3947
      INTEGER l_a_sort
 
3948
      INTEGER k_a_sort
 
3949
      INTEGER l_a
 
3950
      INTEGER k_a
 
3951
      INTEGER l_b_sort
 
3952
      INTEGER k_b_sort
 
3953
      INTEGER l_b
 
3954
      INTEGER k_b
 
3955
      INTEGER l_c
 
3956
      INTEGER k_c
 
3957
c old way      EXTERNAL NXTASK
 
3958
      nprocs = GA_NNODES()
 
3959
      count = 0
 
3960
c old way      next = NXTASK(nprocs, 1)
 
3961
c --- new way ----
 
3962
      call nxt_ctx_next(ctx, icounter, next)
 
3963
c ----------------
 
3964
      DO p3b = noab+1,noab+nvab
 
3965
      DO p4b = p3b,noab+nvab
 
3966
      DO h1b = 1,noab
 
3967
      DO h2b = 1,noab
 
3968
      IF (next.eq.count) THEN
 
3969
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
3970
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
3971
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
3972
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
3973
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
3974
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
3975
     &EN
 
3976
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
3977
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
3978
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
3979
     & ERRQUIT('icsd_t2_3',0,MA_ERR)
 
3980
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
3981
      DO p5b = noab+1,noab+nvab
 
3982
      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
3983
      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
3984
     &EN
 
3985
      CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1)
 
3986
      CALL TCE_RESTRICTED_4(p3b,p4b,h2b,p5b,p3b_2,p4b_2,h2b_2,p5b_2)
 
3987
      dim_common = int_mb(k_range+p5b-1)
 
3988
      dima_sort = int_mb(k_range+h1b-1)
 
3989
      dima = dim_common * dima_sort
 
3990
      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb
 
3991
     &(k_range+h2b-1)
 
3992
      dimb = dim_common * dimb_sort
 
3993
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
3994
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
3995
     & ERRQUIT('icsd_t2_3',1,MA_ERR)
 
3996
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
3997
     &icsd_t2_3',2,MA_ERR)
 
3998
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
3999
     & int_mb(k_a_offset),(h1b_1
 
4000
     & - 1 + noab * (p5b_1 - noab - 1)))
 
4001
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
4002
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
4003
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_3',3,MA_ERR)
 
4004
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
4005
     & ERRQUIT('icsd_t2_3',4,MA_ERR)
 
4006
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
4007
     &icsd_t2_3',5,MA_ERR)
 
4008
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
4009
     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (p4b_2 - noab - 1 + nvab 
 
4010
     &* (p3b_2 - noab - 1)))))
 
4011
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1)
 
4012
     &,int_mb(k_range+p4b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1)
 
4013
     &,3,2,1,4,1.0d0)
 
4014
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_3',6,MA_ERR)
 
4015
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
4016
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
4017
     &t),dima_sort)
 
4018
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_3',7,MA_ERR
 
4019
     &)
 
4020
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_3',8,MA_ERR
 
4021
     &)
 
4022
      END IF
 
4023
      END IF
 
4024
      END IF
 
4025
      END DO
 
4026
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
4027
     &icsd_t2_3',9,MA_ERR)
 
4028
      IF ((h1b .le. h2b)) THEN
 
4029
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
4030
     &,int_mb(k_range+p4b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
 
4031
     &,3,2,4,1,-1.0d0)
 
4032
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
4033
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
4034
     & - 1)))))
 
4035
      END IF
 
4036
      IF ((h2b .le. h1b)) THEN
 
4037
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
4038
     &,int_mb(k_range+p4b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
 
4039
     &,3,2,1,4,1.0d0)
 
4040
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
4041
     & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
4042
     & - 1)))))
 
4043
      END IF
 
4044
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_3',10,MA_ERR)
 
4045
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_3',11,MA_ER
 
4046
     &R)
 
4047
      END IF
 
4048
      END IF
 
4049
      END IF
 
4050
c old way      next = NXTASK(nprocs, 1)
 
4051
c --- new way ----
 
4052
      call nxt_ctx_next(ctx, icounter, next)
 
4053
c ----------------
 
4054
      END IF
 
4055
      count = count + 1
 
4056
      END DO
 
4057
      END DO
 
4058
      END DO
 
4059
      END DO
 
4060
c old way      next = NXTASK(-nprocs, 1)
 
4061
c old way      call GA_SYNC()
 
4062
      RETURN
 
4063
      END
 
4064
      SUBROUTINE icsd_t2_3_1(d_a,k_a_offset,d_c,k_c_offset,ctx,icounter)
 
4065
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
4066
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
4067
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
4068
C     i1 ( p3 p4 h1 p5 )_v + = 1 * v ( p3 p4 h1 p5 )_v
 
4069
      IMPLICIT NONE
 
4070
#include "global.fh"
 
4071
#include "mafdecls.fh"
 
4072
#include "sym.fh"
 
4073
#include "errquit.fh"
 
4074
#include "tce.fh"
 
4075
      INTEGER d_a
 
4076
      INTEGER k_a_offset
 
4077
      INTEGER d_c
 
4078
      INTEGER k_c_offset
 
4079
c old way      INTEGER NXTASK
 
4080
c -------------------------
 
4081
      INTEGER ctx,icounter
 
4082
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
4083
c -------------------------
 
4084
      INTEGER next
 
4085
      INTEGER nprocs
 
4086
      INTEGER count
 
4087
      INTEGER p3b
 
4088
      INTEGER p4b
 
4089
      INTEGER h1b
 
4090
      INTEGER p5b
 
4091
      INTEGER dimc
 
4092
      INTEGER p3b_1
 
4093
      INTEGER p4b_1
 
4094
      INTEGER h1b_1
 
4095
      INTEGER p5b_1
 
4096
      INTEGER dim_common
 
4097
      INTEGER dima_sort
 
4098
      INTEGER dima
 
4099
      INTEGER l_a_sort
 
4100
      INTEGER k_a_sort
 
4101
      INTEGER l_a
 
4102
      INTEGER k_a
 
4103
      INTEGER l_c
 
4104
      INTEGER k_c
 
4105
c old way      EXTERNAL NXTASK
 
4106
      nprocs = GA_NNODES()
 
4107
      count = 0
 
4108
c old way      next = NXTASK(nprocs, 1)
 
4109
c --- new way ----
 
4110
      call nxt_ctx_next(ctx, icounter, next)
 
4111
c ----------------
 
4112
      DO p3b = noab+1,noab+nvab
 
4113
      DO p4b = p3b,noab+nvab
 
4114
      DO h1b = 1,noab
 
4115
      DO p5b = noab+1,noab+nvab
 
4116
      IF (next.eq.count) THEN
 
4117
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
4118
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
4119
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
4120
     &1b-1)+int_mb(k_spin+p5b-1)) THEN
 
4121
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
4122
     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
4123
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
4124
     &nge+h1b-1) * int_mb(k_range+p5b-1)
 
4125
      CALL TCE_RESTRICTED_4(p3b,p4b,h1b,p5b,p3b_1,p4b_1,h1b_1,p5b_1)
 
4126
      dim_common = 1
 
4127
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb
 
4128
     &(k_range+h1b-1) * int_mb(k_range+p5b-1)
 
4129
      dima = dim_common * dima_sort
 
4130
      IF (dima .gt. 0) THEN
 
4131
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
4132
     & ERRQUIT('icsd_t2_3_1',0,MA_ERR)
 
4133
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
4134
     &icsd_t2_3_1',1,MA_ERR)
 
4135
      IF ((h1b .le. p5b)) THEN
 
4136
      if(.not.intorb) then
 
4137
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
 
4138
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p4b_1 - 1 + (noab
 
4139
     &+nvab) * (p3b_1 - 1)))))
 
4140
      else
 
4141
      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
 
4142
     &(p5b_1
 
4143
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p4b_1 - 1 + (noab
 
4144
     &+nvab) * (p3b_1 - 1)))),p5b_1,h1b_1,p4b_1,p3b_1)
 
4145
      end if
 
4146
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
4147
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1)
 
4148
     &,4,3,2,1,1.0d0)
 
4149
      END IF
 
4150
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_3_1',2,MA_ERR)
 
4151
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
4152
     &icsd_t2_3_1',3,MA_ERR)
 
4153
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
4154
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
4155
     &,4,3,2,1,1.0d0)
 
4156
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
4157
     & noab - 1 + nvab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b
 
4158
     & - noab - 1)))))
 
4159
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_3_1',4,MA_ERR)
 
4160
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_3_1',5,MA_E
 
4161
     &RR)
 
4162
      END IF
 
4163
      END IF
 
4164
      END IF
 
4165
      END IF
 
4166
c old way      next = NXTASK(nprocs, 1)
 
4167
c --- new way ----
 
4168
      call nxt_ctx_next(ctx, icounter, next)
 
4169
c ----------------
 
4170
      END IF
 
4171
      count = count + 1
 
4172
      END DO
 
4173
      END DO
 
4174
      END DO
 
4175
      END DO
 
4176
c old way      next = NXTASK(-nprocs, 1)
 
4177
c old way      call GA_SYNC()
 
4178
      RETURN
 
4179
      END
 
4180
      SUBROUTINE OFFSET_icsd_t2_3_1(l_a_offset,k_a_offset,size)
 
4181
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
4182
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
4183
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
4184
C     i1 ( p3 p4 h1 p5 )_v
 
4185
      IMPLICIT NONE
 
4186
#include "global.fh"
 
4187
#include "mafdecls.fh"
 
4188
#include "sym.fh"
 
4189
#include "errquit.fh"
 
4190
#include "tce.fh"
 
4191
      INTEGER l_a_offset
 
4192
      INTEGER k_a_offset
 
4193
      INTEGER size
 
4194
      INTEGER length
 
4195
      INTEGER addr
 
4196
      INTEGER p3b
 
4197
      INTEGER p4b
 
4198
      INTEGER h1b
 
4199
      INTEGER p5b
 
4200
      length = 0
 
4201
      DO p3b = noab+1,noab+nvab
 
4202
      DO p4b = p3b,noab+nvab
 
4203
      DO h1b = 1,noab
 
4204
      DO p5b = noab+1,noab+nvab
 
4205
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
4206
     &1b-1)+int_mb(k_spin+p5b-1)) THEN
 
4207
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
4208
     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
4209
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
4210
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
4211
      length = length + 1
 
4212
      END IF
 
4213
      END IF
 
4214
      END IF
 
4215
      END DO
 
4216
      END DO
 
4217
      END DO
 
4218
      END DO
 
4219
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
4220
     &set)) CALL ERRQUIT('icsd_t2_3_1',0,MA_ERR)
 
4221
      int_mb(k_a_offset) = length
 
4222
      addr = 0
 
4223
      size = 0
 
4224
      DO p3b = noab+1,noab+nvab
 
4225
      DO p4b = p3b,noab+nvab
 
4226
      DO h1b = 1,noab
 
4227
      DO p5b = noab+1,noab+nvab
 
4228
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
4229
     &1b-1)+int_mb(k_spin+p5b-1)) THEN
 
4230
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
4231
     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
4232
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
4233
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
4234
      addr = addr + 1
 
4235
      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 
 
4236
     &* (p4b - noab - 1 + nvab * (p3b - noab - 1)))
 
4237
      int_mb(k_a_offset+length+addr) = size
 
4238
      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_
 
4239
     &mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
 
4240
      END IF
 
4241
      END IF
 
4242
      END IF
 
4243
      END DO
 
4244
      END DO
 
4245
      END DO
 
4246
      END DO
 
4247
      RETURN
 
4248
      END
 
4249
      SUBROUTINE icsd_t2_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
4250
     &t,ctx,icounter)
 
4251
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
4252
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
4253
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
4254
C     i1 ( p3 p4 h1 p5 )_vt + = -1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( p3 p4 p5 p6 )_v
 
4255
      IMPLICIT NONE
 
4256
#include "global.fh"
 
4257
#include "mafdecls.fh"
 
4258
#include "sym.fh"
 
4259
#include "errquit.fh"
 
4260
#include "tce.fh"
 
4261
      INTEGER d_a
 
4262
      INTEGER k_a_offset
 
4263
      INTEGER d_b
 
4264
      INTEGER k_b_offset
 
4265
      INTEGER d_c
 
4266
      INTEGER k_c_offset
 
4267
c old way      INTEGER NXTASK
 
4268
c -------------------------
 
4269
      INTEGER ctx,icounter
 
4270
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
4271
c -------------------------
 
4272
      INTEGER next
 
4273
      INTEGER nprocs
 
4274
      INTEGER count
 
4275
      INTEGER p3b
 
4276
      INTEGER p4b
 
4277
      INTEGER h1b
 
4278
      INTEGER p5b
 
4279
      INTEGER dimc
 
4280
      INTEGER l_c_sort
 
4281
      INTEGER k_c_sort
 
4282
      INTEGER p6b
 
4283
      INTEGER p6b_1
 
4284
      INTEGER h1b_1
 
4285
      INTEGER p3b_2
 
4286
      INTEGER p4b_2
 
4287
      INTEGER p5b_2
 
4288
      INTEGER p6b_2
 
4289
      INTEGER dim_common
 
4290
      INTEGER dima_sort
 
4291
      INTEGER dima
 
4292
      INTEGER dimb_sort
 
4293
      INTEGER dimb
 
4294
      INTEGER l_a_sort
 
4295
      INTEGER k_a_sort
 
4296
      INTEGER l_a
 
4297
      INTEGER k_a
 
4298
      INTEGER l_b_sort
 
4299
      INTEGER k_b_sort
 
4300
      INTEGER l_b
 
4301
      INTEGER k_b
 
4302
      INTEGER l_c
 
4303
      INTEGER k_c
 
4304
c old way      EXTERNAL NXTASK
 
4305
      nprocs = GA_NNODES()
 
4306
      count = 0
 
4307
c old way      next = NXTASK(nprocs, 1)
 
4308
c --- new way ----
 
4309
      call nxt_ctx_next(ctx, icounter, next)
 
4310
c ----------------
 
4311
      DO p3b = noab+1,noab+nvab
 
4312
      DO p4b = p3b,noab+nvab
 
4313
      DO h1b = 1,noab
 
4314
      DO p5b = noab+1,noab+nvab
 
4315
      IF (next.eq.count) THEN
 
4316
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
4317
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
4318
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
4319
     &1b-1)+int_mb(k_spin+p5b-1)) THEN
 
4320
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
4321
     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
4322
     &EN
 
4323
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
4324
     &nge+h1b-1) * int_mb(k_range+p5b-1)
 
4325
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
4326
     & ERRQUIT('icsd_t2_3_2',0,MA_ERR)
 
4327
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
4328
      DO p6b = noab+1,noab+nvab
 
4329
      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
4330
      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
4331
     &EN
 
4332
      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
 
4333
      CALL TCE_RESTRICTED_4(p3b,p4b,p5b,p6b,p3b_2,p4b_2,p5b_2,p6b_2)
 
4334
      dim_common = int_mb(k_range+p6b-1)
 
4335
      dima_sort = int_mb(k_range+h1b-1)
 
4336
      dima = dim_common * dima_sort
 
4337
      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb
 
4338
     &(k_range+p5b-1)
 
4339
      dimb = dim_common * dimb_sort
 
4340
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
4341
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
4342
     & ERRQUIT('icsd_t2_3_2',1,MA_ERR)
 
4343
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
4344
     &icsd_t2_3_2',2,MA_ERR)
 
4345
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
4346
     & int_mb(k_a_offset),(h1b_1
 
4347
     & - 1 + noab * (p6b_1 - noab - 1)))
 
4348
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
4349
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
4350
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_3_2',3,MA_ERR)
 
4351
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
4352
     & ERRQUIT('icsd_t2_3_2',4,MA_ERR)
 
4353
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
4354
     &icsd_t2_3_2',5,MA_ERR)
 
4355
      IF ((p6b .lt. p5b)) THEN
 
4356
      if(.not.intorb) then
 
4357
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
4358
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab
 
4359
     &+nvab) * (p3b_2 - 1)))))
 
4360
      else
 
4361
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
4362
     &(p5b_2
 
4363
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab
 
4364
     &+nvab) * (p3b_2 - 1)))),p5b_2,p6b_2,p4b_2,p3b_2)
 
4365
      end if
 
4366
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1)
 
4367
     &,int_mb(k_range+p4b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1)
 
4368
     &,4,2,1,3,-1.0d0)
 
4369
      END IF
 
4370
      IF ((p5b .le. p6b)) THEN
 
4371
      if(.not.intorb) then
 
4372
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
4373
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab
 
4374
     &+nvab) * (p3b_2 - 1)))))
 
4375
      else
 
4376
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
4377
     &(p6b_2
 
4378
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab
 
4379
     &+nvab) * (p3b_2 - 1)))),p6b_2,p5b_2,p4b_2,p3b_2)
 
4380
      end if
 
4381
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1)
 
4382
     &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1)
 
4383
     &,3,2,1,4,1.0d0)
 
4384
      END IF
 
4385
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_3_2',6,MA_ERR)
 
4386
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
4387
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
4388
     &t),dima_sort)
 
4389
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_3_2',7,MA_E
 
4390
     &RR)
 
4391
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_3_2',8,MA_E
 
4392
     &RR)
 
4393
      END IF
 
4394
      END IF
 
4395
      END IF
 
4396
      END DO
 
4397
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
4398
     &icsd_t2_3_2',9,MA_ERR)
 
4399
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
4400
     &,int_mb(k_range+p4b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
 
4401
     &,3,2,4,1,-1.0d0/2.0d0)
 
4402
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
4403
     & noab - 1 + nvab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b
 
4404
     & - noab - 1)))))
 
4405
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_3_2',10,MA_ERR)
 
4406
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_3_2',11,MA_
 
4407
     &ERR)
 
4408
      END IF
 
4409
      END IF
 
4410
      END IF
 
4411
c old way      next = NXTASK(nprocs, 1)
 
4412
c --- new way ----
 
4413
      call nxt_ctx_next(ctx, icounter, next)
 
4414
c ----------------
 
4415
      END IF
 
4416
      count = count + 1
 
4417
      END DO
 
4418
      END DO
 
4419
      END DO
 
4420
      END DO
 
4421
c old way      next = NXTASK(-nprocs, 1)
 
4422
c old way      call GA_SYNC()
 
4423
      RETURN
 
4424
      END
 
4425
      SUBROUTINE icsd_t2_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset,
 
4426
     &ctx,icounter)
 
4427
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
4428
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
4429
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
4430
C     i0 ( p3 p4 h1 h2 )_tf + = -1 * P( 2 ) * Sum ( h9 ) * t ( p3 p4 h1 h9 )_t * i1 ( h9 h2 )_f
 
4431
      IMPLICIT NONE
 
4432
#include "global.fh"
 
4433
#include "mafdecls.fh"
 
4434
#include "sym.fh"
 
4435
#include "errquit.fh"
 
4436
#include "tce.fh"
 
4437
      INTEGER d_a
 
4438
      INTEGER k_a_offset
 
4439
      INTEGER d_b
 
4440
      INTEGER k_b_offset
 
4441
      INTEGER d_c
 
4442
      INTEGER k_c_offset
 
4443
c old way      INTEGER NXTASK
 
4444
c -------------------------
 
4445
      INTEGER ctx,icounter
 
4446
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
4447
c -------------------------
 
4448
      INTEGER next
 
4449
      INTEGER nprocs
 
4450
      INTEGER count
 
4451
      INTEGER p3b
 
4452
      INTEGER p4b
 
4453
      INTEGER h1b
 
4454
      INTEGER h2b
 
4455
      INTEGER dimc
 
4456
      INTEGER l_c_sort
 
4457
      INTEGER k_c_sort
 
4458
      INTEGER h9b
 
4459
      INTEGER p3b_1
 
4460
      INTEGER p4b_1
 
4461
      INTEGER h1b_1
 
4462
      INTEGER h9b_1
 
4463
      INTEGER h9b_2
 
4464
      INTEGER h2b_2
 
4465
      INTEGER dim_common
 
4466
      INTEGER dima_sort
 
4467
      INTEGER dima
 
4468
      INTEGER dimb_sort
 
4469
      INTEGER dimb
 
4470
      INTEGER l_a_sort
 
4471
      INTEGER k_a_sort
 
4472
      INTEGER l_a
 
4473
      INTEGER k_a
 
4474
      INTEGER l_b_sort
 
4475
      INTEGER k_b_sort
 
4476
      INTEGER l_b
 
4477
      INTEGER k_b
 
4478
      INTEGER l_c
 
4479
      INTEGER k_c
 
4480
c old way      EXTERNAL NXTASK
 
4481
      nprocs = GA_NNODES()
 
4482
      count = 0
 
4483
c old way      next = NXTASK(nprocs, 1)
 
4484
c --- new way ----
 
4485
      call nxt_ctx_next(ctx, icounter, next)
 
4486
c ----------------
 
4487
      DO p3b = noab+1,noab+nvab
 
4488
      DO p4b = p3b,noab+nvab
 
4489
      DO h1b = 1,noab
 
4490
      DO h2b = 1,noab
 
4491
      IF (next.eq.count) THEN
 
4492
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
4493
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
4494
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
4495
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
4496
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
4497
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_t,irrep_f)) TH
 
4498
     &EN
 
4499
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
4500
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
4501
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
4502
     & ERRQUIT('icsd_t2_4',0,MA_ERR)
 
4503
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
4504
      DO h9b = 1,noab
 
4505
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
4506
     &1b-1)+int_mb(k_spin+h9b-1)) THEN
 
4507
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
4508
     &k_sym+h1b-1),int_mb(k_sym+h9b-1)))) .eq. irrep_t) THEN
 
4509
      CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h9b,p3b_1,p4b_1,h1b_1,h9b_1)
 
4510
      CALL TCE_RESTRICTED_2(h9b,h2b,h9b_2,h2b_2)
 
4511
      dim_common = int_mb(k_range+h9b-1)
 
4512
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb
 
4513
     &(k_range+h1b-1)
 
4514
      dima = dim_common * dima_sort
 
4515
      dimb_sort = int_mb(k_range+h2b-1)
 
4516
      dimb = dim_common * dimb_sort
 
4517
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
4518
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
4519
     & ERRQUIT('icsd_t2_4',1,MA_ERR)
 
4520
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
4521
     &icsd_t2_4',2,MA_ERR)
 
4522
      IF ((h9b .lt. h1b)) THEN
 
4523
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
4524
     & - 1 + noab * (h9b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
 
4525
     &1 - noab - 1)))))
 
4526
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
4527
     &,int_mb(k_range+p4b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1)
 
4528
     &,4,2,1,3,-1.0d0)
 
4529
      END IF
 
4530
      IF ((h1b .le. h9b)) THEN
 
4531
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h9b_1
 
4532
     & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
 
4533
     &1 - noab - 1)))))
 
4534
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
4535
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h9b-1)
 
4536
     &,3,2,1,4,1.0d0)
 
4537
      END IF
 
4538
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_4',3,MA_ERR)
 
4539
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
4540
     & ERRQUIT('icsd_t2_4',4,MA_ERR)
 
4541
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
4542
     &icsd_t2_4',5,MA_ERR)
 
4543
ccx      CALL GET_HASH_BLOCK_MA(dbl_mb(d_b),dbl_mb(k_b),dimb,
 
4544
ccx     & int_mb(k_b_offset),(h2b_2
 
4545
ccx     & - 1 + noab * (h9b_2 - 1)))
 
4546
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
 
4547
     & - 1 + noab * (h9b_2 - 1)))
 
4548
c
 
4549
      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
4550
     &,int_mb(k_range+h2b-1),2,1,1.0d0)
 
4551
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_4',6,MA_ERR)
 
4552
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
4553
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
4554
     &t),dima_sort)
 
4555
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_4',7,MA_ERR
 
4556
     &)
 
4557
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_4',8,MA_ERR
 
4558
     &)
 
4559
      END IF
 
4560
      END IF
 
4561
      END IF
 
4562
      END DO
 
4563
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
4564
     &icsd_t2_4',9,MA_ERR)
 
4565
      IF ((h1b .le. h2b)) THEN
 
4566
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
4567
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
4568
     &,4,3,2,1,-1.0d0)
 
4569
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
4570
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
4571
     & - 1)))))
 
4572
      END IF
 
4573
      IF ((h2b .le. h1b)) THEN
 
4574
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
4575
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
4576
     &,4,3,1,2,1.0d0)
 
4577
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
4578
     & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
4579
     & - 1)))))
 
4580
      END IF
 
4581
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_4',10,MA_ERR)
 
4582
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_4',11,MA_ER
 
4583
     &R)
 
4584
      END IF
 
4585
      END IF
 
4586
      END IF
 
4587
c old way      next = NXTASK(nprocs, 1)
 
4588
c --- new way ----
 
4589
      call nxt_ctx_next(ctx, icounter, next)
 
4590
c ----------------
 
4591
      END IF
 
4592
      count = count + 1
 
4593
      END DO
 
4594
      END DO
 
4595
      END DO
 
4596
      END DO
 
4597
c old way      next = NXTASK(-nprocs, 1)
 
4598
c old way      call GA_SYNC()
 
4599
      RETURN
 
4600
      END
 
4601
      SUBROUTINE icsd_t2_4_1(d_a,k_a_offset,d_c,k_c_offset,ctx,icounter)
 
4602
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
4603
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
4604
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
4605
C     i1 ( h9 h1 )_f + = 1 * f ( h9 h1 )_f
 
4606
      IMPLICIT NONE
 
4607
#include "global.fh"
 
4608
#include "mafdecls.fh"
 
4609
#include "sym.fh"
 
4610
#include "errquit.fh"
 
4611
#include "tce.fh"
 
4612
      INTEGER d_a
 
4613
      INTEGER k_a_offset
 
4614
      INTEGER d_c
 
4615
      INTEGER k_c_offset
 
4616
c old way      INTEGER NXTASK
 
4617
c -------------------------
 
4618
      INTEGER ctx,icounter
 
4619
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
4620
c -------------------------
 
4621
      INTEGER next
 
4622
      INTEGER nprocs
 
4623
      INTEGER count
 
4624
      INTEGER h9b
 
4625
      INTEGER h1b
 
4626
      INTEGER dimc
 
4627
      INTEGER h9b_1
 
4628
      INTEGER h1b_1
 
4629
      INTEGER dim_common
 
4630
      INTEGER dima_sort
 
4631
      INTEGER dima
 
4632
      INTEGER l_a_sort
 
4633
      INTEGER k_a_sort
 
4634
      INTEGER l_a
 
4635
      INTEGER k_a
 
4636
      INTEGER l_c
 
4637
      INTEGER k_c
 
4638
c old way      EXTERNAL NXTASK
 
4639
      nprocs = GA_NNODES()
 
4640
      count = 0
 
4641
c old way      next = NXTASK(nprocs, 1)
 
4642
c --- new way ----
 
4643
      call nxt_ctx_next(ctx, icounter, next)
 
4644
c ----------------
 
4645
      DO h9b = 1,noab
 
4646
      DO h1b = 1,noab
 
4647
      IF (next.eq.count) THEN
 
4648
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1
 
4649
     &).ne.4)) THEN
 
4650
      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
4651
      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
 
4652
     &EN
 
4653
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1)
 
4654
      CALL TCE_RESTRICTED_2(h9b,h1b,h9b_1,h1b_1)
 
4655
      dim_common = 1
 
4656
      dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1)
 
4657
      dima = dim_common * dima_sort
 
4658
      IF (dima .gt. 0) THEN
 
4659
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
4660
     & ERRQUIT('icsd_t2_4_1',0,MA_ERR)
 
4661
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
4662
     &icsd_t2_4_1',1,MA_ERR)
 
4663
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
4664
     & - 1 + (noab+nvab) * (h9b_1 - 1)))
 
4665
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1)
 
4666
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
4667
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_4_1',2,MA_ERR)
 
4668
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
4669
     &icsd_t2_4_1',3,MA_ERR)
 
4670
      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
 
4671
     &,int_mb(k_range+h9b-1),2,1,1.0d0)
 
4672
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
4673
     & 1 + noab * (h9b - 1)))
 
4674
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_4_1',4,MA_ERR)
 
4675
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_4_1',5,MA_E
 
4676
     &RR)
 
4677
      END IF
 
4678
      END IF
 
4679
      END IF
 
4680
      END IF
 
4681
c oldl way      next = NXTASK(nprocs, 1)
 
4682
c --- new way ----
 
4683
      call nxt_ctx_next(ctx, icounter, next)
 
4684
c ----------------
 
4685
      END IF
 
4686
      count = count + 1
 
4687
      END DO
 
4688
      END DO
 
4689
c old way      next = NXTASK(-nprocs, 1)
 
4690
c old way      call GA_SYNC()
 
4691
      RETURN
 
4692
      END
 
4693
      SUBROUTINE OFFSET_icsd_t2_4_1(l_a_offset,k_a_offset,size)
 
4694
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
4695
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
4696
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
4697
C     i1 ( h9 h1 )_f
 
4698
      IMPLICIT NONE
 
4699
#include "global.fh"
 
4700
#include "mafdecls.fh"
 
4701
#include "sym.fh"
 
4702
#include "errquit.fh"
 
4703
#include "tce.fh"
 
4704
      INTEGER l_a_offset
 
4705
      INTEGER k_a_offset
 
4706
      INTEGER size
 
4707
      INTEGER length
 
4708
      INTEGER addr
 
4709
      INTEGER h9b
 
4710
      INTEGER h1b
 
4711
      length = 0
 
4712
      DO h9b = 1,noab
 
4713
      DO h1b = 1,noab
 
4714
      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
4715
      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
 
4716
     &EN
 
4717
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1
 
4718
     &).ne.4)) THEN
 
4719
      length = length + 1
 
4720
      END IF
 
4721
      END IF
 
4722
      END IF
 
4723
      END DO
 
4724
      END DO
 
4725
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
4726
     &set)) CALL ERRQUIT('icsd_t2_4_1',0,MA_ERR)
 
4727
      int_mb(k_a_offset) = length
 
4728
      addr = 0
 
4729
      size = 0
 
4730
      DO h9b = 1,noab
 
4731
      DO h1b = 1,noab
 
4732
      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
4733
      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. irrep_f) TH
 
4734
     &EN
 
4735
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1
 
4736
     &).ne.4)) THEN
 
4737
      addr = addr + 1
 
4738
      int_mb(k_a_offset+addr) = h1b - 1 + noab * (h9b - 1)
 
4739
      int_mb(k_a_offset+length+addr) = size
 
4740
      size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1)
 
4741
      END IF
 
4742
      END IF
 
4743
      END IF
 
4744
      END DO
 
4745
      END DO
 
4746
      RETURN
 
4747
      END
 
4748
      SUBROUTINE icsd_t2_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
4749
     &t,ctx,icounter)
 
4750
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
4751
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
4752
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
4753
C     i1 ( h9 h1 )_ft + = 1 * Sum ( p8 ) * t ( p8 h1 )_t * i2 ( h9 p8 )_f
 
4754
      IMPLICIT NONE
 
4755
#include "global.fh"
 
4756
#include "mafdecls.fh"
 
4757
#include "sym.fh"
 
4758
#include "errquit.fh"
 
4759
#include "tce.fh"
 
4760
      INTEGER d_a
 
4761
      INTEGER k_a_offset
 
4762
      INTEGER d_b
 
4763
      INTEGER k_b_offset
 
4764
      INTEGER d_c
 
4765
      INTEGER k_c_offset
 
4766
c old way      INTEGER NXTASK
 
4767
c -------------------------
 
4768
      INTEGER ctx,icounter
 
4769
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
4770
c -------------------------
 
4771
      INTEGER next
 
4772
      INTEGER nprocs
 
4773
      INTEGER count
 
4774
      INTEGER h9b
 
4775
      INTEGER h1b
 
4776
      INTEGER dimc
 
4777
      INTEGER l_c_sort
 
4778
      INTEGER k_c_sort
 
4779
      INTEGER p8b
 
4780
      INTEGER p8b_1
 
4781
      INTEGER h1b_1
 
4782
      INTEGER h9b_2
 
4783
      INTEGER p8b_2
 
4784
      INTEGER dim_common
 
4785
      INTEGER dima_sort
 
4786
      INTEGER dima
 
4787
      INTEGER dimb_sort
 
4788
      INTEGER dimb
 
4789
      INTEGER l_a_sort
 
4790
      INTEGER k_a_sort
 
4791
      INTEGER l_a
 
4792
      INTEGER k_a
 
4793
      INTEGER l_b_sort
 
4794
      INTEGER k_b_sort
 
4795
      INTEGER l_b
 
4796
      INTEGER k_b
 
4797
      INTEGER l_c
 
4798
      INTEGER k_c
 
4799
c old way      EXTERNAL NXTASK
 
4800
      nprocs = GA_NNODES()
 
4801
      count = 0
 
4802
c old way      next = NXTASK(nprocs, 1)
 
4803
c --- new way ----
 
4804
      call nxt_ctx_next(ctx, icounter, next)
 
4805
c ----------------
 
4806
      DO h9b = 1,noab
 
4807
      DO h1b = 1,noab
 
4808
      IF (next.eq.count) THEN
 
4809
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1
 
4810
     &).ne.4)) THEN
 
4811
      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
4812
      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
 
4813
     &f,irrep_t)) THEN
 
4814
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1)
 
4815
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
4816
     & ERRQUIT('icsd_t2_4_2',0,MA_ERR)
 
4817
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
4818
      DO p8b = noab+1,noab+nvab
 
4819
      IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
4820
      IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
4821
     &EN
 
4822
      CALL TCE_RESTRICTED_2(p8b,h1b,p8b_1,h1b_1)
 
4823
      CALL TCE_RESTRICTED_2(h9b,p8b,h9b_2,p8b_2)
 
4824
      dim_common = int_mb(k_range+p8b-1)
 
4825
      dima_sort = int_mb(k_range+h1b-1)
 
4826
      dima = dim_common * dima_sort
 
4827
      dimb_sort = int_mb(k_range+h9b-1)
 
4828
      dimb = dim_common * dimb_sort
 
4829
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
4830
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
4831
     & ERRQUIT('icsd_t2_4_2',1,MA_ERR)
 
4832
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
4833
     &icsd_t2_4_2',2,MA_ERR)
 
4834
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
4835
     & int_mb(k_a_offset),(h1b_1
 
4836
     & - 1 + noab * (p8b_1 - noab - 1)))
 
4837
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
 
4838
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
4839
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_4_2',3,MA_ERR)
 
4840
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
4841
     & ERRQUIT('icsd_t2_4_2',4,MA_ERR)
 
4842
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
4843
     &icsd_t2_4_2',5,MA_ERR)
 
4844
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
 
4845
     & - noab - 1 + nvab * (h9b_2 - 1)))
 
4846
      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
4847
     &,int_mb(k_range+p8b-1),1,2,1.0d0)
 
4848
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_4_2',6,MA_ERR)
 
4849
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
4850
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
4851
     &t),dima_sort)
 
4852
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_4_2',7,MA_E
 
4853
     &RR)
 
4854
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_4_2',8,MA_E
 
4855
     &RR)
 
4856
      END IF
 
4857
      END IF
 
4858
      END IF
 
4859
      END DO
 
4860
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
4861
     &icsd_t2_4_2',9,MA_ERR)
 
4862
      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h9b-1)
 
4863
     &,int_mb(k_range+h1b-1),1,2,1.0d0)
 
4864
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
4865
     & 1 + noab * (h9b - 1)))
 
4866
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_4_2',10,MA_ERR)
 
4867
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_4_2',11,MA_
 
4868
     &ERR)
 
4869
      END IF
 
4870
      END IF
 
4871
      END IF
 
4872
c old way      next = NXTASK(nprocs, 1)
 
4873
c --- new way ----
 
4874
      call nxt_ctx_next(ctx, icounter, next)
 
4875
c ----------------
 
4876
      END IF
 
4877
      count = count + 1
 
4878
      END DO
 
4879
      END DO
 
4880
c old way      next = NXTASK(-nprocs, 1)
 
4881
c old way      call GA_SYNC()
 
4882
      RETURN
 
4883
      END
 
4884
      SUBROUTINE icsd_t2_4_2_1(d_a,k_a_offset,d_c,k_c_offset,
 
4885
     &ctx,icounter)
 
4886
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
4887
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
4888
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
4889
C     i2 ( h9 p8 )_f + = 1 * f ( h9 p8 )_f
 
4890
      IMPLICIT NONE
 
4891
#include "global.fh"
 
4892
#include "mafdecls.fh"
 
4893
#include "sym.fh"
 
4894
#include "errquit.fh"
 
4895
#include "tce.fh"
 
4896
      INTEGER d_a
 
4897
      INTEGER k_a_offset
 
4898
      INTEGER d_c
 
4899
      INTEGER k_c_offset
 
4900
c old way      INTEGER NXTASK
 
4901
c -------------------------
 
4902
      INTEGER ctx,icounter
 
4903
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
4904
c -------------------------
 
4905
      INTEGER next
 
4906
      INTEGER nprocs
 
4907
      INTEGER count
 
4908
      INTEGER h9b
 
4909
      INTEGER p8b
 
4910
      INTEGER dimc
 
4911
      INTEGER h9b_1
 
4912
      INTEGER p8b_1
 
4913
      INTEGER dim_common
 
4914
      INTEGER dima_sort
 
4915
      INTEGER dima
 
4916
      INTEGER l_a_sort
 
4917
      INTEGER k_a_sort
 
4918
      INTEGER l_a
 
4919
      INTEGER k_a
 
4920
      INTEGER l_c
 
4921
      INTEGER k_c
 
4922
c ol dway      EXTERNAL NXTASK
 
4923
      nprocs = GA_NNODES()
 
4924
      count = 0
 
4925
c old way      next = NXTASK(nprocs, 1)
 
4926
c --- new way ----
 
4927
      call nxt_ctx_next(ctx, icounter, next)
 
4928
c ----------------
 
4929
      DO h9b = 1,noab
 
4930
      DO p8b = noab+1,noab+nvab
 
4931
      IF (next.eq.count) THEN
 
4932
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1
 
4933
     &).ne.4)) THEN
 
4934
      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN
 
4935
      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH
 
4936
     &EN
 
4937
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1)
 
4938
      CALL TCE_RESTRICTED_2(h9b,p8b,h9b_1,p8b_1)
 
4939
      dim_common = 1
 
4940
      dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1)
 
4941
      dima = dim_common * dima_sort
 
4942
      IF (dima .gt. 0) THEN
 
4943
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
4944
     & ERRQUIT('icsd_t2_4_2_1',0,MA_ERR)
 
4945
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
4946
     &icsd_t2_4_2_1',1,MA_ERR)
 
4947
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1
 
4948
     & - 1 + (noab+nvab) * (h9b_1 - 1)))
 
4949
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1)
 
4950
     &,int_mb(k_range+p8b-1),2,1,1.0d0)
 
4951
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_4_2_1',2,MA_ERR)
 
4952
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
4953
     &icsd_t2_4_2_1',3,MA_ERR)
 
4954
      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
 
4955
     &,int_mb(k_range+h9b-1),2,1,1.0d0)
 
4956
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
 
4957
     & noab - 1 + nvab * (h9b - 1)))
 
4958
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_4_2_1',4,MA_ERR)
 
4959
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_4_2_1',5,MA
 
4960
     &_ERR)
 
4961
      END IF
 
4962
      END IF
 
4963
      END IF
 
4964
      END IF
 
4965
c old way      next = NXTASK(nprocs, 1)
 
4966
c --- new way ----
 
4967
      call nxt_ctx_next(ctx, icounter, next)
 
4968
c ----------------
 
4969
      END IF
 
4970
      count = count + 1
 
4971
      END DO
 
4972
      END DO
 
4973
c old way      next = NXTASK(-nprocs, 1)
 
4974
c old way      call GA_SYNC()
 
4975
      RETURN
 
4976
      END
 
4977
      SUBROUTINE OFFSET_icsd_t2_4_2_1(l_a_offset,k_a_offset,size)
 
4978
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
4979
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
4980
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
4981
C     i2 ( h9 p8 )_f
 
4982
      IMPLICIT NONE
 
4983
#include "global.fh"
 
4984
#include "mafdecls.fh"
 
4985
#include "sym.fh"
 
4986
#include "errquit.fh"
 
4987
#include "tce.fh"
 
4988
      INTEGER l_a_offset
 
4989
      INTEGER k_a_offset
 
4990
      INTEGER size
 
4991
      INTEGER length
 
4992
      INTEGER addr
 
4993
      INTEGER h9b
 
4994
      INTEGER p8b
 
4995
      length = 0
 
4996
      DO h9b = 1,noab
 
4997
      DO p8b = noab+1,noab+nvab
 
4998
      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN
 
4999
      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH
 
5000
     &EN
 
5001
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1
 
5002
     &).ne.4)) THEN
 
5003
      length = length + 1
 
5004
      END IF
 
5005
      END IF
 
5006
      END IF
 
5007
      END DO
 
5008
      END DO
 
5009
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
5010
     &set)) CALL ERRQUIT('icsd_t2_4_2_1',0,MA_ERR)
 
5011
      int_mb(k_a_offset) = length
 
5012
      addr = 0
 
5013
      size = 0
 
5014
      DO h9b = 1,noab
 
5015
      DO p8b = noab+1,noab+nvab
 
5016
      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN
 
5017
      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. irrep_f) TH
 
5018
     &EN
 
5019
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1
 
5020
     &).ne.4)) THEN
 
5021
      addr = addr + 1
 
5022
      int_mb(k_a_offset+addr) = p8b - noab - 1 + nvab * (h9b - 1)
 
5023
      int_mb(k_a_offset+length+addr) = size
 
5024
      size = size + int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1)
 
5025
      END IF
 
5026
      END IF
 
5027
      END IF
 
5028
      END DO
 
5029
      END DO
 
5030
      RETURN
 
5031
      END
 
5032
      SUBROUTINE icsd_t2_4_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
 
5033
     &set,ctx,icounter)
 
5034
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
5035
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
5036
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
5037
C     i2 ( h9 p8 )_vt + = 1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 p6 p8 )_v
 
5038
      IMPLICIT NONE
 
5039
#include "global.fh"
 
5040
#include "mafdecls.fh"
 
5041
#include "sym.fh"
 
5042
#include "errquit.fh"
 
5043
#include "tce.fh"
 
5044
      INTEGER d_a
 
5045
      INTEGER k_a_offset
 
5046
      INTEGER d_b
 
5047
      INTEGER k_b_offset
 
5048
      INTEGER d_c
 
5049
      INTEGER k_c_offset
 
5050
c old way      INTEGER NXTASK
 
5051
c -------------------------
 
5052
      INTEGER ctx,icounter
 
5053
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
5054
c -------------------------
 
5055
      INTEGER next
 
5056
      INTEGER nprocs
 
5057
      INTEGER count
 
5058
      INTEGER h9b
 
5059
      INTEGER p8b
 
5060
      INTEGER dimc
 
5061
      INTEGER l_c_sort
 
5062
      INTEGER k_c_sort
 
5063
      INTEGER p6b
 
5064
      INTEGER h7b
 
5065
      INTEGER p6b_1
 
5066
      INTEGER h7b_1
 
5067
      INTEGER h9b_2
 
5068
      INTEGER h7b_2
 
5069
      INTEGER p8b_2
 
5070
      INTEGER p6b_2
 
5071
      INTEGER dim_common
 
5072
      INTEGER dima_sort
 
5073
      INTEGER dima
 
5074
      INTEGER dimb_sort
 
5075
      INTEGER dimb
 
5076
      INTEGER l_a_sort
 
5077
      INTEGER k_a_sort
 
5078
      INTEGER l_a
 
5079
      INTEGER k_a
 
5080
      INTEGER l_b_sort
 
5081
      INTEGER k_b_sort
 
5082
      INTEGER l_b
 
5083
      INTEGER k_b
 
5084
      INTEGER l_c
 
5085
      INTEGER k_c
 
5086
c old way      EXTERNAL NXTASK
 
5087
      nprocs = GA_NNODES()
 
5088
      count = 0
 
5089
c old way      next = NXTASK(nprocs, 1)
 
5090
c --- new way ----
 
5091
      call nxt_ctx_next(ctx, icounter, next)
 
5092
c ----------------
 
5093
      DO h9b = 1,noab
 
5094
      DO p8b = noab+1,noab+nvab
 
5095
      IF (next.eq.count) THEN
 
5096
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+p8b-1
 
5097
     &).ne.4)) THEN
 
5098
      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+p8b-1)) THEN
 
5099
      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+p8b-1)) .eq. ieor(irrep_
 
5100
     &v,irrep_t)) THEN
 
5101
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1)
 
5102
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
5103
     & ERRQUIT('icsd_t2_4_2_2',0,MA_ERR)
 
5104
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
5105
      DO p6b = noab+1,noab+nvab
 
5106
      DO h7b = 1,noab
 
5107
      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN
 
5108
      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH
 
5109
     &EN
 
5110
      CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1)
 
5111
      CALL TCE_RESTRICTED_4(h9b,h7b,p8b,p6b,h9b_2,h7b_2,p8b_2,p6b_2)
 
5112
      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1)
 
5113
      dima_sort = 1
 
5114
      dima = dim_common * dima_sort
 
5115
      dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+p8b-1)
 
5116
      dimb = dim_common * dimb_sort
 
5117
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
5118
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
5119
     & ERRQUIT('icsd_t2_4_2_2',1,MA_ERR)
 
5120
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
5121
     &icsd_t2_4_2_2',2,MA_ERR)
 
5122
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
5123
     & int_mb(k_a_offset),(h7b_1
 
5124
     & - 1 + noab * (p6b_1 - noab - 1)))
 
5125
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
5126
     &,int_mb(k_range+h7b-1),2,1,1.0d0)
 
5127
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_4_2_2',3,MA_ERR)
 
5128
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
5129
     & ERRQUIT('icsd_t2_4_2_2',4,MA_ERR)
 
5130
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
5131
     &icsd_t2_4_2_2',5,MA_ERR)
 
5132
      IF ((h7b .le. h9b) .and. (p6b .le. p8b)) THEN
 
5133
      if(.not.intorb) then
 
5134
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
 
5135
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
 
5136
     &+nvab) * (h7b_2 - 1)))))
 
5137
      else
 
5138
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
5139
     &(p8b_2
 
5140
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
 
5141
     &+nvab) * (h7b_2 - 1)))),p8b_2,p6b_2,h9b_2,h7b_2)
 
5142
      end if
 
5143
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
5144
     &,int_mb(k_range+h9b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1)
 
5145
     &,4,2,1,3,1.0d0)
 
5146
      END IF
 
5147
      IF ((h7b .le. h9b) .and. (p8b .lt. p6b)) THEN
 
5148
      if(.not.intorb) then
 
5149
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
5150
     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
 
5151
     &+nvab) * (h7b_2 - 1)))))
 
5152
      else
 
5153
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
5154
     &(p6b_2
 
5155
     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
 
5156
     &+nvab) * (h7b_2 - 1)))),p6b_2,p8b_2,h9b_2,h7b_2)
 
5157
      end if
 
5158
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
5159
     &,int_mb(k_range+h9b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1)
 
5160
     &,3,2,1,4,-1.0d0)
 
5161
      END IF
 
5162
      IF ((h9b .lt. h7b) .and. (p6b .le. p8b)) THEN
 
5163
      if(.not.intorb) then
 
5164
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
 
5165
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
 
5166
     &+nvab) * (h9b_2 - 1)))))
 
5167
      else
 
5168
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
5169
     &(p8b_2
 
5170
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
 
5171
     &+nvab) * (h9b_2 - 1)))),p8b_2,p6b_2,h7b_2,h9b_2)
 
5172
      end if
 
5173
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
5174
     &,int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1)
 
5175
     &,4,1,2,3,-1.0d0)
 
5176
      END IF
 
5177
      IF ((h9b .lt. h7b) .and. (p8b .lt. p6b)) THEN
 
5178
      if(.not.intorb) then
 
5179
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
5180
     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
 
5181
     &+nvab) * (h9b_2 - 1)))))
 
5182
      else
 
5183
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
5184
     &(p6b_2
 
5185
     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
 
5186
     &+nvab) * (h9b_2 - 1)))),p6b_2,p8b_2,h7b_2,h9b_2)
 
5187
      end if
 
5188
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
5189
     &,int_mb(k_range+h7b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1)
 
5190
     &,3,1,2,4,1.0d0)
 
5191
      END IF
 
5192
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_4_2_2',6,MA_ERR)
 
5193
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
5194
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
5195
     &t),dima_sort)
 
5196
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_4_2_2',7,MA
 
5197
     &_ERR)
 
5198
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_4_2_2',8,MA
 
5199
     &_ERR)
 
5200
      END IF
 
5201
      END IF
 
5202
      END IF
 
5203
      END DO
 
5204
      END DO
 
5205
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
5206
     &icsd_t2_4_2_2',9,MA_ERR)
 
5207
      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
 
5208
     &,int_mb(k_range+h9b-1),2,1,1.0d0)
 
5209
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
 
5210
     & noab - 1 + nvab * (h9b - 1)))
 
5211
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_4_2_2',10,MA_ERR
 
5212
     &)
 
5213
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_4_2_2',11,M
 
5214
     &A_ERR)
 
5215
      END IF
 
5216
      END IF
 
5217
      END IF
 
5218
c old way      next = NXTASK(nprocs, 1)
 
5219
c --- new way ----
 
5220
      call nxt_ctx_next(ctx, icounter, next)
 
5221
c ----------------
 
5222
      END IF
 
5223
      count = count + 1
 
5224
      END DO
 
5225
      END DO
 
5226
c old way      next = NXTASK(-nprocs, 1)
 
5227
c old way      call GA_SYNC()
 
5228
      RETURN
 
5229
      END
 
5230
      SUBROUTINE icsd_t2_4_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
5231
     &t,ctx,icounter)
 
5232
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
5233
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
5234
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
5235
C     i1 ( h9 h1 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 h9 h1 p6 )_v
 
5236
      IMPLICIT NONE
 
5237
#include "global.fh"
 
5238
#include "mafdecls.fh"
 
5239
#include "sym.fh"
 
5240
#include "errquit.fh"
 
5241
#include "tce.fh"
 
5242
      INTEGER d_a
 
5243
      INTEGER k_a_offset
 
5244
      INTEGER d_b
 
5245
      INTEGER k_b_offset
 
5246
      INTEGER d_c
 
5247
      INTEGER k_c_offset
 
5248
c old way      INTEGER NXTASK
 
5249
c -------------------------
 
5250
      INTEGER ctx,icounter
 
5251
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
5252
c -------------------------
 
5253
      INTEGER next
 
5254
      INTEGER nprocs
 
5255
      INTEGER count
 
5256
      INTEGER h9b
 
5257
      INTEGER h1b
 
5258
      INTEGER dimc
 
5259
      INTEGER l_c_sort
 
5260
      INTEGER k_c_sort
 
5261
      INTEGER p6b
 
5262
      INTEGER h7b
 
5263
      INTEGER p6b_1
 
5264
      INTEGER h7b_1
 
5265
      INTEGER h9b_2
 
5266
      INTEGER h7b_2
 
5267
      INTEGER h1b_2
 
5268
      INTEGER p6b_2
 
5269
      INTEGER dim_common
 
5270
      INTEGER dima_sort
 
5271
      INTEGER dima
 
5272
      INTEGER dimb_sort
 
5273
      INTEGER dimb
 
5274
      INTEGER l_a_sort
 
5275
      INTEGER k_a_sort
 
5276
      INTEGER l_a
 
5277
      INTEGER k_a
 
5278
      INTEGER l_b_sort
 
5279
      INTEGER k_b_sort
 
5280
      INTEGER l_b
 
5281
      INTEGER k_b
 
5282
      INTEGER l_c
 
5283
      INTEGER k_c
 
5284
c old way      EXTERNAL NXTASK
 
5285
      nprocs = GA_NNODES()
 
5286
      count = 0
 
5287
c old way      next = NXTASK(nprocs, 1)
 
5288
c --- new way ----
 
5289
      call nxt_ctx_next(ctx, icounter, next)
 
5290
c ----------------
 
5291
      DO h9b = 1,noab
 
5292
      DO h1b = 1,noab
 
5293
      IF (next.eq.count) THEN
 
5294
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1
 
5295
     &).ne.4)) THEN
 
5296
      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
5297
      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
 
5298
     &v,irrep_t)) THEN
 
5299
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1)
 
5300
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
5301
     & ERRQUIT('icsd_t2_4_3',0,MA_ERR)
 
5302
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
5303
      DO p6b = noab+1,noab+nvab
 
5304
      DO h7b = 1,noab
 
5305
      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN
 
5306
      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH
 
5307
     &EN
 
5308
      CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1)
 
5309
      CALL TCE_RESTRICTED_4(h9b,h7b,h1b,p6b,h9b_2,h7b_2,h1b_2,p6b_2)
 
5310
      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1)
 
5311
      dima_sort = 1
 
5312
      dima = dim_common * dima_sort
 
5313
      dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1)
 
5314
      dimb = dim_common * dimb_sort
 
5315
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
5316
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
5317
     & ERRQUIT('icsd_t2_4_3',1,MA_ERR)
 
5318
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
5319
     &icsd_t2_4_3',2,MA_ERR)
 
5320
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
5321
     & int_mb(k_a_offset),(h7b_1
 
5322
     & - 1 + noab * (p6b_1 - noab - 1)))
 
5323
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
5324
     &,int_mb(k_range+h7b-1),2,1,1.0d0)
 
5325
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_4_3',3,MA_ERR)
 
5326
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
5327
     & ERRQUIT('icsd_t2_4_3',4,MA_ERR)
 
5328
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
5329
     &icsd_t2_4_3',5,MA_ERR)
 
5330
      IF ((h7b .le. h9b) .and. (h1b .le. p6b)) THEN
 
5331
      if(.not.intorb) then
 
5332
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
5333
     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
 
5334
     &+nvab) * (h7b_2 - 1)))))
 
5335
      else
 
5336
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
5337
     &(p6b_2
 
5338
     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
 
5339
     &+nvab) * (h7b_2 - 1)))),p6b_2,h1b_2,h9b_2,h7b_2)
 
5340
      end if
 
5341
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
5342
     &,int_mb(k_range+h9b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1)
 
5343
     &,3,2,1,4,1.0d0)
 
5344
      END IF
 
5345
      IF ((h9b .lt. h7b) .and. (h1b .le. p6b)) THEN
 
5346
      if(.not.intorb) then
 
5347
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
5348
     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
 
5349
     &+nvab) * (h9b_2 - 1)))))
 
5350
      else
 
5351
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
5352
     &(p6b_2
 
5353
     & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (h7b_2 - 1 + (noab
 
5354
     &+nvab) * (h9b_2 - 1)))),p6b_2,h1b_2,h7b_2,h9b_2)
 
5355
      end if
 
5356
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
5357
     &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+p6b-1)
 
5358
     &,3,1,2,4,-1.0d0)
 
5359
      END IF
 
5360
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_4_3',6,MA_ERR)
 
5361
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
5362
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
5363
     &t),dima_sort)
 
5364
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_4_3',7,MA_E
 
5365
     &RR)
 
5366
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_4_3',8,MA_E
 
5367
     &RR)
 
5368
      END IF
 
5369
      END IF
 
5370
      END IF
 
5371
      END DO
 
5372
      END DO
 
5373
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
5374
     &icsd_t2_4_3',9,MA_ERR)
 
5375
      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
 
5376
     &,int_mb(k_range+h9b-1),2,1,-1.0d0)
 
5377
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
5378
     & 1 + noab * (h9b - 1)))
 
5379
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_4_3',10,MA_ERR)
 
5380
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_4_3',11,MA_
 
5381
     &ERR)
 
5382
      END IF
 
5383
      END IF
 
5384
      END IF
 
5385
c old way      next = NXTASK(nprocs, 1)
 
5386
c --- new way ----
 
5387
      call nxt_ctx_next(ctx, icounter, next)
 
5388
c ----------------
 
5389
      END IF
 
5390
      count = count + 1
 
5391
      END DO
 
5392
      END DO
 
5393
c old way      next = NXTASK(-nprocs, 1)
 
5394
c old way      call GA_SYNC()
 
5395
      RETURN
 
5396
      END
 
5397
      SUBROUTINE icsd_t2_4_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
5398
     &t,ctx,icounter)
 
5399
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
5400
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
5401
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
5402
C     i1 ( h9 h1 )_vt + = -1/2 * Sum ( h8 p6 p7 ) * t ( p6 p7 h1 h8 )_t * v ( h8 h9 p6 p7 )_v
 
5403
      IMPLICIT NONE
 
5404
#include "global.fh"
 
5405
#include "mafdecls.fh"
 
5406
#include "sym.fh"
 
5407
#include "errquit.fh"
 
5408
#include "tce.fh"
 
5409
      INTEGER d_a
 
5410
      INTEGER k_a_offset
 
5411
      INTEGER d_b
 
5412
      INTEGER k_b_offset
 
5413
      INTEGER d_c
 
5414
      INTEGER k_c_offset
 
5415
c old way      INTEGER NXTASK
 
5416
c -------------------------
 
5417
      INTEGER ctx,icounter
 
5418
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
5419
c -------------------------
 
5420
      INTEGER next
 
5421
      INTEGER nprocs
 
5422
      INTEGER count
 
5423
      INTEGER h9b
 
5424
      INTEGER h1b
 
5425
      INTEGER dimc
 
5426
      INTEGER l_c_sort
 
5427
      INTEGER k_c_sort
 
5428
      INTEGER p6b
 
5429
      INTEGER p7b
 
5430
      INTEGER h8b
 
5431
      INTEGER p6b_1
 
5432
      INTEGER p7b_1
 
5433
      INTEGER h1b_1
 
5434
      INTEGER h8b_1
 
5435
      INTEGER h9b_2
 
5436
      INTEGER h8b_2
 
5437
      INTEGER p6b_2
 
5438
      INTEGER p7b_2
 
5439
      INTEGER dim_common
 
5440
      INTEGER dima_sort
 
5441
      INTEGER dima
 
5442
      INTEGER dimb_sort
 
5443
      INTEGER dimb
 
5444
      INTEGER l_a_sort
 
5445
      INTEGER k_a_sort
 
5446
      INTEGER l_a
 
5447
      INTEGER k_a
 
5448
      INTEGER l_b_sort
 
5449
      INTEGER k_b_sort
 
5450
      INTEGER l_b
 
5451
      INTEGER k_b
 
5452
      INTEGER nsuperp(2)
 
5453
      INTEGER isuperp
 
5454
      INTEGER l_c
 
5455
      INTEGER k_c
 
5456
      DOUBLE PRECISION FACTORIAL
 
5457
c old way      EXTERNAL NXTASK
 
5458
      EXTERNAL FACTORIAL
 
5459
      nprocs = GA_NNODES()
 
5460
      count = 0
 
5461
c old way      next = NXTASK(nprocs, 1)
 
5462
c --- new way ----
 
5463
      call nxt_ctx_next(ctx, icounter, next)
 
5464
c ----------------
 
5465
      DO h9b = 1,noab
 
5466
      DO h1b = 1,noab
 
5467
      IF (next.eq.count) THEN
 
5468
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h1b-1
 
5469
     &).ne.4)) THEN
 
5470
      IF (int_mb(k_spin+h9b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
5471
      IF (ieor(int_mb(k_sym+h9b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_
 
5472
     &v,irrep_t)) THEN
 
5473
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h1b-1)
 
5474
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
5475
     & ERRQUIT('icsd_t2_4_4',0,MA_ERR)
 
5476
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
5477
      DO p6b = noab+1,noab+nvab
 
5478
      DO p7b = p6b,noab+nvab
 
5479
      DO h8b = 1,noab
 
5480
      IF (int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h
 
5481
     &1b-1)+int_mb(k_spin+h8b-1)) THEN
 
5482
      IF (ieor(int_mb(k_sym+p6b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb(
 
5483
     &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_t) THEN
 
5484
      CALL TCE_RESTRICTED_4(p6b,p7b,h1b,h8b,p6b_1,p7b_1,h1b_1,h8b_1)
 
5485
      CALL TCE_RESTRICTED_4(h9b,h8b,p6b,p7b,h9b_2,h8b_2,p6b_2,p7b_2)
 
5486
      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+p7b-1) * int_m
 
5487
     &b(k_range+h8b-1)
 
5488
      dima_sort = int_mb(k_range+h1b-1)
 
5489
      dima = dim_common * dima_sort
 
5490
      dimb_sort = int_mb(k_range+h9b-1)
 
5491
      dimb = dim_common * dimb_sort
 
5492
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
5493
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
5494
     & ERRQUIT('icsd_t2_4_4',1,MA_ERR)
 
5495
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
5496
     &icsd_t2_4_4',2,MA_ERR)
 
5497
      IF ((h8b .lt. h1b)) THEN
 
5498
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
5499
     & - 1 + noab * (h8b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p6b_
 
5500
     &1 - noab - 1)))))
 
5501
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
5502
     &,int_mb(k_range+p7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1)
 
5503
     &,4,3,2,1,-1.0d0)
 
5504
      END IF
 
5505
      IF ((h1b .le. h8b)) THEN
 
5506
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
 
5507
     & - 1 + noab * (h1b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p6b_
 
5508
     &1 - noab - 1)))))
 
5509
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
5510
     &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1)
 
5511
     &,3,4,2,1,1.0d0)
 
5512
      END IF
 
5513
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_4_4',3,MA_ERR)
 
5514
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
5515
     & ERRQUIT('icsd_t2_4_4',4,MA_ERR)
 
5516
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
5517
     &icsd_t2_4_4',5,MA_ERR)
 
5518
      IF ((h8b .le. h9b)) THEN
 
5519
      if(.not.intorb) then
 
5520
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
 
5521
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
 
5522
     &+nvab) * (h8b_2 - 1)))))
 
5523
      else
 
5524
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
5525
     &(p7b_2
 
5526
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h9b_2 - 1 + (noab
 
5527
     &+nvab) * (h8b_2 - 1)))),p7b_2,p6b_2,h9b_2,h8b_2)
 
5528
      end if
 
5529
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
 
5530
     &,int_mb(k_range+h9b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b-1)
 
5531
     &,2,1,4,3,1.0d0)
 
5532
      END IF
 
5533
      IF ((h9b .lt. h8b)) THEN
 
5534
      if(.not.intorb) then
 
5535
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
 
5536
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
 
5537
     &+nvab) * (h9b_2 - 1)))))
 
5538
      else
 
5539
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
5540
     &(p7b_2
 
5541
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
 
5542
     &+nvab) * (h9b_2 - 1)))),p7b_2,p6b_2,h8b_2,h9b_2)
 
5543
      end if
 
5544
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
5545
     &,int_mb(k_range+h8b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b-1)
 
5546
     &,1,2,4,3,-1.0d0)
 
5547
      END IF
 
5548
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_4_4',6,MA_ERR)
 
5549
      nsuperp(1) = 1
 
5550
      nsuperp(2) = 1
 
5551
      isuperp = 1
 
5552
      IF (p6b .eq. p7b) THEN
 
5553
      nsuperp(isuperp) = nsuperp(isuperp) + 1
 
5554
      ELSE
 
5555
      isuperp = isuperp + 1
 
5556
      END IF
 
5557
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
 
5558
     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
 
5559
     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
 
5560
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_4_4',7,MA_E
 
5561
     &RR)
 
5562
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_4_4',8,MA_E
 
5563
     &RR)
 
5564
      END IF
 
5565
      END IF
 
5566
      END IF
 
5567
      END DO
 
5568
      END DO
 
5569
      END DO
 
5570
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
5571
     &icsd_t2_4_4',9,MA_ERR)
 
5572
      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h9b-1)
 
5573
     &,int_mb(k_range+h1b-1),1,2,-1.0d0/2.0d0)
 
5574
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
5575
     & 1 + noab * (h9b - 1)))
 
5576
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_4_4',10,MA_ERR)
 
5577
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_4_4',11,MA_
 
5578
     &ERR)
 
5579
      END IF
 
5580
      END IF
 
5581
      END IF
 
5582
c old way      next = NXTASK(nprocs, 1)
 
5583
c --- new way ----
 
5584
      call nxt_ctx_next(ctx, icounter, next)
 
5585
c ----------------
 
5586
      END IF
 
5587
      count = count + 1
 
5588
      END DO
 
5589
      END DO
 
5590
c old way      next = NXTASK(-nprocs, 1)
 
5591
c old way      call GA_SYNC()
 
5592
      RETURN
 
5593
      END
 
5594
      SUBROUTINE icsd_t2_5(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset,
 
5595
     &ctx,icounter)
 
5596
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
5597
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
5598
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
5599
C     i0 ( p3 p4 h1 h2 )_tf + = 1 * P( 2 ) * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * i1 ( p4 p5 )_f
 
5600
      IMPLICIT NONE
 
5601
#include "global.fh"
 
5602
#include "mafdecls.fh"
 
5603
#include "sym.fh"
 
5604
#include "errquit.fh"
 
5605
#include "tce.fh"
 
5606
      INTEGER d_a
 
5607
      INTEGER k_a_offset
 
5608
      INTEGER d_b
 
5609
      INTEGER k_b_offset
 
5610
      INTEGER d_c
 
5611
      INTEGER k_c_offset
 
5612
c old way      INTEGER NXTASK
 
5613
c -------------------------
 
5614
      INTEGER ctx,icounter
 
5615
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
5616
c -------------------------
 
5617
      INTEGER next
 
5618
      INTEGER nprocs
 
5619
      INTEGER count
 
5620
      INTEGER p3b
 
5621
      INTEGER p4b
 
5622
      INTEGER h1b
 
5623
      INTEGER h2b
 
5624
      INTEGER dimc
 
5625
      INTEGER l_c_sort
 
5626
      INTEGER k_c_sort
 
5627
      INTEGER p5b
 
5628
      INTEGER p3b_1
 
5629
      INTEGER p5b_1
 
5630
      INTEGER h1b_1
 
5631
      INTEGER h2b_1
 
5632
      INTEGER p4b_2
 
5633
      INTEGER p5b_2
 
5634
      INTEGER dim_common
 
5635
      INTEGER dima_sort
 
5636
      INTEGER dima
 
5637
      INTEGER dimb_sort
 
5638
      INTEGER dimb
 
5639
      INTEGER l_a_sort
 
5640
      INTEGER k_a_sort
 
5641
      INTEGER l_a
 
5642
      INTEGER k_a
 
5643
      INTEGER l_b_sort
 
5644
      INTEGER k_b_sort
 
5645
      INTEGER l_b
 
5646
      INTEGER k_b
 
5647
      INTEGER l_c
 
5648
      INTEGER k_c
 
5649
c old way      EXTERNAL NXTASK
 
5650
      nprocs = GA_NNODES()
 
5651
      count = 0
 
5652
c old way      next = NXTASK(nprocs, 1)
 
5653
c --- new way ----
 
5654
      call nxt_ctx_next(ctx, icounter, next)
 
5655
c ----------------
 
5656
      DO p3b = noab+1,noab+nvab
 
5657
      DO p4b = noab+1,noab+nvab
 
5658
      DO h1b = 1,noab
 
5659
      DO h2b = h1b,noab
 
5660
      IF (next.eq.count) THEN
 
5661
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
5662
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
5663
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
5664
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
5665
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
5666
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_t,irrep_f)) TH
 
5667
     &EN
 
5668
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
5669
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
5670
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
5671
     & ERRQUIT('icsd_t2_5',0,MA_ERR)
 
5672
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
5673
      DO p5b = noab+1,noab+nvab
 
5674
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
 
5675
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
5676
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
 
5677
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
 
5678
      CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h2b,p3b_1,p5b_1,h1b_1,h2b_1)
 
5679
      CALL TCE_RESTRICTED_2(p4b,p5b,p4b_2,p5b_2)
 
5680
      dim_common = int_mb(k_range+p5b-1)
 
5681
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb
 
5682
     &(k_range+h2b-1)
 
5683
      dima = dim_common * dima_sort
 
5684
      dimb_sort = int_mb(k_range+p4b-1)
 
5685
      dimb = dim_common * dimb_sort
 
5686
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
5687
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
5688
     & ERRQUIT('icsd_t2_5',1,MA_ERR)
 
5689
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
5690
     &icsd_t2_5',2,MA_ERR)
 
5691
      IF ((p5b .lt. p3b)) THEN
 
5692
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
5693
     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
 
5694
     &1 - noab - 1)))))
 
5695
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
5696
     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
5697
     &,4,3,2,1,-1.0d0)
 
5698
      END IF
 
5699
      IF ((p3b .le. p5b)) THEN
 
5700
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
5701
     & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
 
5702
     &1 - noab - 1)))))
 
5703
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
5704
     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
5705
     &,4,3,1,2,1.0d0)
 
5706
      END IF
 
5707
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_5',3,MA_ERR)
 
5708
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
5709
     & ERRQUIT('icsd_t2_5',4,MA_ERR)
 
5710
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
5711
     &icsd_t2_5',5,MA_ERR)
 
5712
ccx      CALL GET_HASH_BLOCK_MA(dbl_mb(d_b),dbl_mb(k_b),dimb,
 
5713
ccx     & int_mb(k_b_offset),(p5b_2
 
5714
ccx     & - noab - 1 + nvab * (p4b_2 - noab - 1)))
 
5715
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
5716
     & - noab - 1 + nvab * (p4b_2 - noab - 1)))
 
5717
c
 
5718
      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
 
5719
     &,int_mb(k_range+p5b-1),1,2,1.0d0)
 
5720
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_5',6,MA_ERR)
 
5721
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
5722
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
5723
     &t),dima_sort)
 
5724
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_5',7,MA_ERR
 
5725
     &)
 
5726
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_5',8,MA_ERR
 
5727
     &)
 
5728
      END IF
 
5729
      END IF
 
5730
      END IF
 
5731
      END DO
 
5732
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
5733
     &icsd_t2_5',9,MA_ERR)
 
5734
      IF ((p3b .le. p4b)) THEN
 
5735
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1)
 
5736
     &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
5737
     &,4,1,3,2,1.0d0)
 
5738
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
5739
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
5740
     & - 1)))))
 
5741
      END IF
 
5742
      IF ((p4b .le. p3b)) THEN
 
5743
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1)
 
5744
     &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
5745
     &,1,4,3,2,-1.0d0)
 
5746
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
5747
     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
 
5748
     & - 1)))))
 
5749
      END IF
 
5750
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_5',10,MA_ERR)
 
5751
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_5',11,MA_ER
 
5752
     &R)
 
5753
      END IF
 
5754
      END IF
 
5755
      END IF
 
5756
c old way      next = NXTASK(nprocs, 1)
 
5757
c --- new way ----
 
5758
      call nxt_ctx_next(ctx, icounter, next)
 
5759
c ----------------
 
5760
      END IF
 
5761
      count = count + 1
 
5762
      END DO
 
5763
      END DO
 
5764
      END DO
 
5765
      END DO
 
5766
c old way      next = NXTASK(-nprocs, 1)
 
5767
c old way      call GA_SYNC()
 
5768
      RETURN
 
5769
      END
 
5770
      SUBROUTINE icsd_t2_5_1(d_a,k_a_offset,d_c,k_c_offset,ctx,icounter)
 
5771
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
5772
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
5773
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
5774
C     i1 ( p3 p5 )_f + = 1 * f ( p3 p5 )_f
 
5775
      IMPLICIT NONE
 
5776
#include "global.fh"
 
5777
#include "mafdecls.fh"
 
5778
#include "sym.fh"
 
5779
#include "errquit.fh"
 
5780
#include "tce.fh"
 
5781
      INTEGER d_a
 
5782
      INTEGER k_a_offset
 
5783
      INTEGER d_c
 
5784
      INTEGER k_c_offset
 
5785
c old way      INTEGER NXTASK
 
5786
c -------------------------
 
5787
      INTEGER ctx,icounter
 
5788
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
5789
c -------------------------
 
5790
      INTEGER next
 
5791
      INTEGER nprocs
 
5792
      INTEGER count
 
5793
      INTEGER p3b
 
5794
      INTEGER p5b
 
5795
      INTEGER dimc
 
5796
      INTEGER p3b_1
 
5797
      INTEGER p5b_1
 
5798
      INTEGER dim_common
 
5799
      INTEGER dima_sort
 
5800
      INTEGER dima
 
5801
      INTEGER l_a_sort
 
5802
      INTEGER k_a_sort
 
5803
      INTEGER l_a
 
5804
      INTEGER k_a
 
5805
      INTEGER l_c
 
5806
      INTEGER k_c
 
5807
c old way      EXTERNAL NXTASK
 
5808
      nprocs = GA_NNODES()
 
5809
      count = 0
 
5810
c old way      next = NXTASK(nprocs, 1)
 
5811
c --- new way ----
 
5812
      call nxt_ctx_next(ctx, icounter, next)
 
5813
c ----------------
 
5814
      DO p3b = noab+1,noab+nvab
 
5815
      DO p5b = noab+1,noab+nvab
 
5816
      IF (next.eq.count) THEN
 
5817
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
 
5818
     &).ne.4)) THEN
 
5819
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
5820
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) TH
 
5821
     &EN
 
5822
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1)
 
5823
      CALL TCE_RESTRICTED_2(p3b,p5b,p3b_1,p5b_1)
 
5824
      dim_common = 1
 
5825
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1)
 
5826
      dima = dim_common * dima_sort
 
5827
      IF (dima .gt. 0) THEN
 
5828
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
5829
     & ERRQUIT('icsd_t2_5_1',0,MA_ERR)
 
5830
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
5831
     &icsd_t2_5_1',1,MA_ERR)
 
5832
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
 
5833
     & - 1 + (noab+nvab) * (p3b_1 - 1)))
 
5834
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
5835
     &,int_mb(k_range+p5b-1),2,1,1.0d0)
 
5836
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_5_1',2,MA_ERR)
 
5837
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
5838
     &icsd_t2_5_1',3,MA_ERR)
 
5839
      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
5840
     &,int_mb(k_range+p3b-1),2,1,1.0d0)
 
5841
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
5842
     & noab - 1 + nvab * (p3b - noab - 1)))
 
5843
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_5_1',4,MA_ERR)
 
5844
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_5_1',5,MA_E
 
5845
     &RR)
 
5846
      END IF
 
5847
      END IF
 
5848
      END IF
 
5849
      END IF
 
5850
c old way      next = NXTASK(nprocs, 1)
 
5851
c --- new way ----
 
5852
      call nxt_ctx_next(ctx, icounter, next)
 
5853
c ----------------
 
5854
      END IF
 
5855
      count = count + 1
 
5856
      END DO
 
5857
      END DO
 
5858
c old way      next = NXTASK(-nprocs, 1)
 
5859
c old way      call GA_SYNC()
 
5860
      RETURN
 
5861
      END
 
5862
      SUBROUTINE OFFSET_icsd_t2_5_1(l_a_offset,k_a_offset,size)
 
5863
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
5864
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
5865
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
5866
C     i1 ( p3 p5 )_f
 
5867
      IMPLICIT NONE
 
5868
#include "global.fh"
 
5869
#include "mafdecls.fh"
 
5870
#include "sym.fh"
 
5871
#include "errquit.fh"
 
5872
#include "tce.fh"
 
5873
      INTEGER l_a_offset
 
5874
      INTEGER k_a_offset
 
5875
      INTEGER size
 
5876
      INTEGER length
 
5877
      INTEGER addr
 
5878
      INTEGER p3b
 
5879
      INTEGER p5b
 
5880
      length = 0
 
5881
      DO p3b = noab+1,noab+nvab
 
5882
      DO p5b = noab+1,noab+nvab
 
5883
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
5884
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) TH
 
5885
     &EN
 
5886
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
 
5887
     &).ne.4)) THEN
 
5888
      length = length + 1
 
5889
      END IF
 
5890
      END IF
 
5891
      END IF
 
5892
      END DO
 
5893
      END DO
 
5894
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
5895
     &set)) CALL ERRQUIT('icsd_t2_5_1',0,MA_ERR)
 
5896
      int_mb(k_a_offset) = length
 
5897
      addr = 0
 
5898
      size = 0
 
5899
      DO p3b = noab+1,noab+nvab
 
5900
      DO p5b = noab+1,noab+nvab
 
5901
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
5902
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) TH
 
5903
     &EN
 
5904
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
 
5905
     &).ne.4)) THEN
 
5906
      addr = addr + 1
 
5907
      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (p3b - noab - 1)
 
5908
      int_mb(k_a_offset+length+addr) = size
 
5909
      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1)
 
5910
      END IF
 
5911
      END IF
 
5912
      END IF
 
5913
      END DO
 
5914
      END DO
 
5915
      RETURN
 
5916
      END
 
5917
      SUBROUTINE icsd_t2_5_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
5918
     &t,ctx,icounter)
 
5919
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
5920
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
5921
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
5922
C     i1 ( p3 p5 )_vt + = -1 * Sum ( h7 p6 ) * t ( p6 h7 )_t * v ( h7 p3 p5 p6 )_v
 
5923
      IMPLICIT NONE
 
5924
#include "global.fh"
 
5925
#include "mafdecls.fh"
 
5926
#include "sym.fh"
 
5927
#include "errquit.fh"
 
5928
#include "tce.fh"
 
5929
      INTEGER d_a
 
5930
      INTEGER k_a_offset
 
5931
      INTEGER d_b
 
5932
      INTEGER k_b_offset
 
5933
      INTEGER d_c
 
5934
      INTEGER k_c_offset
 
5935
c old way      INTEGER NXTASK
 
5936
c -------------------------
 
5937
      INTEGER ctx,icounter
 
5938
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
5939
c -------------------------
 
5940
      INTEGER next
 
5941
      INTEGER nprocs
 
5942
      INTEGER count
 
5943
      INTEGER p3b
 
5944
      INTEGER p5b
 
5945
      INTEGER dimc
 
5946
      INTEGER l_c_sort
 
5947
      INTEGER k_c_sort
 
5948
      INTEGER p6b
 
5949
      INTEGER h7b
 
5950
      INTEGER p6b_1
 
5951
      INTEGER h7b_1
 
5952
      INTEGER p3b_2
 
5953
      INTEGER h7b_2
 
5954
      INTEGER p5b_2
 
5955
      INTEGER p6b_2
 
5956
      INTEGER dim_common
 
5957
      INTEGER dima_sort
 
5958
      INTEGER dima
 
5959
      INTEGER dimb_sort
 
5960
      INTEGER dimb
 
5961
      INTEGER l_a_sort
 
5962
      INTEGER k_a_sort
 
5963
      INTEGER l_a
 
5964
      INTEGER k_a
 
5965
      INTEGER l_b_sort
 
5966
      INTEGER k_b_sort
 
5967
      INTEGER l_b
 
5968
      INTEGER k_b
 
5969
      INTEGER l_c
 
5970
      INTEGER k_c
 
5971
c old way      EXTERNAL NXTASK
 
5972
      nprocs = GA_NNODES()
 
5973
      count = 0
 
5974
c old way      next = NXTASK(nprocs, 1)
 
5975
c --- new way ----
 
5976
      call nxt_ctx_next(ctx, icounter, next)
 
5977
c ----------------
 
5978
      DO p3b = noab+1,noab+nvab
 
5979
      DO p5b = noab+1,noab+nvab
 
5980
      IF (next.eq.count) THEN
 
5981
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
 
5982
     &).ne.4)) THEN
 
5983
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
5984
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
 
5985
     &v,irrep_t)) THEN
 
5986
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1)
 
5987
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
5988
     & ERRQUIT('icsd_t2_5_2',0,MA_ERR)
 
5989
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
5990
      DO p6b = noab+1,noab+nvab
 
5991
      DO h7b = 1,noab
 
5992
      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h7b-1)) THEN
 
5993
      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH
 
5994
     &EN
 
5995
      CALL TCE_RESTRICTED_2(p6b,h7b,p6b_1,h7b_1)
 
5996
      CALL TCE_RESTRICTED_4(p3b,h7b,p5b,p6b,p3b_2,h7b_2,p5b_2,p6b_2)
 
5997
      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1)
 
5998
      dima_sort = 1
 
5999
      dima = dim_common * dima_sort
 
6000
      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1)
 
6001
      dimb = dim_common * dimb_sort
 
6002
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
6003
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
6004
     & ERRQUIT('icsd_t2_5_2',1,MA_ERR)
 
6005
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
6006
     &icsd_t2_5_2',2,MA_ERR)
 
6007
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
6008
     & int_mb(k_a_offset),(h7b_1
 
6009
     & - 1 + noab * (p6b_1 - noab - 1)))
 
6010
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
6011
     &,int_mb(k_range+h7b-1),2,1,1.0d0)
 
6012
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_5_2',3,MA_ERR)
 
6013
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
6014
     & ERRQUIT('icsd_t2_5_2',4,MA_ERR)
 
6015
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
6016
     &icsd_t2_5_2',5,MA_ERR)
 
6017
      IF ((h7b .le. p3b) .and. (p6b .lt. p5b)) THEN
 
6018
      if(.not.intorb) then
 
6019
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
6020
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
6021
     &+nvab) * (h7b_2 - 1)))))
 
6022
      else
 
6023
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
6024
     &(p5b_2
 
6025
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
6026
     &+nvab) * (h7b_2 - 1)))),p5b_2,p6b_2,p3b_2,h7b_2)
 
6027
      end if
 
6028
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
6029
     &,int_mb(k_range+p3b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1)
 
6030
     &,4,2,1,3,-1.0d0)
 
6031
      END IF
 
6032
      IF ((h7b .le. p3b) .and. (p5b .le. p6b)) THEN
 
6033
      if(.not.intorb) then
 
6034
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
6035
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
6036
     &+nvab) * (h7b_2 - 1)))))
 
6037
      else
 
6038
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
6039
     &(p6b_2
 
6040
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
6041
     &+nvab) * (h7b_2 - 1)))),p6b_2,p5b_2,p3b_2,h7b_2)
 
6042
      end if
 
6043
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
6044
     &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1)
 
6045
     &,3,2,1,4,1.0d0)
 
6046
      END IF
 
6047
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_5_2',6,MA_ERR)
 
6048
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
6049
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
6050
     &t),dima_sort)
 
6051
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_5_2',7,MA_E
 
6052
     &RR)
 
6053
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_5_2',8,MA_E
 
6054
     &RR)
 
6055
      END IF
 
6056
      END IF
 
6057
      END IF
 
6058
      END DO
 
6059
      END DO
 
6060
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
6061
     &icsd_t2_5_2',9,MA_ERR)
 
6062
      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
6063
     &,int_mb(k_range+p3b-1),2,1,-1.0d0)
 
6064
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
6065
     & noab - 1 + nvab * (p3b - noab - 1)))
 
6066
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_5_2',10,MA_ERR)
 
6067
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_5_2',11,MA_
 
6068
     &ERR)
 
6069
      END IF
 
6070
      END IF
 
6071
      END IF
 
6072
c old way      next = NXTASK(nprocs, 1)
 
6073
c --- new way ----
 
6074
      call nxt_ctx_next(ctx, icounter, next)
 
6075
c ----------------
 
6076
      END IF
 
6077
      count = count + 1
 
6078
      END DO
 
6079
      END DO
 
6080
c old way      next = NXTASK(-nprocs, 1)
 
6081
c old way      call GA_SYNC()
 
6082
      RETURN
 
6083
      END
 
6084
      SUBROUTINE icsd_t2_5_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
6085
     &t,ctx,icounter)
 
6086
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
6087
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
6088
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
6089
C     i1 ( p3 p5 )_vt + = -1/2 * Sum ( h7 h8 p6 ) * t ( p3 p6 h7 h8 )_t * v ( h7 h8 p5 p6 )_v
 
6090
      IMPLICIT NONE
 
6091
#include "global.fh"
 
6092
#include "mafdecls.fh"
 
6093
#include "sym.fh"
 
6094
#include "errquit.fh"
 
6095
#include "tce.fh"
 
6096
      INTEGER d_a
 
6097
      INTEGER k_a_offset
 
6098
      INTEGER d_b
 
6099
      INTEGER k_b_offset
 
6100
      INTEGER d_c
 
6101
      INTEGER k_c_offset
 
6102
c old way      INTEGER NXTASK
 
6103
c -------------------------
 
6104
      INTEGER ctx,icounter
 
6105
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
6106
c -------------------------
 
6107
      INTEGER next
 
6108
      INTEGER nprocs
 
6109
      INTEGER count
 
6110
      INTEGER p3b
 
6111
      INTEGER p5b
 
6112
      INTEGER dimc
 
6113
      INTEGER l_c_sort
 
6114
      INTEGER k_c_sort
 
6115
      INTEGER p6b
 
6116
      INTEGER h7b
 
6117
      INTEGER h8b
 
6118
      INTEGER p3b_1
 
6119
      INTEGER p6b_1
 
6120
      INTEGER h7b_1
 
6121
      INTEGER h8b_1
 
6122
      INTEGER h7b_2
 
6123
      INTEGER h8b_2
 
6124
      INTEGER p5b_2
 
6125
      INTEGER p6b_2
 
6126
      INTEGER dim_common
 
6127
      INTEGER dima_sort
 
6128
      INTEGER dima
 
6129
      INTEGER dimb_sort
 
6130
      INTEGER dimb
 
6131
      INTEGER l_a_sort
 
6132
      INTEGER k_a_sort
 
6133
      INTEGER l_a
 
6134
      INTEGER k_a
 
6135
      INTEGER l_b_sort
 
6136
      INTEGER k_b_sort
 
6137
      INTEGER l_b
 
6138
      INTEGER k_b
 
6139
      INTEGER nsubh(2)
 
6140
      INTEGER isubh
 
6141
      INTEGER l_c
 
6142
      INTEGER k_c
 
6143
      DOUBLE PRECISION FACTORIAL
 
6144
c old way      EXTERNAL NXTASK
 
6145
      EXTERNAL FACTORIAL
 
6146
      nprocs = GA_NNODES()
 
6147
      count = 0
 
6148
c old way      next = NXTASK(nprocs, 1)
 
6149
c --- new way ----
 
6150
      call nxt_ctx_next(ctx, icounter, next)
 
6151
c ----------------
 
6152
      DO p3b = noab+1,noab+nvab
 
6153
      DO p5b = noab+1,noab+nvab
 
6154
      IF (next.eq.count) THEN
 
6155
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1
 
6156
     &).ne.4)) THEN
 
6157
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
6158
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
 
6159
     &v,irrep_t)) THEN
 
6160
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p5b-1)
 
6161
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
6162
     & ERRQUIT('icsd_t2_5_3',0,MA_ERR)
 
6163
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
6164
      DO p6b = noab+1,noab+nvab
 
6165
      DO h7b = 1,noab
 
6166
      DO h8b = h7b,noab
 
6167
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h
 
6168
     &7b-1)+int_mb(k_spin+h8b-1)) THEN
 
6169
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb(
 
6170
     &k_sym+h7b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_t) THEN
 
6171
      CALL TCE_RESTRICTED_4(p3b,p6b,h7b,h8b,p3b_1,p6b_1,h7b_1,h8b_1)
 
6172
      CALL TCE_RESTRICTED_4(h7b,h8b,p5b,p6b,h7b_2,h8b_2,p5b_2,p6b_2)
 
6173
      dim_common = int_mb(k_range+p6b-1) * int_mb(k_range+h7b-1) * int_m
 
6174
     &b(k_range+h8b-1)
 
6175
      dima_sort = int_mb(k_range+p3b-1)
 
6176
      dima = dim_common * dima_sort
 
6177
      dimb_sort = int_mb(k_range+p5b-1)
 
6178
      dimb = dim_common * dimb_sort
 
6179
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
6180
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
6181
     & ERRQUIT('icsd_t2_5_3',1,MA_ERR)
 
6182
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
6183
     &icsd_t2_5_3',2,MA_ERR)
 
6184
      IF ((p6b .lt. p3b)) THEN
 
6185
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
 
6186
     & - 1 + noab * (h7b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p6b_
 
6187
     &1 - noab - 1)))))
 
6188
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
6189
     &,int_mb(k_range+p3b-1),int_mb(k_range+h7b-1),int_mb(k_range+h8b-1)
 
6190
     &,2,4,3,1,-1.0d0)
 
6191
      END IF
 
6192
      IF ((p3b .le. p6b)) THEN
 
6193
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
 
6194
     & - 1 + noab * (h7b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p3b_
 
6195
     &1 - noab - 1)))))
 
6196
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
6197
     &,int_mb(k_range+p6b-1),int_mb(k_range+h7b-1),int_mb(k_range+h8b-1)
 
6198
     &,1,4,3,2,1.0d0)
 
6199
      END IF
 
6200
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_5_3',3,MA_ERR)
 
6201
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
6202
     & ERRQUIT('icsd_t2_5_3',4,MA_ERR)
 
6203
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
6204
     &icsd_t2_5_3',5,MA_ERR)
 
6205
      IF ((p6b .lt. p5b)) THEN
 
6206
      if(.not.intorb) then
 
6207
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
6208
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
 
6209
     &+nvab) * (h7b_2 - 1)))))
 
6210
      else
 
6211
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
6212
     &(p5b_2
 
6213
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
 
6214
     &+nvab) * (h7b_2 - 1)))),p5b_2,p6b_2,h8b_2,h7b_2)
 
6215
      end if
 
6216
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
6217
     &,int_mb(k_range+h8b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1)
 
6218
     &,4,2,1,3,-1.0d0)
 
6219
      END IF
 
6220
      IF ((p5b .le. p6b)) THEN
 
6221
      if(.not.intorb) then
 
6222
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
6223
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
 
6224
     &+nvab) * (h7b_2 - 1)))))
 
6225
      else
 
6226
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
6227
     &(p6b_2
 
6228
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
 
6229
     &+nvab) * (h7b_2 - 1)))),p6b_2,p5b_2,h8b_2,h7b_2)
 
6230
      end if
 
6231
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1)
 
6232
     &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1)
 
6233
     &,3,2,1,4,1.0d0)
 
6234
      END IF
 
6235
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_5_3',6,MA_ERR)
 
6236
      nsubh(1) = 1
 
6237
      nsubh(2) = 1
 
6238
      isubh = 1
 
6239
      IF (h7b .eq. h8b) THEN
 
6240
      nsubh(isubh) = nsubh(isubh) + 1
 
6241
      ELSE
 
6242
      isubh = isubh + 1
 
6243
      END IF
 
6244
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
 
6245
     &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k
 
6246
     &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
 
6247
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_5_3',7,MA_E
 
6248
     &RR)
 
6249
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_5_3',8,MA_E
 
6250
     &RR)
 
6251
      END IF
 
6252
      END IF
 
6253
      END IF
 
6254
      END DO
 
6255
      END DO
 
6256
      END DO
 
6257
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
6258
     &icsd_t2_5_3',9,MA_ERR)
 
6259
      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
6260
     &,int_mb(k_range+p3b-1),2,1,-1.0d0/2.0d0)
 
6261
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
6262
     & noab - 1 + nvab * (p3b - noab - 1)))
 
6263
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_5_3',10,MA_ERR)
 
6264
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_5_3',11,MA_
 
6265
     &ERR)
 
6266
      END IF
 
6267
      END IF
 
6268
      END IF
 
6269
c old way      next = NXTASK(nprocs, 1)
 
6270
c --- new way ----
 
6271
      call nxt_ctx_next(ctx, icounter, next)
 
6272
c ----------------
 
6273
      END IF
 
6274
      count = count + 1
 
6275
      END DO
 
6276
      END DO
 
6277
c old way      next = NXTASK(-nprocs, 1)
 
6278
c old way      call GA_SYNC()
 
6279
      RETURN
 
6280
      END
 
6281
      SUBROUTINE icsd_t2_6(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset,
 
6282
     &ctx,icounter)
 
6283
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
6284
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
6285
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
6286
C     i0 ( p3 p4 h1 h2 )_vt + = -1/2 * Sum ( h11 h9 ) * t ( p3 p4 h9 h11 )_t * i1 ( h9 h11 h1 h2 )_v
 
6287
      IMPLICIT NONE
 
6288
#include "global.fh"
 
6289
#include "mafdecls.fh"
 
6290
#include "sym.fh"
 
6291
#include "errquit.fh"
 
6292
#include "tce.fh"
 
6293
      INTEGER d_a
 
6294
      INTEGER k_a_offset
 
6295
      INTEGER d_b
 
6296
      INTEGER k_b_offset
 
6297
      INTEGER d_c
 
6298
      INTEGER k_c_offset
 
6299
c old way      INTEGER NXTASK
 
6300
c -------------------------
 
6301
      INTEGER ctx,icounter
 
6302
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
6303
c -------------------------
 
6304
      INTEGER next
 
6305
      INTEGER nprocs
 
6306
      INTEGER count
 
6307
      INTEGER p3b
 
6308
      INTEGER p4b
 
6309
      INTEGER h1b
 
6310
      INTEGER h2b
 
6311
      INTEGER dimc
 
6312
      INTEGER l_c_sort
 
6313
      INTEGER k_c_sort
 
6314
      INTEGER h9b
 
6315
      INTEGER h11b
 
6316
      INTEGER p3b_1
 
6317
      INTEGER p4b_1
 
6318
      INTEGER h9b_1
 
6319
      INTEGER h11b_1
 
6320
      INTEGER h9b_2
 
6321
      INTEGER h11b_2
 
6322
      INTEGER h1b_2
 
6323
      INTEGER h2b_2
 
6324
      INTEGER dim_common
 
6325
      INTEGER dima_sort
 
6326
      INTEGER dima
 
6327
      INTEGER dimb_sort
 
6328
      INTEGER dimb
 
6329
      INTEGER l_a_sort
 
6330
      INTEGER k_a_sort
 
6331
      INTEGER l_a
 
6332
      INTEGER k_a
 
6333
      INTEGER l_b_sort
 
6334
      INTEGER k_b_sort
 
6335
      INTEGER l_b
 
6336
      INTEGER k_b
 
6337
      INTEGER nsubh(2)
 
6338
      INTEGER isubh
 
6339
      INTEGER l_c
 
6340
      INTEGER k_c
 
6341
      DOUBLE PRECISION FACTORIAL
 
6342
c old way      EXTERNAL NXTASK
 
6343
      EXTERNAL FACTORIAL
 
6344
      nprocs = GA_NNODES()
 
6345
      count = 0
 
6346
c old way      next = NXTASK(nprocs, 1)
 
6347
c --- new way ----
 
6348
      call nxt_ctx_next(ctx, icounter, next)
 
6349
c ----------------
 
6350
      DO p3b = noab+1,noab+nvab
 
6351
      DO p4b = p3b,noab+nvab
 
6352
      DO h1b = 1,noab
 
6353
      DO h2b = h1b,noab
 
6354
      IF (next.eq.count) THEN
 
6355
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
6356
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
6357
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
6358
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
6359
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
6360
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
6361
     &EN
 
6362
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
6363
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
6364
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
6365
     & ERRQUIT('icsd_t2_6',0,MA_ERR)
 
6366
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
6367
      DO h9b = 1,noab
 
6368
      DO h11b = h9b,noab
 
6369
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
6370
     &9b-1)+int_mb(k_spin+h11b-1)) THEN
 
6371
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
6372
     &k_sym+h9b-1),int_mb(k_sym+h11b-1)))) .eq. irrep_t) THEN
 
6373
      CALL TCE_RESTRICTED_4(p3b,p4b,h9b,h11b,p3b_1,p4b_1,h9b_1,h11b_1)
 
6374
      CALL TCE_RESTRICTED_4(h9b,h11b,h1b,h2b,h9b_2,h11b_2,h1b_2,h2b_2)
 
6375
      dim_common = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1)
 
6376
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1)
 
6377
      dima = dim_common * dima_sort
 
6378
      dimb_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
6379
      dimb = dim_common * dimb_sort
 
6380
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
6381
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
6382
     & ERRQUIT('icsd_t2_6',1,MA_ERR)
 
6383
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
6384
     &icsd_t2_6',2,MA_ERR)
 
6385
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h11b_
 
6386
     &1 - 1 + noab * (h9b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b
 
6387
     &_1 - noab - 1)))))
 
6388
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
6389
     &,int_mb(k_range+p4b-1),int_mb(k_range+h9b-1),int_mb(k_range+h11b-1
 
6390
     &),2,1,4,3,1.0d0)
 
6391
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_6',3,MA_ERR)
 
6392
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
6393
     & ERRQUIT('icsd_t2_6',4,MA_ERR)
 
6394
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
6395
     &icsd_t2_6',5,MA_ERR)
 
6396
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
 
6397
     & - 1 + noab * (h1b_2 - 1 + noab * (h11b_2 - 1 + noab * (h9b_2 - 1)
 
6398
     &))))
 
6399
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
6400
     &,int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
 
6401
     &),4,3,2,1,1.0d0)
 
6402
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_6',6,MA_ERR)
 
6403
      nsubh(1) = 1
 
6404
      nsubh(2) = 1
 
6405
      isubh = 1
 
6406
      IF (h9b .eq. h11b) THEN
 
6407
      nsubh(isubh) = nsubh(isubh) + 1
 
6408
      ELSE
 
6409
      isubh = isubh + 1
 
6410
      END IF
 
6411
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
 
6412
     &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k
 
6413
     &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
 
6414
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_6',7,MA_ERR
 
6415
     &)
 
6416
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_6',8,MA_ERR
 
6417
     &)
 
6418
      END IF
 
6419
      END IF
 
6420
      END IF
 
6421
      END DO
 
6422
      END DO
 
6423
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
6424
     &icsd_t2_6',9,MA_ERR)
 
6425
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
6426
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
6427
     &,4,3,2,1,-1.0d0/2.0d0)
 
6428
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
6429
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
6430
     & - 1)))))
 
6431
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_6',10,MA_ERR)
 
6432
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_6',11,MA_ER
 
6433
     &R)
 
6434
      END IF
 
6435
      END IF
 
6436
      END IF
 
6437
c old way      next = NXTASK(nprocs, 1)
 
6438
c --- new way ----
 
6439
      call nxt_ctx_next(ctx, icounter, next)
 
6440
c ----------------
 
6441
      END IF
 
6442
      count = count + 1
 
6443
      END DO
 
6444
      END DO
 
6445
      END DO
 
6446
      END DO
 
6447
c old way      next = NXTASK(-nprocs, 1)
 
6448
c old way      call GA_SYNC()
 
6449
      RETURN
 
6450
      END
 
6451
      SUBROUTINE icsd_t2_6_1(d_a,k_a_offset,d_c,k_c_offset,ctx,icounter)
 
6452
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
6453
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
6454
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
6455
C     i1 ( h9 h11 h1 h2 )_v + = -1 * v ( h9 h11 h1 h2 )_v
 
6456
      IMPLICIT NONE
 
6457
#include "global.fh"
 
6458
#include "mafdecls.fh"
 
6459
#include "sym.fh"
 
6460
#include "errquit.fh"
 
6461
#include "tce.fh"
 
6462
      INTEGER d_a
 
6463
      INTEGER k_a_offset
 
6464
      INTEGER d_c
 
6465
      INTEGER k_c_offset
 
6466
c old way      INTEGER NXTASK
 
6467
c -------------------------
 
6468
      INTEGER ctx,icounter
 
6469
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
6470
c -------------------------
 
6471
      INTEGER next
 
6472
      INTEGER nprocs
 
6473
      INTEGER count
 
6474
      INTEGER h9b
 
6475
      INTEGER h11b
 
6476
      INTEGER h1b
 
6477
      INTEGER h2b
 
6478
      INTEGER dimc
 
6479
      INTEGER h9b_1
 
6480
      INTEGER h11b_1
 
6481
      INTEGER h1b_1
 
6482
      INTEGER h2b_1
 
6483
      INTEGER dim_common
 
6484
      INTEGER dima_sort
 
6485
      INTEGER dima
 
6486
      INTEGER l_a_sort
 
6487
      INTEGER k_a_sort
 
6488
      INTEGER l_a
 
6489
      INTEGER k_a
 
6490
      INTEGER l_c
 
6491
      INTEGER k_c
 
6492
c old way      EXTERNAL NXTASK
 
6493
      nprocs = GA_NNODES()
 
6494
      count = 0
 
6495
c old way      next = NXTASK(nprocs, 1)
 
6496
c --- new way ----
 
6497
      call nxt_ctx_next(ctx, icounter, next)
 
6498
c ----------------
 
6499
      DO h9b = 1,noab
 
6500
      DO h11b = h9b,noab
 
6501
      DO h1b = 1,noab
 
6502
      DO h2b = h1b,noab
 
6503
      IF (next.eq.count) THEN
 
6504
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-
 
6505
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
6506
      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+
 
6507
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
6508
      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb
 
6509
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
 
6510
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_mb(k_r
 
6511
     &ange+h1b-1) * int_mb(k_range+h2b-1)
 
6512
      CALL TCE_RESTRICTED_4(h9b,h11b,h1b,h2b,h9b_1,h11b_1,h1b_1,h2b_1)
 
6513
      dim_common = 1
 
6514
      dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_m
 
6515
     &b(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
6516
      dima = dim_common * dima_sort
 
6517
      IF (dima .gt. 0) THEN
 
6518
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
6519
     & ERRQUIT('icsd_t2_6_1',0,MA_ERR)
 
6520
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
6521
     &icsd_t2_6_1',1,MA_ERR)
 
6522
      if(.not.intorb) then
 
6523
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
6524
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa
 
6525
     &b+nvab) * (h9b_1 - 1)))))
 
6526
      else
 
6527
      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
 
6528
     &(h2b_1
 
6529
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa
 
6530
     &b+nvab) * (h9b_1 - 1)))),h2b_1,h1b_1,h11b_1,h9b_1)
 
6531
      end if
 
6532
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1)
 
6533
     &,int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1
 
6534
     &),4,3,2,1,1.0d0)
 
6535
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_6_1',2,MA_ERR)
 
6536
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
6537
     &icsd_t2_6_1',3,MA_ERR)
 
6538
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
6539
     &,int_mb(k_range+h1b-1),int_mb(k_range+h11b-1),int_mb(k_range+h9b-1
 
6540
     &),4,3,2,1,-1.0d0)
 
6541
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
6542
     & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h9b - 1)))))
 
6543
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_6_1',4,MA_ERR)
 
6544
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_6_1',5,MA_E
 
6545
     &RR)
 
6546
      END IF
 
6547
      END IF
 
6548
      END IF
 
6549
      END IF
 
6550
c old way      next = NXTASK(nprocs, 1)
 
6551
c --- new way ----
 
6552
      call nxt_ctx_next(ctx, icounter, next)
 
6553
c ----------------
 
6554
      END IF
 
6555
      count = count + 1
 
6556
      END DO
 
6557
      END DO
 
6558
      END DO
 
6559
      END DO
 
6560
c old way      next = NXTASK(-nprocs, 1)
 
6561
c old way      call GA_SYNC()
 
6562
      RETURN
 
6563
      END
 
6564
      SUBROUTINE OFFSET_icsd_t2_6_1(l_a_offset,k_a_offset,size)
 
6565
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
6566
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
6567
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
6568
C     i1 ( h9 h11 h1 h2 )_v
 
6569
      IMPLICIT NONE
 
6570
#include "global.fh"
 
6571
#include "mafdecls.fh"
 
6572
#include "sym.fh"
 
6573
#include "errquit.fh"
 
6574
#include "tce.fh"
 
6575
      INTEGER l_a_offset
 
6576
      INTEGER k_a_offset
 
6577
      INTEGER size
 
6578
      INTEGER length
 
6579
      INTEGER addr
 
6580
      INTEGER h9b
 
6581
      INTEGER h11b
 
6582
      INTEGER h1b
 
6583
      INTEGER h2b
 
6584
      length = 0
 
6585
      DO h9b = 1,noab
 
6586
      DO h11b = h9b,noab
 
6587
      DO h1b = 1,noab
 
6588
      DO h2b = h1b,noab
 
6589
      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+
 
6590
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
6591
      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb
 
6592
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
 
6593
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-
 
6594
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
6595
      length = length + 1
 
6596
      END IF
 
6597
      END IF
 
6598
      END IF
 
6599
      END DO
 
6600
      END DO
 
6601
      END DO
 
6602
      END DO
 
6603
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
6604
     &set)) CALL ERRQUIT('icsd_t2_6_1',0,MA_ERR)
 
6605
      int_mb(k_a_offset) = length
 
6606
      addr = 0
 
6607
      size = 0
 
6608
      DO h9b = 1,noab
 
6609
      DO h11b = h9b,noab
 
6610
      DO h1b = 1,noab
 
6611
      DO h2b = h1b,noab
 
6612
      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+
 
6613
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
6614
      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb
 
6615
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_v) THEN
 
6616
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-
 
6617
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
6618
      addr = addr + 1
 
6619
      int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h11b
 
6620
     & - 1 + noab * (h9b - 1)))
 
6621
      int_mb(k_a_offset+length+addr) = size
 
6622
      size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int
 
6623
     &_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
6624
      END IF
 
6625
      END IF
 
6626
      END IF
 
6627
      END DO
 
6628
      END DO
 
6629
      END DO
 
6630
      END DO
 
6631
      RETURN
 
6632
      END
 
6633
      SUBROUTINE icsd_t2_6_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
6634
     &t,ctx,icounter)
 
6635
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
6636
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
6637
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
6638
C     i1 ( h9 h11 h1 h2 )_vt + = 1 * P( 2 ) * Sum ( p8 ) * t ( p8 h1 )_t * i2 ( h9 h11 h2 p8 )_v
 
6639
      IMPLICIT NONE
 
6640
#include "global.fh"
 
6641
#include "mafdecls.fh"
 
6642
#include "sym.fh"
 
6643
#include "errquit.fh"
 
6644
#include "tce.fh"
 
6645
      INTEGER d_a
 
6646
      INTEGER k_a_offset
 
6647
      INTEGER d_b
 
6648
      INTEGER k_b_offset
 
6649
      INTEGER d_c
 
6650
      INTEGER k_c_offset
 
6651
c old way      INTEGER NXTASK
 
6652
c -------------------------
 
6653
      INTEGER ctx,icounter
 
6654
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
6655
c -------------------------
 
6656
      INTEGER next
 
6657
      INTEGER nprocs
 
6658
      INTEGER count
 
6659
      INTEGER h9b
 
6660
      INTEGER h11b
 
6661
      INTEGER h1b
 
6662
      INTEGER h2b
 
6663
      INTEGER dimc
 
6664
      INTEGER l_c_sort
 
6665
      INTEGER k_c_sort
 
6666
      INTEGER p8b
 
6667
      INTEGER p8b_1
 
6668
      INTEGER h1b_1
 
6669
      INTEGER h9b_2
 
6670
      INTEGER h11b_2
 
6671
      INTEGER h2b_2
 
6672
      INTEGER p8b_2
 
6673
      INTEGER dim_common
 
6674
      INTEGER dima_sort
 
6675
      INTEGER dima
 
6676
      INTEGER dimb_sort
 
6677
      INTEGER dimb
 
6678
      INTEGER l_a_sort
 
6679
      INTEGER k_a_sort
 
6680
      INTEGER l_a
 
6681
      INTEGER k_a
 
6682
      INTEGER l_b_sort
 
6683
      INTEGER k_b_sort
 
6684
      INTEGER l_b
 
6685
      INTEGER k_b
 
6686
      INTEGER l_c
 
6687
      INTEGER k_c
 
6688
c old way      EXTERNAL NXTASK
 
6689
      nprocs = GA_NNODES()
 
6690
      count = 0
 
6691
c old way      next = NXTASK(nprocs, 1)
 
6692
c --- new way ----
 
6693
      call nxt_ctx_next(ctx, icounter, next)
 
6694
c ----------------
 
6695
      DO h9b = 1,noab
 
6696
      DO h11b = h9b,noab
 
6697
      DO h1b = 1,noab
 
6698
      DO h2b = 1,noab
 
6699
      IF (next.eq.count) THEN
 
6700
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-
 
6701
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
6702
      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+
 
6703
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
6704
      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb
 
6705
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T
 
6706
     &HEN
 
6707
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_mb(k_r
 
6708
     &ange+h1b-1) * int_mb(k_range+h2b-1)
 
6709
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
6710
     & ERRQUIT('icsd_t2_6_2',0,MA_ERR)
 
6711
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
6712
      DO p8b = noab+1,noab+nvab
 
6713
      IF (int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
6714
      IF (ieor(int_mb(k_sym+p8b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
6715
     &EN
 
6716
      CALL TCE_RESTRICTED_2(p8b,h1b,p8b_1,h1b_1)
 
6717
      CALL TCE_RESTRICTED_4(h9b,h11b,h2b,p8b,h9b_2,h11b_2,h2b_2,p8b_2)
 
6718
      dim_common = int_mb(k_range+p8b-1)
 
6719
      dima_sort = int_mb(k_range+h1b-1)
 
6720
      dima = dim_common * dima_sort
 
6721
      dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_m
 
6722
     &b(k_range+h2b-1)
 
6723
      dimb = dim_common * dimb_sort
 
6724
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
6725
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
6726
     & ERRQUIT('icsd_t2_6_2',1,MA_ERR)
 
6727
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
6728
     &icsd_t2_6_2',2,MA_ERR)
 
6729
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
6730
     & int_mb(k_a_offset),(h1b_1
 
6731
     & - 1 + noab * (p8b_1 - noab - 1)))
 
6732
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1)
 
6733
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
6734
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_6_2',3,MA_ERR)
 
6735
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
6736
     & ERRQUIT('icsd_t2_6_2',4,MA_ERR)
 
6737
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
6738
     &icsd_t2_6_2',5,MA_ERR)
 
6739
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
 
6740
     & - noab - 1 + nvab * (h2b_2 - 1 + noab * (h11b_2 - 1 + noab * (h9b
 
6741
     &_2 - 1)))))
 
6742
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
6743
     &,int_mb(k_range+h11b-1),int_mb(k_range+h2b-1),int_mb(k_range+p8b-1
 
6744
     &),3,2,1,4,1.0d0)
 
6745
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_6_2',6,MA_ERR)
 
6746
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
6747
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
6748
     &t),dima_sort)
 
6749
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_6_2',7,MA_E
 
6750
     &RR)
 
6751
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_6_2',8,MA_E
 
6752
     &RR)
 
6753
      END IF
 
6754
      END IF
 
6755
      END IF
 
6756
      END DO
 
6757
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
6758
     &icsd_t2_6_2',9,MA_ERR)
 
6759
      IF ((h1b .le. h2b)) THEN
 
6760
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
6761
     &,int_mb(k_range+h11b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1
 
6762
     &),3,2,4,1,1.0d0)
 
6763
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
6764
     & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h9b - 1)))))
 
6765
      END IF
 
6766
      IF ((h2b .le. h1b)) THEN
 
6767
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
6768
     &,int_mb(k_range+h11b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1
 
6769
     &),3,2,1,4,-1.0d0)
 
6770
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
6771
     & 1 + noab * (h2b - 1 + noab * (h11b - 1 + noab * (h9b - 1)))))
 
6772
      END IF
 
6773
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_6_2',10,MA_ERR)
 
6774
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_6_2',11,MA_
 
6775
     &ERR)
 
6776
      END IF
 
6777
      END IF
 
6778
      END IF
 
6779
c old way      next = NXTASK(nprocs, 1)
 
6780
c --- new way ----
 
6781
      call nxt_ctx_next(ctx, icounter, next)
 
6782
c ----------------
 
6783
      END IF
 
6784
      count = count + 1
 
6785
      END DO
 
6786
      END DO
 
6787
      END DO
 
6788
      END DO
 
6789
c old way      next = NXTASK(-nprocs, 1)
 
6790
c old way      call GA_SYNC()
 
6791
      RETURN
 
6792
      END
 
6793
      SUBROUTINE icsd_t2_6_2_1(d_a,k_a_offset,d_c,k_c_offset,
 
6794
     &ctx,icounter)
 
6795
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
6796
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
6797
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
6798
C     i2 ( h9 h11 h1 p8 )_v + = 1 * v ( h9 h11 h1 p8 )_v
 
6799
      IMPLICIT NONE
 
6800
#include "global.fh"
 
6801
#include "mafdecls.fh"
 
6802
#include "sym.fh"
 
6803
#include "errquit.fh"
 
6804
#include "tce.fh"
 
6805
      INTEGER d_a
 
6806
      INTEGER k_a_offset
 
6807
      INTEGER d_c
 
6808
      INTEGER k_c_offset
 
6809
c old way      INTEGER NXTASK
 
6810
c -------------------------
 
6811
      INTEGER ctx,icounter
 
6812
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
6813
c -------------------------
 
6814
      INTEGER next
 
6815
      INTEGER nprocs
 
6816
      INTEGER count
 
6817
      INTEGER h9b
 
6818
      INTEGER h11b
 
6819
      INTEGER h1b
 
6820
      INTEGER p8b
 
6821
      INTEGER dimc
 
6822
      INTEGER h9b_1
 
6823
      INTEGER h11b_1
 
6824
      INTEGER h1b_1
 
6825
      INTEGER p8b_1
 
6826
      INTEGER dim_common
 
6827
      INTEGER dima_sort
 
6828
      INTEGER dima
 
6829
      INTEGER l_a_sort
 
6830
      INTEGER k_a_sort
 
6831
      INTEGER l_a
 
6832
      INTEGER k_a
 
6833
      INTEGER l_c
 
6834
      INTEGER k_c
 
6835
c old way      EXTERNAL NXTASK
 
6836
      nprocs = GA_NNODES()
 
6837
      count = 0
 
6838
c old way      next = NXTASK(nprocs, 1)
 
6839
c --- new way ----
 
6840
      call nxt_ctx_next(ctx, icounter, next)
 
6841
c ----------------
 
6842
      DO h9b = 1,noab
 
6843
      DO h11b = h9b,noab
 
6844
      DO h1b = 1,noab
 
6845
      DO p8b = noab+1,noab+nvab
 
6846
      IF (next.eq.count) THEN
 
6847
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-
 
6848
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN
 
6849
      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+
 
6850
     &h1b-1)+int_mb(k_spin+p8b-1)) THEN
 
6851
      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb
 
6852
     &(k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN
 
6853
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_mb(k_r
 
6854
     &ange+h1b-1) * int_mb(k_range+p8b-1)
 
6855
      CALL TCE_RESTRICTED_4(h9b,h11b,h1b,p8b,h9b_1,h11b_1,h1b_1,p8b_1)
 
6856
      dim_common = 1
 
6857
      dima_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_m
 
6858
     &b(k_range+h1b-1) * int_mb(k_range+p8b-1)
 
6859
      dima = dim_common * dima_sort
 
6860
      IF (dima .gt. 0) THEN
 
6861
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
6862
     & ERRQUIT('icsd_t2_6_2_1',0,MA_ERR)
 
6863
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
6864
     &icsd_t2_6_2_1',1,MA_ERR)
 
6865
      IF ((h1b .le. p8b)) THEN
 
6866
      if(.not.intorb) then
 
6867
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p8b_1
 
6868
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa
 
6869
     &b+nvab) * (h9b_1 - 1)))))
 
6870
      else
 
6871
      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
 
6872
     &(p8b_1
 
6873
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (h11b_1 - 1 + (noa
 
6874
     &b+nvab) * (h9b_1 - 1)))),p8b_1,h1b_1,h11b_1,h9b_1)
 
6875
      end if
 
6876
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h9b-1)
 
6877
     &,int_mb(k_range+h11b-1),int_mb(k_range+h1b-1),int_mb(k_range+p8b-1
 
6878
     &),4,3,2,1,1.0d0)
 
6879
      END IF
 
6880
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_6_2_1',2,MA_ERR)
 
6881
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
6882
     &icsd_t2_6_2_1',3,MA_ERR)
 
6883
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
 
6884
     &,int_mb(k_range+h1b-1),int_mb(k_range+h11b-1),int_mb(k_range+h9b-1
 
6885
     &),4,3,2,1,1.0d0)
 
6886
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
 
6887
     & noab - 1 + nvab * (h1b - 1 + noab * (h11b - 1 + noab * (h9b - 1))
 
6888
     &)))
 
6889
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_6_2_1',4,MA_ERR)
 
6890
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_6_2_1',5,MA
 
6891
     &_ERR)
 
6892
      END IF
 
6893
      END IF
 
6894
      END IF
 
6895
      END IF
 
6896
c old way      next = NXTASK(nprocs, 1)
 
6897
c --- new way ----
 
6898
      call nxt_ctx_next(ctx, icounter, next)
 
6899
c ----------------
 
6900
      END IF
 
6901
      count = count + 1
 
6902
      END DO
 
6903
      END DO
 
6904
      END DO
 
6905
      END DO
 
6906
c old way      next = NXTASK(-nprocs, 1)
 
6907
c old way      call GA_SYNC()
 
6908
      RETURN
 
6909
      END
 
6910
      SUBROUTINE OFFSET_icsd_t2_6_2_1(l_a_offset,k_a_offset,size)
 
6911
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
6912
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
6913
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
6914
C     i2 ( h9 h11 h1 p8 )_v
 
6915
      IMPLICIT NONE
 
6916
#include "global.fh"
 
6917
#include "mafdecls.fh"
 
6918
#include "sym.fh"
 
6919
#include "errquit.fh"
 
6920
#include "tce.fh"
 
6921
      INTEGER l_a_offset
 
6922
      INTEGER k_a_offset
 
6923
      INTEGER size
 
6924
      INTEGER length
 
6925
      INTEGER addr
 
6926
      INTEGER h9b
 
6927
      INTEGER h11b
 
6928
      INTEGER h1b
 
6929
      INTEGER p8b
 
6930
      length = 0
 
6931
      DO h9b = 1,noab
 
6932
      DO h11b = h9b,noab
 
6933
      DO h1b = 1,noab
 
6934
      DO p8b = noab+1,noab+nvab
 
6935
      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+
 
6936
     &h1b-1)+int_mb(k_spin+p8b-1)) THEN
 
6937
      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb
 
6938
     &(k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN
 
6939
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-
 
6940
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN
 
6941
      length = length + 1
 
6942
      END IF
 
6943
      END IF
 
6944
      END IF
 
6945
      END DO
 
6946
      END DO
 
6947
      END DO
 
6948
      END DO
 
6949
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
6950
     &set)) CALL ERRQUIT('icsd_t2_6_2_1',0,MA_ERR)
 
6951
      int_mb(k_a_offset) = length
 
6952
      addr = 0
 
6953
      size = 0
 
6954
      DO h9b = 1,noab
 
6955
      DO h11b = h9b,noab
 
6956
      DO h1b = 1,noab
 
6957
      DO p8b = noab+1,noab+nvab
 
6958
      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+
 
6959
     &h1b-1)+int_mb(k_spin+p8b-1)) THEN
 
6960
      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb
 
6961
     &(k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. irrep_v) THEN
 
6962
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-
 
6963
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN
 
6964
      addr = addr + 1
 
6965
      int_mb(k_a_offset+addr) = p8b - noab - 1 + nvab * (h1b - 1 + noab 
 
6966
     &* (h11b - 1 + noab * (h9b - 1)))
 
6967
      int_mb(k_a_offset+length+addr) = size
 
6968
      size = size + int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int
 
6969
     &_mb(k_range+h1b-1) * int_mb(k_range+p8b-1)
 
6970
      END IF
 
6971
      END IF
 
6972
      END IF
 
6973
      END DO
 
6974
      END DO
 
6975
      END DO
 
6976
      END DO
 
6977
      RETURN
 
6978
      END
 
6979
      SUBROUTINE icsd_t2_6_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_off
 
6980
     &set,ctx,icounter)
 
6981
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
6982
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
6983
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
6984
C     i2 ( h9 h11 h1 p8 )_vt + = 1/2 * Sum ( p6 ) * t ( p6 h1 )_t * v ( h9 h11 p6 p8 )_v
 
6985
      IMPLICIT NONE
 
6986
#include "global.fh"
 
6987
#include "mafdecls.fh"
 
6988
#include "sym.fh"
 
6989
#include "errquit.fh"
 
6990
#include "tce.fh"
 
6991
      INTEGER d_a
 
6992
      INTEGER k_a_offset
 
6993
      INTEGER d_b
 
6994
      INTEGER k_b_offset
 
6995
      INTEGER d_c
 
6996
      INTEGER k_c_offset
 
6997
c old way      INTEGER NXTASK
 
6998
c -------------------------
 
6999
      INTEGER ctx,icounter
 
7000
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
7001
c -------------------------
 
7002
      INTEGER next
 
7003
      INTEGER nprocs
 
7004
      INTEGER count
 
7005
      INTEGER h9b
 
7006
      INTEGER h11b
 
7007
      INTEGER h1b
 
7008
      INTEGER p8b
 
7009
      INTEGER dimc
 
7010
      INTEGER l_c_sort
 
7011
      INTEGER k_c_sort
 
7012
      INTEGER p6b
 
7013
      INTEGER p6b_1
 
7014
      INTEGER h1b_1
 
7015
      INTEGER h9b_2
 
7016
      INTEGER h11b_2
 
7017
      INTEGER p8b_2
 
7018
      INTEGER p6b_2
 
7019
      INTEGER dim_common
 
7020
      INTEGER dima_sort
 
7021
      INTEGER dima
 
7022
      INTEGER dimb_sort
 
7023
      INTEGER dimb
 
7024
      INTEGER l_a_sort
 
7025
      INTEGER k_a_sort
 
7026
      INTEGER l_a
 
7027
      INTEGER k_a
 
7028
      INTEGER l_b_sort
 
7029
      INTEGER k_b_sort
 
7030
      INTEGER l_b
 
7031
      INTEGER k_b
 
7032
      INTEGER l_c
 
7033
      INTEGER k_c
 
7034
c old way      EXTERNAL NXTASK
 
7035
      nprocs = GA_NNODES()
 
7036
      count = 0
 
7037
c old way      next = NXTASK(nprocs, 1)
 
7038
c --- new way ----
 
7039
      call nxt_ctx_next(ctx, icounter, next)
 
7040
c ----------------
 
7041
      DO h9b = 1,noab
 
7042
      DO h11b = h9b,noab
 
7043
      DO h1b = 1,noab
 
7044
      DO p8b = noab+1,noab+nvab
 
7045
      IF (next.eq.count) THEN
 
7046
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-
 
7047
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p8b-1).ne.8)) THEN
 
7048
      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+
 
7049
     &h1b-1)+int_mb(k_spin+p8b-1)) THEN
 
7050
      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb
 
7051
     &(k_sym+h1b-1),int_mb(k_sym+p8b-1)))) .eq. ieor(irrep_v,irrep_t)) T
 
7052
     &HEN
 
7053
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_mb(k_r
 
7054
     &ange+h1b-1) * int_mb(k_range+p8b-1)
 
7055
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
7056
     & ERRQUIT('icsd_t2_6_2_2',0,MA_ERR)
 
7057
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
7058
      DO p6b = noab+1,noab+nvab
 
7059
      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
7060
      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
7061
     &EN
 
7062
      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
 
7063
      CALL TCE_RESTRICTED_4(h9b,h11b,p8b,p6b,h9b_2,h11b_2,p8b_2,p6b_2)
 
7064
      dim_common = int_mb(k_range+p6b-1)
 
7065
      dima_sort = int_mb(k_range+h1b-1)
 
7066
      dima = dim_common * dima_sort
 
7067
      dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_m
 
7068
     &b(k_range+p8b-1)
 
7069
      dimb = dim_common * dimb_sort
 
7070
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
7071
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
7072
     & ERRQUIT('icsd_t2_6_2_2',1,MA_ERR)
 
7073
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
7074
     &icsd_t2_6_2_2',2,MA_ERR)
 
7075
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
7076
     & int_mb(k_a_offset),(h1b_1
 
7077
     & - 1 + noab * (p6b_1 - noab - 1)))
 
7078
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
7079
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
7080
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_6_2_2',3,MA_ERR)
 
7081
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
7082
     & ERRQUIT('icsd_t2_6_2_2',4,MA_ERR)
 
7083
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
7084
     &icsd_t2_6_2_2',5,MA_ERR)
 
7085
      IF ((p6b .le. p8b)) THEN
 
7086
      if(.not.intorb) then
 
7087
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
 
7088
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
7089
     &b+nvab) * (h9b_2 - 1)))))
 
7090
      else
 
7091
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
7092
     &(p8b_2
 
7093
     & - 1 + (noab+nvab) * (p6b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
7094
     &b+nvab) * (h9b_2 - 1)))),p8b_2,p6b_2,h11b_2,h9b_2)
 
7095
      end if
 
7096
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
7097
     &,int_mb(k_range+h11b-1),int_mb(k_range+p6b-1),int_mb(k_range+p8b-1
 
7098
     &),4,2,1,3,1.0d0)
 
7099
      END IF
 
7100
      IF ((p8b .lt. p6b)) THEN
 
7101
      if(.not.intorb) then
 
7102
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
7103
     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
7104
     &b+nvab) * (h9b_2 - 1)))))
 
7105
      else
 
7106
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
7107
     &(p6b_2
 
7108
     & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
7109
     &b+nvab) * (h9b_2 - 1)))),p6b_2,p8b_2,h11b_2,h9b_2)
 
7110
      end if
 
7111
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
7112
     &,int_mb(k_range+h11b-1),int_mb(k_range+p8b-1),int_mb(k_range+p6b-1
 
7113
     &),3,2,1,4,-1.0d0)
 
7114
      END IF
 
7115
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_6_2_2',6,MA_ERR)
 
7116
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
7117
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
7118
     &t),dima_sort)
 
7119
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_6_2_2',7,MA
 
7120
     &_ERR)
 
7121
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_6_2_2',8,MA
 
7122
     &_ERR)
 
7123
      END IF
 
7124
      END IF
 
7125
      END IF
 
7126
      END DO
 
7127
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
7128
     &icsd_t2_6_2_2',9,MA_ERR)
 
7129
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p8b-1)
 
7130
     &,int_mb(k_range+h11b-1),int_mb(k_range+h9b-1),int_mb(k_range+h1b-1
 
7131
     &),3,2,4,1,1.0d0/2.0d0)
 
7132
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p8b -
 
7133
     & noab - 1 + nvab * (h1b - 1 + noab * (h11b - 1 + noab * (h9b - 1))
 
7134
     &)))
 
7135
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_6_2_2',10,MA_ERR
 
7136
     &)
 
7137
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_6_2_2',11,M
 
7138
     &A_ERR)
 
7139
      END IF
 
7140
      END IF
 
7141
      END IF
 
7142
c old way      next = NXTASK(nprocs, 1)
 
7143
c --- new way ----
 
7144
      call nxt_ctx_next(ctx, icounter, next)
 
7145
c ----------------
 
7146
      END IF
 
7147
      count = count + 1
 
7148
      END DO
 
7149
      END DO
 
7150
      END DO
 
7151
      END DO
 
7152
c old way      next = NXTASK(-nprocs, 1)
 
7153
c old way      call GA_SYNC()
 
7154
      RETURN
 
7155
      END
 
7156
      SUBROUTINE icsd_t2_6_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
7157
     &t,ctx,icounter)
 
7158
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
7159
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
7160
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
7161
C     i1 ( h9 h11 h1 h2 )_vt + = -1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( h9 h11 p5 p6 )_v
 
7162
      IMPLICIT NONE
 
7163
#include "global.fh"
 
7164
#include "mafdecls.fh"
 
7165
#include "sym.fh"
 
7166
#include "errquit.fh"
 
7167
#include "tce.fh"
 
7168
      INTEGER d_a
 
7169
      INTEGER k_a_offset
 
7170
      INTEGER d_b
 
7171
      INTEGER k_b_offset
 
7172
      INTEGER d_c
 
7173
      INTEGER k_c_offset
 
7174
c old way      INTEGER NXTASK
 
7175
c -------------------------
 
7176
      INTEGER ctx,icounter
 
7177
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
7178
c -------------------------
 
7179
      INTEGER next
 
7180
      INTEGER nprocs
 
7181
      INTEGER count
 
7182
      INTEGER h9b
 
7183
      INTEGER h11b
 
7184
      INTEGER h1b
 
7185
      INTEGER h2b
 
7186
      INTEGER dimc
 
7187
      INTEGER l_c_sort
 
7188
      INTEGER k_c_sort
 
7189
      INTEGER p5b
 
7190
      INTEGER p6b
 
7191
      INTEGER p5b_1
 
7192
      INTEGER p6b_1
 
7193
      INTEGER h1b_1
 
7194
      INTEGER h2b_1
 
7195
      INTEGER h9b_2
 
7196
      INTEGER h11b_2
 
7197
      INTEGER p5b_2
 
7198
      INTEGER p6b_2
 
7199
      INTEGER dim_common
 
7200
      INTEGER dima_sort
 
7201
      INTEGER dima
 
7202
      INTEGER dimb_sort
 
7203
      INTEGER dimb
 
7204
      INTEGER l_a_sort
 
7205
      INTEGER k_a_sort
 
7206
      INTEGER l_a
 
7207
      INTEGER k_a
 
7208
      INTEGER l_b_sort
 
7209
      INTEGER k_b_sort
 
7210
      INTEGER l_b
 
7211
      INTEGER k_b
 
7212
      INTEGER nsuperp(2)
 
7213
      INTEGER isuperp
 
7214
      INTEGER l_c
 
7215
      INTEGER k_c
 
7216
      DOUBLE PRECISION FACTORIAL
 
7217
c old way      EXTERNAL NXTASK
 
7218
      EXTERNAL FACTORIAL
 
7219
      nprocs = GA_NNODES()
 
7220
      count = 0
 
7221
c old way      next = NXTASK(nprocs, 1)
 
7222
c --- new way ----
 
7223
      call nxt_ctx_next(ctx, icounter, next)
 
7224
c ----------------
 
7225
      DO h9b = 1,noab
 
7226
      DO h11b = h9b,noab
 
7227
      DO h1b = 1,noab
 
7228
      DO h2b = h1b,noab
 
7229
      IF (next.eq.count) THEN
 
7230
      IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-
 
7231
     &1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
7232
      IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+
 
7233
     &h1b-1)+int_mb(k_spin+h2b-1)) THEN
 
7234
      IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb
 
7235
     &(k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) T
 
7236
     &HEN
 
7237
      dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1) * int_mb(k_r
 
7238
     &ange+h1b-1) * int_mb(k_range+h2b-1)
 
7239
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
7240
     & ERRQUIT('icsd_t2_6_3',0,MA_ERR)
 
7241
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
7242
      DO p5b = noab+1,noab+nvab
 
7243
      DO p6b = p5b,noab+nvab
 
7244
      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h
 
7245
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
7246
      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb(
 
7247
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
 
7248
      CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1)
 
7249
      CALL TCE_RESTRICTED_4(h9b,h11b,p5b,p6b,h9b_2,h11b_2,p5b_2,p6b_2)
 
7250
      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1)
 
7251
      dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
7252
      dima = dim_common * dima_sort
 
7253
      dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h11b-1)
 
7254
      dimb = dim_common * dimb_sort
 
7255
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
7256
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
7257
     & ERRQUIT('icsd_t2_6_3',1,MA_ERR)
 
7258
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
7259
     &icsd_t2_6_3',2,MA_ERR)
 
7260
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
7261
     & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_
 
7262
     &1 - noab - 1)))))
 
7263
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
7264
     &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
7265
     &,4,3,2,1,1.0d0)
 
7266
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_6_3',3,MA_ERR)
 
7267
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
7268
     & ERRQUIT('icsd_t2_6_3',4,MA_ERR)
 
7269
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
7270
     &icsd_t2_6_3',5,MA_ERR)
 
7271
      if(.not.intorb) then
 
7272
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
7273
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
7274
     &b+nvab) * (h9b_2 - 1)))))
 
7275
      else
 
7276
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
7277
     &(p6b_2
 
7278
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h11b_2 - 1 + (noa
 
7279
     &b+nvab) * (h9b_2 - 1)))),p6b_2,p5b_2,h11b_2,h9b_2)
 
7280
      end if
 
7281
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
 
7282
     &,int_mb(k_range+h11b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1
 
7283
     &),2,1,4,3,1.0d0)
 
7284
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_6_3',6,MA_ERR)
 
7285
      nsuperp(1) = 1
 
7286
      nsuperp(2) = 1
 
7287
      isuperp = 1
 
7288
      IF (p5b .eq. p6b) THEN
 
7289
      nsuperp(isuperp) = nsuperp(isuperp) + 1
 
7290
      ELSE
 
7291
      isuperp = isuperp + 1
 
7292
      END IF
 
7293
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
 
7294
     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
 
7295
     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
 
7296
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_6_3',7,MA_E
 
7297
     &RR)
 
7298
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_6_3',8,MA_E
 
7299
     &RR)
 
7300
      END IF
 
7301
      END IF
 
7302
      END IF
 
7303
      END DO
 
7304
      END DO
 
7305
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
7306
     &icsd_t2_6_3',9,MA_ERR)
 
7307
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h11b-1
 
7308
     &),int_mb(k_range+h9b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1
 
7309
     &),2,1,4,3,-1.0d0/2.0d0)
 
7310
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
7311
     & 1 + noab * (h1b - 1 + noab * (h11b - 1 + noab * (h9b - 1)))))
 
7312
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_6_3',10,MA_ERR)
 
7313
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_6_3',11,MA_
 
7314
     &ERR)
 
7315
      END IF
 
7316
      END IF
 
7317
      END IF
 
7318
c old way      next = NXTASK(nprocs, 1)
 
7319
c --- new way ----
 
7320
      call nxt_ctx_next(ctx, icounter, next)
 
7321
c ----------------
 
7322
      END IF
 
7323
      count = count + 1
 
7324
      END DO
 
7325
      END DO
 
7326
      END DO
 
7327
      END DO
 
7328
c old way      next = NXTASK(-nprocs, 1)
 
7329
c old way      call GA_SYNC()
 
7330
      RETURN
 
7331
      END
 
7332
      SUBROUTINE icsd_t2_7(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset,
 
7333
     &ctx,icounter)
 
7334
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
7335
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
7336
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
7337
C     i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 4 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i1 ( h6 p4 h2 p5 )_v
 
7338
      IMPLICIT NONE
 
7339
#include "global.fh"
 
7340
#include "mafdecls.fh"
 
7341
#include "sym.fh"
 
7342
#include "errquit.fh"
 
7343
#include "tce.fh"
 
7344
      INTEGER d_a
 
7345
      INTEGER k_a_offset
 
7346
      INTEGER d_b
 
7347
      INTEGER k_b_offset
 
7348
      INTEGER d_c
 
7349
      INTEGER k_c_offset
 
7350
c old way      INTEGER NXTASK
 
7351
c -------------------------
 
7352
      INTEGER ctx,icounter
 
7353
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
7354
c -------------------------
 
7355
      INTEGER next
 
7356
      INTEGER nprocs
 
7357
      INTEGER count
 
7358
      INTEGER p3b
 
7359
      INTEGER p4b
 
7360
      INTEGER h1b
 
7361
      INTEGER h2b
 
7362
      INTEGER dimc
 
7363
      INTEGER l_c_sort
 
7364
      INTEGER k_c_sort
 
7365
      INTEGER p5b
 
7366
      INTEGER h6b
 
7367
      INTEGER p3b_1
 
7368
      INTEGER p5b_1
 
7369
      INTEGER h1b_1
 
7370
      INTEGER h6b_1
 
7371
      INTEGER p4b_2
 
7372
      INTEGER h6b_2
 
7373
      INTEGER h2b_2
 
7374
      INTEGER p5b_2
 
7375
      INTEGER dim_common
 
7376
      INTEGER dima_sort
 
7377
      INTEGER dima
 
7378
      INTEGER dimb_sort
 
7379
      INTEGER dimb
 
7380
      INTEGER l_a_sort
 
7381
      INTEGER k_a_sort
 
7382
      INTEGER l_a
 
7383
      INTEGER k_a
 
7384
      INTEGER l_b_sort
 
7385
      INTEGER k_b_sort
 
7386
      INTEGER l_b
 
7387
      INTEGER k_b
 
7388
      INTEGER l_c
 
7389
      INTEGER k_c
 
7390
c old way      EXTERNAL NXTASK
 
7391
      nprocs = GA_NNODES()
 
7392
      count = 0
 
7393
c old way      next = NXTASK(nprocs, 1)
 
7394
c --- new way ----
 
7395
      call nxt_ctx_next(ctx, icounter, next)
 
7396
c ----------------
 
7397
      DO p3b = noab+1,noab+nvab
 
7398
      DO p4b = noab+1,noab+nvab
 
7399
      DO h1b = 1,noab
 
7400
      DO h2b = 1,noab
 
7401
      IF (next.eq.count) THEN
 
7402
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
7403
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
7404
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
7405
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
7406
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
7407
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
7408
     &EN
 
7409
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
7410
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
7411
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
7412
     & ERRQUIT('icsd_t2_7',0,MA_ERR)
 
7413
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
7414
      DO p5b = noab+1,noab+nvab
 
7415
      DO h6b = 1,noab
 
7416
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h
 
7417
     &1b-1)+int_mb(k_spin+h6b-1)) THEN
 
7418
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(
 
7419
     &k_sym+h1b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_t) THEN
 
7420
      CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h6b,p3b_1,p5b_1,h1b_1,h6b_1)
 
7421
      CALL TCE_RESTRICTED_4(p4b,h6b,h2b,p5b,p4b_2,h6b_2,h2b_2,p5b_2)
 
7422
      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1)
 
7423
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
 
7424
      dima = dim_common * dima_sort
 
7425
      dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h2b-1)
 
7426
      dimb = dim_common * dimb_sort
 
7427
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
7428
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
7429
     & ERRQUIT('icsd_t2_7',1,MA_ERR)
 
7430
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
7431
     &icsd_t2_7',2,MA_ERR)
 
7432
      IF ((p5b .lt. p3b) .and. (h6b .lt. h1b)) THEN
 
7433
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
7434
     & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
 
7435
     &1 - noab - 1)))))
 
7436
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
7437
     &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1)
 
7438
     &,4,2,3,1,1.0d0)
 
7439
      END IF
 
7440
      IF ((p5b .lt. p3b) .and. (h1b .le. h6b)) THEN
 
7441
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
 
7442
     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_
 
7443
     &1 - noab - 1)))))
 
7444
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
7445
     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1)
 
7446
     &,3,2,4,1,-1.0d0)
 
7447
      END IF
 
7448
      IF ((p3b .le. p5b) .and. (h6b .lt. h1b)) THEN
 
7449
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
7450
     & - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
 
7451
     &1 - noab - 1)))))
 
7452
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
7453
     &,int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1)
 
7454
     &,4,1,3,2,-1.0d0)
 
7455
      END IF
 
7456
      IF ((p3b .le. p5b) .and. (h1b .le. h6b)) THEN
 
7457
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
 
7458
     & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_
 
7459
     &1 - noab - 1)))))
 
7460
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
7461
     &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1)
 
7462
     &,3,1,4,2,1.0d0)
 
7463
      END IF
 
7464
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_7',3,MA_ERR)
 
7465
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
7466
     & ERRQUIT('icsd_t2_7',4,MA_ERR)
 
7467
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
7468
     &icsd_t2_7',5,MA_ERR)
 
7469
c *** peta *****
 
7470
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
7471
     &(h6b_2 -1 + noab * (p5b_2 - noab -1 +nvab * (h2b_2 - 1 + noab *
 
7472
     &( p4b_2 - noab -1 )))))
 
7473
c **************
 
7474
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
 
7475
     &,int_mb(k_range+h6b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1)
 
7476
     &,3,1,2,4,1.0d0)
 
7477
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_7',6,MA_ERR)
 
7478
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
7479
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
7480
     &t),dima_sort)
 
7481
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_7',7,MA_ERR
 
7482
     &)
 
7483
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_7',8,MA_ERR
 
7484
     &)
 
7485
      END IF
 
7486
      END IF
 
7487
      END IF
 
7488
      END DO
 
7489
      END DO
 
7490
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
7491
     &icsd_t2_7',9,MA_ERR)
 
7492
      IF ((p3b .le. p4b) .and. (h1b .le. h2b)) THEN
 
7493
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
7494
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
7495
     &,4,2,3,1,-1.0d0)
 
7496
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
7497
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
7498
     & - 1)))))
 
7499
      END IF
 
7500
      IF ((p3b .le. p4b) .and. (h2b .le. h1b)) THEN
 
7501
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
7502
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
7503
     &,4,2,1,3,1.0d0)
 
7504
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
7505
     & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
7506
     & - 1)))))
 
7507
      END IF
 
7508
      IF ((p4b .le. p3b) .and. (h1b .le. h2b)) THEN
 
7509
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
7510
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
7511
     &,2,4,3,1,1.0d0)
 
7512
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
7513
     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
 
7514
     & - 1)))))
 
7515
      END IF
 
7516
      IF ((p4b .le. p3b) .and. (h2b .le. h1b)) THEN
 
7517
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
7518
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
7519
     &,2,4,1,3,-1.0d0)
 
7520
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
7521
     & 1 + noab * (h2b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
 
7522
     & - 1)))))
 
7523
      END IF
 
7524
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_7',10,MA_ERR)
 
7525
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_7',11,MA_ER
 
7526
     &R)
 
7527
      END IF
 
7528
      END IF
 
7529
      END IF
 
7530
c old way      next = NXTASK(nprocs, 1)
 
7531
c --- new way ----
 
7532
      call nxt_ctx_next(ctx, icounter, next)
 
7533
c ----------------
 
7534
      END IF
 
7535
      count = count + 1
 
7536
      END DO
 
7537
      END DO
 
7538
      END DO
 
7539
      END DO
 
7540
c old way      next = NXTASK(-nprocs, 1)
 
7541
c old way      call GA_SYNC()
 
7542
      RETURN
 
7543
      END
 
7544
      SUBROUTINE icsd_t2_7_1(d_a,k_a_offset,d_c,k_c_offset,ctx,icounter)
 
7545
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
7546
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
7547
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
7548
C     i1 ( h6 p3 h1 p5 )_v + = 1 * v ( h6 p3 h1 p5 )_v
 
7549
      IMPLICIT NONE
 
7550
#include "global.fh"
 
7551
#include "mafdecls.fh"
 
7552
#include "sym.fh"
 
7553
#include "errquit.fh"
 
7554
#include "tce.fh"
 
7555
      INTEGER d_a
 
7556
      INTEGER k_a_offset
 
7557
      INTEGER d_c
 
7558
      INTEGER k_c_offset
 
7559
c old way      INTEGER NXTASK
 
7560
c -------------------------
 
7561
      INTEGER ctx,icounter
 
7562
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
7563
c -------------------------
 
7564
      INTEGER next
 
7565
      INTEGER nprocs
 
7566
      INTEGER count
 
7567
      INTEGER p3b
 
7568
      INTEGER h6b
 
7569
      INTEGER h1b
 
7570
      INTEGER p5b
 
7571
      INTEGER dimc
 
7572
      INTEGER p3b_1
 
7573
      INTEGER h6b_1
 
7574
      INTEGER h1b_1
 
7575
      INTEGER p5b_1
 
7576
      INTEGER dim_common
 
7577
      INTEGER dima_sort
 
7578
      INTEGER dima
 
7579
      INTEGER l_a_sort
 
7580
      INTEGER k_a_sort
 
7581
      INTEGER l_a
 
7582
      INTEGER k_a
 
7583
      INTEGER l_c
 
7584
      INTEGER k_c
 
7585
c old way      EXTERNAL NXTASK
 
7586
      nprocs = GA_NNODES()
 
7587
      count = 0
 
7588
c old way      next = NXTASK(nprocs, 1)
 
7589
c --- new way ----
 
7590
      call nxt_ctx_next(ctx, icounter, next)
 
7591
c ----------------
 
7592
c *** peta ***
 
7593
      DO p3b = noab+1,noab+nvab
 
7594
      DO h1b = 1,noab
 
7595
      DO p5b = noab+1,noab+nvab
 
7596
      DO h6b = 1,noab
 
7597
c ************
 
7598
      IF (next.eq.count) THEN
 
7599
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1
 
7600
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
7601
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h
 
7602
     &1b-1)+int_mb(k_spin+p5b-1)) THEN
 
7603
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb(
 
7604
     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
7605
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra
 
7606
     &nge+h1b-1) * int_mb(k_range+p5b-1)
 
7607
      CALL TCE_RESTRICTED_4(p3b,h6b,h1b,p5b,p3b_1,h6b_1,h1b_1,p5b_1)
 
7608
      dim_common = 1
 
7609
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb
 
7610
     &(k_range+h1b-1) * int_mb(k_range+p5b-1)
 
7611
      dima = dim_common * dima_sort
 
7612
      IF (dima .gt. 0) THEN
 
7613
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
7614
     & ERRQUIT('icsd_t2_7_1',0,MA_ERR)
 
7615
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
7616
     &icsd_t2_7_1',1,MA_ERR)
 
7617
      IF ((h6b .le. p3b) .and. (h1b .le. p5b)) THEN
 
7618
      if(.not.intorb) then
 
7619
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
 
7620
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
 
7621
     &+nvab) * (h6b_1 - 1)))))
 
7622
      else
 
7623
      CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),
 
7624
     &(p5b_1
 
7625
     & - 1 + (noab+nvab) * (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + (noab
 
7626
     &+nvab) * (h6b_1 - 1)))),p5b_1,h1b_1,p3b_1,h6b_1)
 
7627
      end if
 
7628
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1)
 
7629
     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+p5b-1)
 
7630
     &,4,3,1,2,1.0d0)
 
7631
      END IF
 
7632
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_7_1',2,MA_ERR)
 
7633
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
7634
     &icsd_t2_7_1',3,MA_ERR)
 
7635
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
7636
     &,int_mb(k_range+h1b-1),int_mb(k_range+h6b-1),int_mb(k_range+p3b-1)
 
7637
     &,4,3,2,1,1.0d0)
 
7638
c *** peta *****
 
7639
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),
 
7640
     &(h6b -1 + noab * (p5b - noab -1 +nvab * (h1b - 1 + noab * 
 
7641
     &( p3b - noab -1 )))))
 
7642
c **************
 
7643
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_7_1',4,MA_ERR)
 
7644
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_7_1',5,MA_E
 
7645
     &RR)
 
7646
      END IF
 
7647
      END IF
 
7648
      END IF
 
7649
      END IF
 
7650
c old way      next = NXTASK(nprocs, 1)
 
7651
c --- new way ----
 
7652
      call nxt_ctx_next(ctx, icounter, next)
 
7653
c ----------------
 
7654
      END IF
 
7655
      count = count + 1
 
7656
      END DO
 
7657
      END DO
 
7658
      END DO
 
7659
      END DO
 
7660
c old way      next = NXTASK(-nprocs, 1)
 
7661
c old way      call GA_SYNC()
 
7662
      RETURN
 
7663
      END
 
7664
      SUBROUTINE OFFSET_icsd_t2_7_1(l_a_offset,k_a_offset,size)
 
7665
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
7666
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
7667
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
7668
C     i1 ( h6 p3 h1 p5 )_v
 
7669
      IMPLICIT NONE
 
7670
#include "global.fh"
 
7671
#include "mafdecls.fh"
 
7672
#include "sym.fh"
 
7673
#include "errquit.fh"
 
7674
#include "tce.fh"
 
7675
      INTEGER l_a_offset
 
7676
      INTEGER k_a_offset
 
7677
      INTEGER size
 
7678
      INTEGER length
 
7679
      INTEGER addr
 
7680
      INTEGER p3b
 
7681
      INTEGER h6b
 
7682
      INTEGER h1b
 
7683
      INTEGER p5b
 
7684
      length = 0
 
7685
c *** peta ****
 
7686
      DO p3b = noab+1,noab+nvab
 
7687
      DO h1b = 1,noab
 
7688
      DO p5b = noab+1,noab+nvab
 
7689
      DO h6b = 1,noab
 
7690
c *************
 
7691
      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
 
7692
     &1b-1)+int_mb(k_spin+p5b-1)) THEN
 
7693
      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
 
7694
     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
7695
      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1
 
7696
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
7697
      length = length + 1
 
7698
      END IF
 
7699
      END IF
 
7700
      END IF
 
7701
      END DO
 
7702
      END DO
 
7703
      END DO
 
7704
      END DO
 
7705
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
7706
     &set)) CALL ERRQUIT('icsd_t2_7_1',0,MA_ERR)
 
7707
      int_mb(k_a_offset) = length
 
7708
      addr = 0
 
7709
      size = 0
 
7710
c *** peta ***
 
7711
      DO p3b = noab+1,noab+nvab
 
7712
      DO h1b = 1,noab
 
7713
      DO p5b = noab+1,noab+nvab
 
7714
      DO h6b = 1,noab
 
7715
c ************
 
7716
      IF (int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
 
7717
     &1b-1)+int_mb(k_spin+p5b-1)) THEN
 
7718
      IF (ieor(int_mb(k_sym+h6b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
 
7719
     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. irrep_v) THEN
 
7720
      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p3b-1
 
7721
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
7722
      addr = addr + 1
 
7723
c *** peta ***
 
7724
      int_mb(k_a_offset+addr) = h6b -1 + noab * (p5b - noab -1 +nvab * (
 
7725
     &h1b - 1 + noab * ( p3b - noab -1 )))
 
7726
c ************ 
 
7727
      int_mb(k_a_offset+length+addr) = size
 
7728
      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_
 
7729
     &mb(k_range+h1b-1) * int_mb(k_range+p5b-1)
 
7730
      END IF
 
7731
      END IF
 
7732
      END IF
 
7733
      END DO
 
7734
      END DO
 
7735
      END DO
 
7736
      END DO
 
7737
      RETURN
 
7738
      END
 
7739
      SUBROUTINE icsd_t2_7_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
7740
     &t,ctx,icounter)
 
7741
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
7742
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
7743
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
7744
C     i1 ( h6 p3 h1 p5 )_vt + = -1 * Sum ( p7 ) * t ( p7 h1 )_t * v ( h6 p3 p5 p7 )_v
 
7745
      IMPLICIT NONE
 
7746
#include "global.fh"
 
7747
#include "mafdecls.fh"
 
7748
#include "sym.fh"
 
7749
#include "errquit.fh"
 
7750
#include "tce.fh"
 
7751
      INTEGER d_a
 
7752
      INTEGER k_a_offset
 
7753
      INTEGER d_b
 
7754
      INTEGER k_b_offset
 
7755
      INTEGER d_c
 
7756
      INTEGER k_c_offset
 
7757
c old way      INTEGER NXTASK
 
7758
c -------------------------
 
7759
      INTEGER ctx,icounter
 
7760
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
7761
c -------------------------
 
7762
      INTEGER next
 
7763
      INTEGER nprocs
 
7764
      INTEGER count
 
7765
      INTEGER p3b
 
7766
      INTEGER h6b
 
7767
      INTEGER h1b
 
7768
      INTEGER p5b
 
7769
      INTEGER dimc
 
7770
      INTEGER l_c_sort
 
7771
      INTEGER k_c_sort
 
7772
      INTEGER p7b
 
7773
      INTEGER p7b_1
 
7774
      INTEGER h1b_1
 
7775
      INTEGER p3b_2
 
7776
      INTEGER h6b_2
 
7777
      INTEGER p5b_2
 
7778
      INTEGER p7b_2
 
7779
      INTEGER dim_common
 
7780
      INTEGER dima_sort
 
7781
      INTEGER dima
 
7782
      INTEGER dimb_sort
 
7783
      INTEGER dimb
 
7784
      INTEGER l_a_sort
 
7785
      INTEGER k_a_sort
 
7786
      INTEGER l_a
 
7787
      INTEGER k_a
 
7788
      INTEGER l_b_sort
 
7789
      INTEGER k_b_sort
 
7790
      INTEGER l_b
 
7791
      INTEGER k_b
 
7792
      INTEGER l_c
 
7793
      INTEGER k_c
 
7794
c old way      EXTERNAL NXTASK
 
7795
      nprocs = GA_NNODES()
 
7796
      count = 0
 
7797
c old way      next = NXTASK(nprocs, 1)
 
7798
c --- new way ----
 
7799
      call nxt_ctx_next(ctx, icounter, next)
 
7800
c ----------------
 
7801
c *** peta ***
 
7802
      DO p3b = noab+1,noab+nvab
 
7803
      DO h1b = 1,noab
 
7804
      DO p5b = noab+1,noab+nvab
 
7805
      DO h6b = 1,noab
 
7806
c ************
 
7807
      IF (next.eq.count) THEN
 
7808
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1
 
7809
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
7810
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h
 
7811
     &1b-1)+int_mb(k_spin+p5b-1)) THEN
 
7812
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb(
 
7813
     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
7814
     &EN
 
7815
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra
 
7816
     &nge+h1b-1) * int_mb(k_range+p5b-1)
 
7817
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
7818
     & ERRQUIT('icsd_t2_7_2',0,MA_ERR)
 
7819
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
7820
      DO p7b = noab+1,noab+nvab
 
7821
      IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
7822
      IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
7823
     &EN
 
7824
      CALL TCE_RESTRICTED_2(p7b,h1b,p7b_1,h1b_1)
 
7825
      CALL TCE_RESTRICTED_4(p3b,h6b,p5b,p7b,p3b_2,h6b_2,p5b_2,p7b_2)
 
7826
      dim_common = int_mb(k_range+p7b-1)
 
7827
      dima_sort = int_mb(k_range+h1b-1)
 
7828
      dima = dim_common * dima_sort
 
7829
      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb
 
7830
     &(k_range+p5b-1)
 
7831
      dimb = dim_common * dimb_sort
 
7832
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
7833
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
7834
     & ERRQUIT('icsd_t2_7_2',1,MA_ERR)
 
7835
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
7836
     &icsd_t2_7_2',2,MA_ERR)
 
7837
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
7838
     & int_mb(k_a_offset),(h1b_1
 
7839
     & - 1 + noab * (p7b_1 - noab - 1)))
 
7840
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
 
7841
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
7842
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_7_2',3,MA_ERR)
 
7843
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
7844
     & ERRQUIT('icsd_t2_7_2',4,MA_ERR)
 
7845
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
7846
     &icsd_t2_7_2',5,MA_ERR)
 
7847
      IF ((h6b .le. p3b) .and. (p7b .lt. p5b)) THEN
 
7848
      if(.not.intorb) then
 
7849
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
7850
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
7851
     &+nvab) * (h6b_2 - 1)))))
 
7852
      else
 
7853
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
7854
     &(p5b_2
 
7855
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
7856
     &+nvab) * (h6b_2 - 1)))),p5b_2,p7b_2,p3b_2,h6b_2)
 
7857
      end if
 
7858
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
 
7859
     &,int_mb(k_range+p3b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1)
 
7860
     &,4,1,2,3,-1.0d0)
 
7861
      END IF
 
7862
      IF ((h6b .le. p3b) .and. (p5b .le. p7b)) THEN
 
7863
      if(.not.intorb) then
 
7864
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
 
7865
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
7866
     &+nvab) * (h6b_2 - 1)))))
 
7867
      else
 
7868
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
7869
     &(p7b_2
 
7870
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
7871
     &+nvab) * (h6b_2 - 1)))),p7b_2,p5b_2,p3b_2,h6b_2)
 
7872
      end if
 
7873
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
 
7874
     &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1)
 
7875
     &,3,1,2,4,1.0d0)
 
7876
      END IF
 
7877
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_7_2',6,MA_ERR)
 
7878
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
7879
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
7880
     &t),dima_sort)
 
7881
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_7_2',7,MA_E
 
7882
     &RR)
 
7883
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_7_2',8,MA_E
 
7884
     &RR)
 
7885
      END IF
 
7886
      END IF
 
7887
      END IF
 
7888
      END DO
 
7889
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
7890
     &icsd_t2_7_2',9,MA_ERR)
 
7891
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
7892
     &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
 
7893
     &,3,2,4,1,-1.0d0)
 
7894
c *** peta ***
 
7895
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),
 
7896
     &(h6b -1 + noab * (p5b - noab -1 +nvab * (h1b - 1 + noab *
 
7897
     &( p3b - noab -1 )))))
 
7898
c ************
 
7899
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_7_2',10,MA_ERR)
 
7900
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_7_2',11,MA_
 
7901
     &ERR)
 
7902
      END IF
 
7903
      END IF
 
7904
      END IF
 
7905
c old way      next = NXTASK(nprocs, 1)
 
7906
c --- new way ----
 
7907
      call nxt_ctx_next(ctx, icounter, next)
 
7908
c ----------------
 
7909
      END IF
 
7910
      count = count + 1
 
7911
      END DO
 
7912
      END DO
 
7913
      END DO
 
7914
      END DO
 
7915
c old way      next = NXTASK(-nprocs, 1)
 
7916
c old way      call GA_SYNC()
 
7917
      RETURN
 
7918
      END
 
7919
      SUBROUTINE icsd_t2_7_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse
 
7920
     &t,ctx,icounter)
 
7921
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
7922
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
7923
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
7924
C     i1 ( h6 p3 h1 p5 )_vt + = -1/2 * Sum ( h8 p7 ) * t ( p3 p7 h1 h8 )_t * v ( h6 h8 p5 p7 )_v
 
7925
      IMPLICIT NONE
 
7926
#include "global.fh"
 
7927
#include "mafdecls.fh"
 
7928
#include "sym.fh"
 
7929
#include "errquit.fh"
 
7930
#include "tce.fh"
 
7931
      INTEGER d_a
 
7932
      INTEGER k_a_offset
 
7933
      INTEGER d_b
 
7934
      INTEGER k_b_offset
 
7935
      INTEGER d_c
 
7936
      INTEGER k_c_offset
 
7937
c old way      INTEGER NXTASK
 
7938
c -------------------------
 
7939
      INTEGER ctx,icounter
 
7940
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
7941
c -------------------------
 
7942
      INTEGER next
 
7943
      INTEGER nprocs
 
7944
      INTEGER count
 
7945
      INTEGER p3b
 
7946
      INTEGER h6b
 
7947
      INTEGER h1b
 
7948
      INTEGER p5b
 
7949
      INTEGER dimc
 
7950
      INTEGER l_c_sort
 
7951
      INTEGER k_c_sort
 
7952
      INTEGER p7b
 
7953
      INTEGER h8b
 
7954
      INTEGER p3b_1
 
7955
      INTEGER p7b_1
 
7956
      INTEGER h1b_1
 
7957
      INTEGER h8b_1
 
7958
      INTEGER h6b_2
 
7959
      INTEGER h8b_2
 
7960
      INTEGER p5b_2
 
7961
      INTEGER p7b_2
 
7962
      INTEGER dim_common
 
7963
      INTEGER dima_sort
 
7964
      INTEGER dima
 
7965
      INTEGER dimb_sort
 
7966
      INTEGER dimb
 
7967
      INTEGER l_a_sort
 
7968
      INTEGER k_a_sort
 
7969
      INTEGER l_a
 
7970
      INTEGER k_a
 
7971
      INTEGER l_b_sort
 
7972
      INTEGER k_b_sort
 
7973
      INTEGER l_b
 
7974
      INTEGER k_b
 
7975
      INTEGER l_c
 
7976
      INTEGER k_c
 
7977
c old way      EXTERNAL NXTASK
 
7978
      nprocs = GA_NNODES()
 
7979
      count = 0
 
7980
c old way      next = NXTASK(nprocs, 1)
 
7981
c --- new way ----
 
7982
      call nxt_ctx_next(ctx, icounter, next)
 
7983
c ----------------
 
7984
c *** peta ***
 
7985
      DO p3b = noab+1,noab+nvab
 
7986
      DO h1b = 1,noab
 
7987
      DO p5b = noab+1,noab+nvab
 
7988
      DO h6b = 1,noab
 
7989
c ************
 
7990
      IF (next.eq.count) THEN
 
7991
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1
 
7992
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN
 
7993
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h
 
7994
     &1b-1)+int_mb(k_spin+p5b-1)) THEN
 
7995
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb(
 
7996
     &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
7997
     &EN
 
7998
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra
 
7999
     &nge+h1b-1) * int_mb(k_range+p5b-1)
 
8000
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
8001
     & ERRQUIT('icsd_t2_7_3',0,MA_ERR)
 
8002
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
8003
      DO h8b = 1,noab
 
8004
      DO p7b = noab+1,noab+nvab
 
8005
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h
 
8006
     &1b-1)+int_mb(k_spin+h8b-1)) THEN
 
8007
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb(
 
8008
     &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_t) THEN
 
8009
      CALL TCE_RESTRICTED_4(p3b,p7b,h1b,h8b,p3b_1,p7b_1,h1b_1,h8b_1)
 
8010
      CALL TCE_RESTRICTED_4(h6b,h8b,p5b,p7b,h6b_2,h8b_2,p5b_2,p7b_2)
 
8011
      dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+h8b-1)
 
8012
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
 
8013
      dima = dim_common * dima_sort
 
8014
      dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1)
 
8015
      dimb = dim_common * dimb_sort
 
8016
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
8017
 
 
8018
 
 
8019
 
 
8020
 
 
8021
 
 
8022
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
8023
     & ERRQUIT('icsd_t2_7_3',1,MA_ERR)
 
8024
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
8025
     &icsd_t2_7_3',2,MA_ERR)
 
8026
      IF ((p7b .lt. p3b) .and. (h8b .lt. h1b)) THEN
 
8027
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
8028
     & - 1 + noab * (h8b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p7b_
 
8029
     &1 - noab - 1)))))
 
8030
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
 
8031
     &,int_mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1)
 
8032
     &,4,2,3,1,1.0d0)
 
8033
      END IF
 
8034
      IF ((p7b .lt. p3b) .and. (h1b .le. h8b)) THEN
 
8035
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
 
8036
     & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p7b_
 
8037
     &1 - noab - 1)))))
 
8038
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
 
8039
     &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1)
 
8040
     &,3,2,4,1,-1.0d0)
 
8041
      END IF
 
8042
      IF ((p3b .le. p7b) .and. (h8b .lt. h1b)) THEN
 
8043
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
8044
     & - 1 + noab * (h8b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p3b_
 
8045
     &1 - noab - 1)))))
 
8046
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
8047
     &,int_mb(k_range+p7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1)
 
8048
     &,4,1,3,2,-1.0d0)
 
8049
      END IF
 
8050
      IF ((p3b .le. p7b) .and. (h1b .le. h8b)) THEN
 
8051
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
 
8052
     & - 1 + noab * (h1b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p3b_
 
8053
     &1 - noab - 1)))))
 
8054
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
8055
     &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1)
 
8056
     &,3,1,4,2,1.0d0)
 
8057
      END IF
 
8058
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_7_3',3,MA_ERR)
 
8059
 
 
8060
 
 
8061
 
 
8062
 
 
8063
 
 
8064
 
 
8065
 
 
8066
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
8067
     & ERRQUIT('icsd_t2_7_3',4,MA_ERR)
 
8068
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
8069
     &icsd_t2_7_3',5,MA_ERR)
 
8070
      IF ((h8b .lt. h6b) .and. (p7b .lt. p5b)) THEN
 
8071
      if(.not.intorb) then
 
8072
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
8073
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
 
8074
     &+nvab) * (h8b_2 - 1)))))
 
8075
      else
 
8076
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
8077
     &(p5b_2
 
8078
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
 
8079
     &+nvab) * (h8b_2 - 1)))),p5b_2,p7b_2,h6b_2,h8b_2)
 
8080
      end if
 
8081
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
 
8082
     &,int_mb(k_range+h6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1)
 
8083
     &,4,2,1,3,1.0d0)
 
8084
      END IF
 
8085
      IF ((h8b .lt. h6b) .and. (p5b .le. p7b)) THEN
 
8086
      if(.not.intorb) then
 
8087
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
 
8088
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
 
8089
     &+nvab) * (h8b_2 - 1)))))
 
8090
      else
 
8091
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
8092
     &(p7b_2
 
8093
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
 
8094
     &+nvab) * (h8b_2 - 1)))),p7b_2,p5b_2,h6b_2,h8b_2)
 
8095
      end if
 
8096
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
 
8097
     &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1)
 
8098
     &,3,2,1,4,-1.0d0)
 
8099
      END IF
 
8100
      IF ((h6b .le. h8b) .and. (p7b .lt. p5b)) THEN
 
8101
      if(.not.intorb) then
 
8102
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
8103
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
 
8104
     &+nvab) * (h6b_2 - 1)))))
 
8105
      else
 
8106
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
8107
     &(p5b_2
 
8108
     & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
 
8109
     &+nvab) * (h6b_2 - 1)))),p5b_2,p7b_2,h8b_2,h6b_2)
 
8110
      end if
 
8111
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
 
8112
     &,int_mb(k_range+h8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1)
 
8113
     &,4,1,2,3,-1.0d0)
 
8114
      END IF
 
8115
      IF ((h6b .le. h8b) .and. (p5b .le. p7b)) THEN
 
8116
      if(.not.intorb) then
 
8117
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
 
8118
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
 
8119
     &+nvab) * (h6b_2 - 1)))))
 
8120
      else
 
8121
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
8122
     &(p7b_2
 
8123
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab
 
8124
     &+nvab) * (h6b_2 - 1)))),p7b_2,p5b_2,h8b_2,h6b_2)
 
8125
      end if
 
8126
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
 
8127
     &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1)
 
8128
     &,3,1,2,4,1.0d0)
 
8129
      END IF
 
8130
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_7_3',6,MA_ERR)
 
8131
 
 
8132
 
 
8133
 
 
8134
 
 
8135
 
 
8136
 
 
8137
 
 
8138
 
 
8139
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
8140
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
8141
     &t),dima_sort)
 
8142
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_7_3',7,MA_E
 
8143
     &RR)
 
8144
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_7_3',8,MA_E
 
8145
     &RR)
 
8146
      END IF
 
8147
      END IF
 
8148
      END IF
 
8149
      END DO
 
8150
      END DO
 
8151
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
8152
     &icsd_t2_7_3',9,MA_ERR)
 
8153
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
8154
     &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
8155
     &,4,2,3,1,-1.0d0/2.0d0)
 
8156
c *** peta ***
 
8157
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),
 
8158
     &(h6b -1 + noab * (p5b - noab -1 +nvab * (h1b - 1 + noab *
 
8159
     &( p3b - noab -1 )))))
 
8160
c ************
 
8161
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_7_3',10,MA_ERR)
 
8162
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_7_3',11,MA_
 
8163
     &ERR)
 
8164
      END IF
 
8165
      END IF
 
8166
      END IF
 
8167
c old way      next = NXTASK(nprocs, 1)
 
8168
c --- new way ----
 
8169
      call nxt_ctx_next(ctx, icounter, next)
 
8170
c ----------------
 
8171
      END IF
 
8172
      count = count + 1
 
8173
      END DO
 
8174
      END DO
 
8175
      END DO
 
8176
      END DO
 
8177
c old way      next = NXTASK(-nprocs, 1)
 
8178
c old way      call GA_SYNC()
 
8179
      RETURN
 
8180
      END
 
8181
      SUBROUTINE icsd_t2_8(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset,
 
8182
     &ctx,icounter)
 
8183
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
8184
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
8185
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
8186
C     i0 ( p3 p4 h1 h2 )_vt + = 1/2 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * v ( p3 p4 p5 p6 )_v
 
8187
      IMPLICIT NONE
 
8188
#include "global.fh"
 
8189
#include "mafdecls.fh"
 
8190
#include "sym.fh"
 
8191
#include "errquit.fh"
 
8192
#include "tce.fh"
 
8193
c *** peta ***
 
8194
c#include "util.fh"
 
8195
c*************
 
8196
      INTEGER d_a
 
8197
      INTEGER k_a_offset
 
8198
      INTEGER d_b
 
8199
      INTEGER k_b_offset
 
8200
      INTEGER d_c
 
8201
      INTEGER k_c_offset
 
8202
c old way      INTEGER NXTASK
 
8203
c -------------------------
 
8204
      INTEGER ctx,icounter
 
8205
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
8206
c -------------------------
 
8207
      INTEGER next
 
8208
      INTEGER nprocs
 
8209
      INTEGER count
 
8210
      INTEGER p3b
 
8211
      INTEGER p4b
 
8212
      INTEGER h1b
 
8213
      INTEGER h2b
 
8214
      INTEGER dimc
 
8215
      INTEGER l_c_sort
 
8216
      INTEGER k_c_sort
 
8217
      INTEGER p5b
 
8218
      INTEGER p6b
 
8219
      INTEGER p5b_1
 
8220
      INTEGER p6b_1
 
8221
      INTEGER h1b_1
 
8222
      INTEGER h2b_1
 
8223
      INTEGER p3b_2
 
8224
      INTEGER p4b_2
 
8225
      INTEGER p5b_2
 
8226
      INTEGER p6b_2
 
8227
      INTEGER dim_common
 
8228
      INTEGER dima_sort
 
8229
      INTEGER dima
 
8230
      INTEGER dimb_sort
 
8231
      INTEGER dimb
 
8232
      INTEGER l_a_sort
 
8233
      INTEGER k_a_sort
 
8234
      INTEGER l_a
 
8235
      INTEGER k_a
 
8236
      INTEGER l_b_sort
 
8237
      INTEGER k_b_sort
 
8238
      INTEGER l_b
 
8239
      INTEGER k_b
 
8240
      INTEGER nsuperp(2)
 
8241
      INTEGER isuperp
 
8242
      INTEGER l_c
 
8243
      INTEGER k_c
 
8244
      DOUBLE PRECISION FACTORIAL
 
8245
c *** peta ****
 
8246
c      logical nodezero         ! True if node 0
 
8247
c      double precision cpu     ! CPU sec counter
 
8248
c      double precision wall    ! WALL sec counter
 
8249
c *************
 
8250
c old way      EXTERNAL NXTASK
 
8251
      EXTERNAL FACTORIAL
 
8252
      nprocs = GA_NNODES()
 
8253
      count = 0
 
8254
c old way      next = NXTASK(nprocs, 1)
 
8255
c --- new way ----
 
8256
      call nxt_ctx_next(ctx, icounter, next)
 
8257
c ----------------
 
8258
      DO p3b = noab+1,noab+nvab
 
8259
      DO p4b = p3b,noab+nvab
 
8260
      DO h1b = 1,noab
 
8261
      DO h2b = h1b,noab
 
8262
      IF (next.eq.count) THEN
 
8263
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
8264
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
8265
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
8266
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
8267
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
8268
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
8269
     &EN
 
8270
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
8271
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
8272
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
8273
     & ERRQUIT('icsd_t2_8',0,MA_ERR)
 
8274
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
8275
      DO p5b = noab+1,noab+nvab
 
8276
      DO p6b = p5b,noab+nvab
 
8277
      IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h
 
8278
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
8279
      IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb(
 
8280
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
 
8281
c             cpu = - util_cpusec()
 
8282
c             wall = - util_wallsec()
 
8283
      CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1)
 
8284
      CALL TCE_RESTRICTED_4(p3b,p4b,p5b,p6b,p3b_2,p4b_2,p5b_2,p6b_2)
 
8285
c             cpu = cpu + util_cpusec()
 
8286
c             wall = wall + util_wallsec()
 
8287
c             write(6,*)'      '
 
8288
c             write(6,9022)ga_nodeid(),cpu, wall
 
8289
c             write(6,*)'      '
 
8290
c             call util_flush(6)
 
8291
      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1)
 
8292
      dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
8293
      dima = dim_common * dima_sort
 
8294
      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1)
 
8295
      dimb = dim_common * dimb_sort
 
8296
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
8297
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
8298
     & ERRQUIT('icsd_t2_8',1,MA_ERR)
 
8299
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
8300
     &icsd_t2_8',2,MA_ERR)
 
8301
c             cpu = - util_cpusec()
 
8302
c             wall = - util_wallsec()
 
8303
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
8304
     & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_
 
8305
     &1 - noab - 1)))))
 
8306
c             cpu = cpu + util_cpusec()
 
8307
c             wall = wall + util_wallsec()
 
8308
c             write(6,*)'      '
 
8309
c             write(6,9020)ga_nodeid(),cpu, wall,h2b,h1b,p6b,p5b,dima
 
8310
c             write(6,*)'      ' 
 
8311
c             call util_flush(6)
 
8312
c 
 
8313
c             cpu = - util_cpusec()
 
8314
c             wall = - util_wallsec()
 
8315
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
8316
     &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
8317
     &,4,3,2,1,1.0d0)
 
8318
c             cpu = cpu + util_cpusec()
 
8319
c             wall = wall + util_wallsec()
 
8320
c             write(6,*)'      '
 
8321
c             write(6,9023)ga_nodeid(),cpu, wall
 
8322
c             write(6,*)'      '
 
8323
c             call util_flush(6)
 
8324
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('icsd_t2_8',3,MA_ERR)
 
8325
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
8326
     & ERRQUIT('icsd_t2_8',4,MA_ERR)
 
8327
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
8328
     &icsd_t2_8',5,MA_ERR)
 
8329
      if(.not.intorb) then
 
8330
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
8331
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab
 
8332
     &+nvab) * (p3b_2 - 1)))))
 
8333
      else
 
8334
c             cpu = - util_cpusec()
 
8335
c             wall = - util_wallsec()
 
8336
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
8337
     &(p6b_2
 
8338
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab
 
8339
     &+nvab) * (p3b_2 - 1)))),p6b_2,p5b_2,p4b_2,p3b_2)
 
8340
c             cpu = cpu + util_cpusec()
 
8341
c             wall = wall + util_wallsec()
 
8342
c             write(6,*)'      '
 
8343
c             write(6,9021)ga_nodeid(),cpu, wall,p6b_2,p5b_2,p4b_2,p3b_2,
 
8344
c     6                    dimb
 
8345
c             write(6,*)'      '
 
8346
c             call util_flush(6)
 
8347
      end if
 
8348
c             cpu = - util_cpusec()
 
8349
c             wall = - util_wallsec()
 
8350
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1)
 
8351
     &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1)
 
8352
     &,2,1,4,3,1.0d0)
 
8353
c             cpu = cpu + util_cpusec()
 
8354
c             wall = wall + util_wallsec()
 
8355
c             write(6,*)'      '
 
8356
c             write(6,9023)ga_nodeid(),cpu, wall
 
8357
c             write(6,*)'      '
 
8358
c             call util_flush(6)
 
8359
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('icsd_t2_8',6,MA_ERR)
 
8360
      nsuperp(1) = 1
 
8361
      nsuperp(2) = 1
 
8362
      isuperp = 1
 
8363
      IF (p5b .eq. p6b) THEN
 
8364
      nsuperp(isuperp) = nsuperp(isuperp) + 1
 
8365
      ELSE
 
8366
      isuperp = isuperp + 1
 
8367
      END IF
 
8368
c             cpu = - util_cpusec()
 
8369
c             wall = - util_wallsec()
 
8370
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
 
8371
     &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
 
8372
     &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
 
8373
c             cpu = cpu + util_cpusec()
 
8374
c             wall = wall + util_wallsec()
 
8375
c             write(6,*)'      '
 
8376
c             write(6,9024)ga_nodeid(),cpu, wall
 
8377
c             write(6,*)'      '
 
8378
c             call util_flush(6)
 
8379
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('icsd_t2_8',7,MA_ERR
 
8380
     &)
 
8381
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('icsd_t2_8',8,MA_ERR
 
8382
     &)
 
8383
      END IF
 
8384
      END IF
 
8385
      END IF
 
8386
      END DO
 
8387
      END DO
 
8388
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
8389
     &icsd_t2_8',9,MA_ERR)
 
8390
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1)
 
8391
     &,int_mb(k_range+p3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1)
 
8392
     &,2,1,4,3,1.0d0/2.0d0)
 
8393
c             cpu = - util_cpusec()
 
8394
c             wall = - util_wallsec()
 
8395
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
8396
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
8397
     & - 1)))))
 
8398
c             cpu = cpu + util_cpusec()
 
8399
c             wall = wall + util_wallsec()
 
8400
c             write(6,*)'      '
 
8401
c             write(6,9025)ga_nodeid(),cpu, wall
 
8402
c             write(6,*)'      '
 
8403
c             call util_flush(6)
 
8404
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('icsd_t2_8',10,MA_ERR)
 
8405
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('icsd_t2_8',11,MA_ER
 
8406
     &R)
 
8407
      END IF
 
8408
      END IF
 
8409
      END IF
 
8410
c old way      next = NXTASK(nprocs, 1)
 
8411
c --- new way ----
 
8412
      call nxt_ctx_next(ctx, icounter, next)
 
8413
c ----------------
 
8414
      END IF
 
8415
      count = count + 1
 
8416
      END DO
 
8417
      END DO
 
8418
      END DO
 
8419
      END DO
 
8420
c old way      next = NXTASK(-nprocs, 1)
 
8421
c old way      call GA_SYNC()
 
8422
 9020 format('  T2 GA',i4,1x,'Cpu  wall ',2(f17.12,1x),1x,4i4,2x,i10)
 
8423
 9021 format('  V2 GA',i4,1x,'Cpu  wall ',2(f17.12,1x),1x,4i4,2x,i10)
 
8424
 9022 format('  TRANS',i4,1x,'Cpu  wall ',2(f17.12,1x))  
 
8425
 9023 format('  SORT ',i4,1x,'Cpu  wall ',2(f17.12,1x))
 
8426
 9024 format('  DGEMM',i4,1x,'Cpu  wall ',2(f17.12,1x))
 
8427
 9025 format(' ADD_BL',i4,1x,'Cpu  wall ',2(f17.12,1x))
 
8428
      RETURN
 
8429
      END
 
8430
cccx
 
8431
cccx
 
8432
cccx
 
8433
cccx
 
8434
cccx
 
8435
cccx
 
8436
cccx
 
8437
cccx
 
8438
cccx
 
8439
c
 
8440
c
 
8441
c
 
8442
      SUBROUTINE licsd_t2_3x(d_a,k_a_offset,d_b,k_b_offset,d_c,
 
8443
     &k_c_offset,ctx,icounter)
 
8444
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
8445
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
8446
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
8447
C     i0 ( p3 p4 h1 h2 )_vt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * v ( p3 p4 h2 p5 )_v
 
8448
      IMPLICIT NONE
 
8449
#include "global.fh"
 
8450
#include "mafdecls.fh"
 
8451
#include "sym.fh"
 
8452
#include "errquit.fh"
 
8453
#include "tce.fh"
 
8454
      INTEGER d_a
 
8455
      INTEGER k_a_offset
 
8456
      INTEGER d_b
 
8457
      INTEGER k_b_offset
 
8458
      INTEGER d_c
 
8459
      INTEGER k_c_offset
 
8460
cc      INTEGER NXTVAL
 
8461
      INTEGER next
 
8462
      INTEGER nprocs
 
8463
      INTEGER count
 
8464
      INTEGER p3b
 
8465
      INTEGER p4b
 
8466
      INTEGER h1b
 
8467
      INTEGER h2b
 
8468
      INTEGER dimc
 
8469
      INTEGER l_c_sort
 
8470
      INTEGER k_c_sort
 
8471
      INTEGER p5b
 
8472
      INTEGER p5b_1
 
8473
      INTEGER h1b_1
 
8474
      INTEGER p3b_2
 
8475
      INTEGER p4b_2
 
8476
      INTEGER h2b_2
 
8477
      INTEGER p5b_2
 
8478
      INTEGER dim_common
 
8479
      INTEGER dima_sort
 
8480
      INTEGER dima
 
8481
      INTEGER dimb_sort
 
8482
      INTEGER dimb
 
8483
      INTEGER l_a_sort
 
8484
      INTEGER k_a_sort
 
8485
      INTEGER l_a
 
8486
      INTEGER k_a
 
8487
      INTEGER l_b_sort
 
8488
      INTEGER k_b_sort
 
8489
      INTEGER l_b
 
8490
      INTEGER k_b
 
8491
      INTEGER l_c
 
8492
      INTEGER k_c
 
8493
cc      EXTERNAL NXTVAL
 
8494
c old way      INTEGER NXTASK
 
8495
c -------------------------
 
8496
      INTEGER ctx,icounter
 
8497
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
8498
c -------------------------
 
8499
c old way      EXTERNAL NXTASK
 
8500
      nprocs = GA_NNODES()
 
8501
      count = 0
 
8502
cc      next = NXTVAL(nprocs)
 
8503
c old way      next = NXTASK(nprocs, 1)
 
8504
c --- new way ----
 
8505
      call nxt_ctx_next(ctx, icounter, next)
 
8506
c ----------------
 
8507
      DO p3b = noab+1,noab+nvab
 
8508
      DO p4b = p3b,noab+nvab
 
8509
      DO h1b = 1,noab
 
8510
      DO h2b = 1,noab
 
8511
      IF (next.eq.count) THEN
 
8512
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
8513
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
8514
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
8515
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
8516
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
8517
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
8518
     &EN
 
8519
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
8520
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
8521
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
8522
     & ERRQUIT('licsd_t2_3',0,MA_ERR)
 
8523
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
8524
      DO p5b = noab+1,noab+nvab
 
8525
      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
8526
      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
8527
     &EN
 
8528
      CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1)
 
8529
      CALL TCE_RESTRICTED_4(p3b,p4b,h2b,p5b,p3b_2,p4b_2,h2b_2,p5b_2)
 
8530
      dim_common = int_mb(k_range+p5b-1)
 
8531
      dima_sort = int_mb(k_range+h1b-1)
 
8532
      dima = dim_common * dima_sort
 
8533
      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb
 
8534
     &(k_range+h2b-1)
 
8535
      dimb = dim_common * dimb_sort
 
8536
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
8537
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
8538
     & ERRQUIT('licsd_t2_3',1,MA_ERR)
 
8539
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
8540
     &licsd_t2_3',2,MA_ERR)
 
8541
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
8542
     & int_mb(k_a_offset),(h1b_1
 
8543
     & - 1 + noab * (p5b_1 - noab - 1)))
 
8544
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
8545
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
8546
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('licsd_t2_3',3,MA_ERR)
 
8547
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
8548
     & ERRQUIT('licsd_t2_3',4,MA_ERR)
 
8549
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
8550
     &licsd_t2_3',5,MA_ERR)
 
8551
      IF ((h2b .le. p5b)) THEN
 
8552
      if(.not.intorb) then
 
8553
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
8554
     & - 1 + (noab+nvab) * (h2b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab
 
8555
     &+nvab) * (p3b_2 - 1)))))
 
8556
      else
 
8557
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
8558
     &(p5b_2
 
8559
     & - 1 + (noab+nvab) * (h2b_2 - 1 + (noab+nvab) * (p4b_2 - 1 + (noab
 
8560
     &+nvab) * (p3b_2 - 1)))),p5b_2,h2b_2,p4b_2,p3b_2)
 
8561
      end if
 
8562
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p3b-1)
 
8563
     &,int_mb(k_range+p4b-1),int_mb(k_range+h2b-1),int_mb(k_range+p5b-1)
 
8564
     &,3,2,1,4,1.0d0)
 
8565
      END IF
 
8566
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('licsd_t2_3',6,MA_ERR)
 
8567
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
8568
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
8569
     &t),dima_sort)
 
8570
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('licsd_t2_3',7,MA_ER
 
8571
     &R)
 
8572
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('licsd_t2_3',8,MA_ER
 
8573
     &R)
 
8574
      END IF
 
8575
      END IF
 
8576
      END IF
 
8577
      END DO
 
8578
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
8579
     &licsd_t2_3',9,MA_ERR)
 
8580
      IF ((h1b .le. h2b)) THEN
 
8581
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
8582
     &,int_mb(k_range+p4b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
 
8583
     &,3,2,4,1,-1.0d0)
 
8584
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
8585
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
8586
     & - 1)))))
 
8587
      END IF
 
8588
      IF ((h2b .le. h1b)) THEN
 
8589
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
8590
     &,int_mb(k_range+p4b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
 
8591
     &,3,2,1,4,1.0d0)
 
8592
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
8593
     & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
8594
     & - 1)))))
 
8595
      END IF
 
8596
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('licsd_t2_3',10,MA_ERR)
 
8597
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('licsd_t2_3',11,MA_E
 
8598
     &RR)
 
8599
      END IF
 
8600
      END IF
 
8601
      END IF
 
8602
cc      next = NXTVAL(nprocs)
 
8603
c old way      next = NXTASK(nprocs, 1)
 
8604
c --- new way ----
 
8605
      call nxt_ctx_next(ctx, icounter, next)
 
8606
c ----------------
 
8607
      END IF
 
8608
      count = count + 1
 
8609
      END DO
 
8610
      END DO
 
8611
      END DO
 
8612
      END DO
 
8613
cc      next = NXTVAL(-nprocs)
 
8614
c old way      next = NXTASK(-nprocs, 1)
 
8615
c old way      call GA_SYNC()
 
8616
      RETURN
 
8617
      END
 
8618
c
 
8619
c
 
8620
c
 
8621
c
 
8622
c
 
8623
c
 
8624
c
 
8625
c
 
8626
c
 
8627
c
 
8628
c
 
8629
c
 
8630
      SUBROUTINE vt1ic_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset,
 
8631
     &ctx,icounter)
 
8632
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
8633
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
8634
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
8635
C     i0 ( p3 p4 h1 h2 )_vtt + = -1/2 * P( 2 ) * Sum ( h5 ) * t ( p3 h5 )_t * i1 ( h5 p4 h1 h2 )_vt
 
8636
      IMPLICIT NONE
 
8637
#include "global.fh"
 
8638
#include "mafdecls.fh"
 
8639
#include "sym.fh"
 
8640
#include "errquit.fh"
 
8641
#include "tce.fh"
 
8642
      INTEGER d_a
 
8643
      INTEGER k_a_offset
 
8644
      INTEGER d_b
 
8645
      INTEGER k_b_offset
 
8646
      INTEGER d_c
 
8647
      INTEGER k_c_offset
 
8648
cc      INTEGER NXTVAL
 
8649
      INTEGER next
 
8650
      INTEGER nprocs
 
8651
      INTEGER count
 
8652
      INTEGER p3b
 
8653
      INTEGER p4b
 
8654
      INTEGER h1b
 
8655
      INTEGER h2b
 
8656
      INTEGER dimc
 
8657
      INTEGER l_c_sort
 
8658
      INTEGER k_c_sort
 
8659
      INTEGER h5b
 
8660
      INTEGER p3b_1
 
8661
      INTEGER h5b_1
 
8662
      INTEGER p4b_2
 
8663
      INTEGER h5b_2
 
8664
      INTEGER h1b_2
 
8665
      INTEGER h2b_2
 
8666
      INTEGER dim_common
 
8667
      INTEGER dima_sort
 
8668
      INTEGER dima
 
8669
      INTEGER dimb_sort
 
8670
      INTEGER dimb
 
8671
      INTEGER l_a_sort
 
8672
      INTEGER k_a_sort
 
8673
      INTEGER l_a
 
8674
      INTEGER k_a
 
8675
      INTEGER l_b_sort
 
8676
      INTEGER k_b_sort
 
8677
      INTEGER l_b
 
8678
      INTEGER k_b
 
8679
      INTEGER l_c
 
8680
      INTEGER k_c
 
8681
cc      EXTERNAL NXTVAL
 
8682
c old way      INTEGER NXTASK
 
8683
c -------------------------
 
8684
      INTEGER ctx,icounter
 
8685
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
8686
c -------------------------
 
8687
c old way      EXTERNAL NXTASK
 
8688
      nprocs = GA_NNODES()
 
8689
      count = 0
 
8690
cc      next = NXTVAL(nprocs)
 
8691
c old way      next = NXTASK(nprocs, 1)
 
8692
c --- new way ----
 
8693
      call nxt_ctx_next(ctx, icounter, next)
 
8694
c ----------------
 
8695
      DO p3b = noab+1,noab+nvab
 
8696
      DO p4b = noab+1,noab+nvab
 
8697
      DO h1b = 1,noab
 
8698
      DO h2b = h1b,noab
 
8699
      IF (next.eq.count) THEN
 
8700
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
8701
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
8702
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
8703
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
8704
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
8705
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,ieor(irrep_t
 
8706
     &,irrep_t))) THEN
 
8707
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
8708
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
8709
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
8710
     & ERRQUIT('vt1ic_1',0,MA_ERR)
 
8711
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
8712
      DO h5b = 1,noab
 
8713
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h5b-1)) THEN
 
8714
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h5b-1)) .eq. irrep_t) TH
 
8715
     &EN
 
8716
      CALL TCE_RESTRICTED_2(p3b,h5b,p3b_1,h5b_1)
 
8717
      CALL TCE_RESTRICTED_4(p4b,h5b,h1b,h2b,p4b_2,h5b_2,h1b_2,h2b_2)
 
8718
      dim_common = int_mb(k_range+h5b-1)
 
8719
      dima_sort = int_mb(k_range+p3b-1)
 
8720
      dima = dim_common * dima_sort
 
8721
      dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h1b-1) * int_mb
 
8722
     &(k_range+h2b-1)
 
8723
      dimb = dim_common * dimb_sort
 
8724
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
8725
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
8726
     & ERRQUIT('vt1ic_1',1,MA_ERR)
 
8727
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
8728
     &vt1ic_1',2,MA_ERR)
 
8729
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
8730
     & int_mb(k_a_offset),(h5b_1
 
8731
     & - 1 + noab * (p3b_1 - noab - 1)))
 
8732
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
8733
     &,int_mb(k_range+h5b-1),1,2,1.0d0)
 
8734
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('vt1ic_1',3,MA_ERR)
 
8735
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
8736
     & ERRQUIT('vt1ic_1',4,MA_ERR)
 
8737
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
8738
     &vt1ic_1',5,MA_ERR)
 
8739
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
 
8740
     & - 1 + noab * (h1b_2 - 1 + noab * (h5b_2 - 1 + noab * (p4b_2 - noa
 
8741
     &b - 1)))))
 
8742
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
 
8743
     &,int_mb(k_range+h5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
8744
     &,4,3,1,2,1.0d0)
 
8745
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('vt1ic_1',6,MA_ERR)
 
8746
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
8747
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
8748
     &t),dima_sort)
 
8749
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('vt1ic_1',7,MA_ERR)
 
8750
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('vt1ic_1',8,MA_ERR)
 
8751
      END IF
 
8752
      END IF
 
8753
      END IF
 
8754
      END DO
 
8755
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
8756
     &vt1ic_1',9,MA_ERR)
 
8757
      IF ((p3b .le. p4b)) THEN
 
8758
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
8759
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
8760
     &,4,3,2,1,-1.0d0/2.0d0)
 
8761
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
8762
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
8763
     & - 1)))))
 
8764
      END IF
 
8765
      IF ((p4b .le. p3b)) THEN
 
8766
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
8767
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
8768
     &,3,4,2,1,1.0d0/2.0d0)
 
8769
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
8770
     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
 
8771
     & - 1)))))
 
8772
      END IF
 
8773
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('vt1ic_1',10,MA_ERR)
 
8774
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('vt1ic_1',11,MA_ERR)
 
8775
      END IF
 
8776
      END IF
 
8777
      END IF
 
8778
cc      next = NXTVAL(nprocs)
 
8779
c old way      next = NXTASK(nprocs, 1)
 
8780
c --- new way ----
 
8781
      call nxt_ctx_next(ctx, icounter, next)
 
8782
c ----------------
 
8783
      END IF
 
8784
      count = count + 1
 
8785
      END DO
 
8786
      END DO
 
8787
      END DO
 
8788
      END DO
 
8789
cc      next = NXTVAL(-nprocs)
 
8790
c old way      next = NXTASK(-nprocs, 1)
 
8791
c old way      call GA_SYNC()
 
8792
      RETURN
 
8793
      END
 
8794
      SUBROUTINE OFFSET_vt1ic_1_1(l_a_offset,k_a_offset,size)
 
8795
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
8796
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
8797
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
8798
C     i1 ( h5 p3 h1 h2 )_vt
 
8799
      IMPLICIT NONE
 
8800
#include "global.fh"
 
8801
#include "mafdecls.fh"
 
8802
#include "sym.fh"
 
8803
#include "errquit.fh"
 
8804
#include "tce.fh"
 
8805
      INTEGER l_a_offset
 
8806
      INTEGER k_a_offset
 
8807
      INTEGER size
 
8808
      INTEGER length
 
8809
      INTEGER addr
 
8810
      INTEGER p3b
 
8811
      INTEGER h5b
 
8812
      INTEGER h1b
 
8813
      INTEGER h2b
 
8814
      length = 0
 
8815
      DO p3b = noab+1,noab+nvab
 
8816
      DO h5b = 1,noab
 
8817
      DO h1b = 1,noab
 
8818
      DO h2b = h1b,noab
 
8819
      IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
 
8820
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
8821
      IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
 
8822
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
8823
     &EN
 
8824
      IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+p3b-1
 
8825
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
8826
      length = length + 1
 
8827
      END IF
 
8828
      END IF
 
8829
      END IF
 
8830
      END DO
 
8831
      END DO
 
8832
      END DO
 
8833
      END DO
 
8834
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
8835
     &set)) CALL ERRQUIT('vt1ic_1_1',0,MA_ERR)
 
8836
      int_mb(k_a_offset) = length
 
8837
      addr = 0
 
8838
      size = 0
 
8839
      DO p3b = noab+1,noab+nvab
 
8840
      DO h5b = 1,noab
 
8841
      DO h1b = 1,noab
 
8842
      DO h2b = h1b,noab
 
8843
      IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h
 
8844
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
8845
      IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(
 
8846
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
8847
     &EN
 
8848
      IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+p3b-1
 
8849
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
8850
      addr = addr + 1
 
8851
      int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h5b 
 
8852
     &- 1 + noab * (p3b - noab - 1)))
 
8853
      int_mb(k_a_offset+length+addr) = size
 
8854
      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h5b-1) * int_
 
8855
     &mb(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
8856
      END IF
 
8857
      END IF
 
8858
      END IF
 
8859
      END DO
 
8860
      END DO
 
8861
      END DO
 
8862
      END DO
 
8863
      RETURN
 
8864
      END
 
8865
      SUBROUTINE vt1ic_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset,
 
8866
     &ctx,icounter)
 
8867
C     $Id: icsd_t2.F 21409 2011-11-05 06:36:24Z d3y133 $
 
8868
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
8869
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
8870
C     i1 ( h5 p3 h1 h2 )_vt + = -2 * P( 2 ) * Sum ( p6 ) * t ( p6 h1 )_t * v ( h5 p3 h2 p6 )_v
 
8871
      IMPLICIT NONE
 
8872
#include "global.fh"
 
8873
#include "mafdecls.fh"
 
8874
#include "sym.fh"
 
8875
#include "errquit.fh"
 
8876
#include "tce.fh"
 
8877
      INTEGER d_a
 
8878
      INTEGER k_a_offset
 
8879
      INTEGER d_b
 
8880
      INTEGER k_b_offset
 
8881
      INTEGER d_c
 
8882
      INTEGER k_c_offset
 
8883
cc      INTEGER NXTVAL
 
8884
      INTEGER next
 
8885
      INTEGER nprocs
 
8886
      INTEGER count
 
8887
      INTEGER p3b
 
8888
      INTEGER h5b
 
8889
      INTEGER h1b
 
8890
      INTEGER h2b
 
8891
      INTEGER dimc
 
8892
      INTEGER l_c_sort
 
8893
      INTEGER k_c_sort
 
8894
      INTEGER p6b
 
8895
      INTEGER p6b_1
 
8896
      INTEGER h1b_1
 
8897
      INTEGER p3b_2
 
8898
      INTEGER h5b_2
 
8899
      INTEGER h2b_2
 
8900
      INTEGER p6b_2
 
8901
      INTEGER dim_common
 
8902
      INTEGER dima_sort
 
8903
      INTEGER dima
 
8904
      INTEGER dimb_sort
 
8905
      INTEGER dimb
 
8906
      INTEGER l_a_sort
 
8907
      INTEGER k_a_sort
 
8908
      INTEGER l_a
 
8909
      INTEGER k_a
 
8910
      INTEGER l_b_sort
 
8911
      INTEGER k_b_sort
 
8912
      INTEGER l_b
 
8913
      INTEGER k_b
 
8914
      INTEGER l_c
 
8915
      INTEGER k_c
 
8916
cc      EXTERNAL NXTVAL
 
8917
c old way      INTEGER NXTASK
 
8918
c -------------------------
 
8919
      INTEGER ctx,icounter
 
8920
      external nxt_ctx_create, nxt_ctx_destroy, nxt_ctx_next
 
8921
c -------------------------
 
8922
c old way      EXTERNAL NXTASK
 
8923
      nprocs = GA_NNODES()
 
8924
      count = 0
 
8925
cc      next = NXTVAL(nprocs)
 
8926
c old way      next = NXTASK(nprocs, 1)
 
8927
c --- new way ----
 
8928
      call nxt_ctx_next(ctx, icounter, next)
 
8929
c ----------------
 
8930
      DO p3b = noab+1,noab+nvab
 
8931
      DO h5b = 1,noab
 
8932
      DO h1b = 1,noab
 
8933
      DO h2b = 1,noab
 
8934
      IF (next.eq.count) THEN
 
8935
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h5b-1
 
8936
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
8937
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+h
 
8938
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
8939
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb(
 
8940
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH
 
8941
     &EN
 
8942
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra
 
8943
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
8944
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
8945
     & ERRQUIT('vt1ic_1_2',0,MA_ERR)
 
8946
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
8947
      DO p6b = noab+1,noab+nvab
 
8948
      IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
8949
      IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
8950
     &EN
 
8951
      CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1)
 
8952
      CALL TCE_RESTRICTED_4(p3b,h5b,h2b,p6b,p3b_2,h5b_2,h2b_2,p6b_2)
 
8953
      dim_common = int_mb(k_range+p6b-1)
 
8954
      dima_sort = int_mb(k_range+h1b-1)
 
8955
      dima = dim_common * dima_sort
 
8956
      dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h5b-1) * int_mb
 
8957
     &(k_range+h2b-1)
 
8958
      dimb = dim_common * dimb_sort
 
8959
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
8960
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
8961
     & ERRQUIT('vt1ic_1_2',1,MA_ERR)
 
8962
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
8963
     &vt1ic_1_2',2,MA_ERR)
 
8964
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
8965
     & int_mb(k_a_offset),(h1b_1
 
8966
     & - 1 + noab * (p6b_1 - noab - 1)))
 
8967
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1)
 
8968
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
8969
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('vt1ic_1_2',3,MA_ERR)
 
8970
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
8971
     & ERRQUIT('vt1ic_1_2',4,MA_ERR)
 
8972
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
8973
     &vt1ic_1_2',5,MA_ERR)
 
8974
      IF ((h5b .le. p3b) .and. (h2b .le. p6b)) THEN
 
8975
      if(.not.intorb) then
 
8976
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2
 
8977
     & - 1 + (noab+nvab) * (h2b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
8978
     &+nvab) * (h5b_2 - 1)))))
 
8979
      else
 
8980
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
8981
     &(p6b_2
 
8982
     & - 1 + (noab+nvab) * (h2b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab
 
8983
     &+nvab) * (h5b_2 - 1)))),p6b_2,h2b_2,p3b_2,h5b_2)
 
8984
      end if
 
8985
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
 
8986
     &,int_mb(k_range+p3b-1),int_mb(k_range+h2b-1),int_mb(k_range+p6b-1)
 
8987
     &,3,1,2,4,1.0d0)
 
8988
      END IF
 
8989
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('vt1ic_1_2',6,MA_ERR)
 
8990
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
8991
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
8992
     &t),dima_sort)
 
8993
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('vt1ic_1_2',7,MA_ERR
 
8994
     &)
 
8995
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('vt1ic_1_2',8,MA_ERR
 
8996
     &)
 
8997
      END IF
 
8998
      END IF
 
8999
      END IF
 
9000
      END DO
 
9001
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
9002
     &vt1ic_1_2',9,MA_ERR)
 
9003
      IF ((h1b .le. h2b)) THEN
 
9004
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
9005
     &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
 
9006
     &,3,2,4,1,-2.0d0/1.0d0)
 
9007
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
9008
     & 1 + noab * (h1b - 1 + noab * (h5b - 1 + noab * (p3b - noab - 1)))
 
9009
     &))
 
9010
      END IF
 
9011
      IF ((h2b .le. h1b)) THEN
 
9012
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
9013
     &,int_mb(k_range+h5b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1)
 
9014
     &,3,2,1,4,2.0d0/1.0d0)
 
9015
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
9016
     & 1 + noab * (h2b - 1 + noab * (h5b - 1 + noab * (p3b - noab - 1)))
 
9017
     &))
 
9018
      END IF
 
9019
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('vt1ic_1_2',10,MA_ERR)
 
9020
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('vt1ic_1_2',11,MA_ER
 
9021
     &R)
 
9022
      END IF
 
9023
      END IF
 
9024
      END IF
 
9025
cc      next = NXTVAL(nprocs)
 
9026
c old way      next = NXTASK(nprocs, 1)
 
9027
c --- new way ----
 
9028
      call nxt_ctx_next(ctx, icounter, next)
 
9029
c ----------------
 
9030
      END IF
 
9031
      count = count + 1
 
9032
      END DO
 
9033
      END DO
 
9034
      END DO
 
9035
      END DO
 
9036
cc      next = NXTVAL(-nprocs)
 
9037
c old way      next = NXTASK(-nprocs, 1)
 
9038
c old way      call GA_SYNC()
 
9039
      RETURN
 
9040
      END
 
9041
c
 
9042
c
 
9043
c
 
9044
c