← Back to branch summary

~ubuntu-branches/ubuntu/utopic/nwchem/utopic

« back to all changes in this revision

Viewing changes to src/tce/mrcc/ccsd_sub/ccsd_se.F

  • Committer: Package Import Robot
  • Author(s): Michael Banck, Daniel Leidert, Andreas Tille, Michael Banck
  • Date: 2013-07-04 12:14:55 UTC
  • mfrom: (1.1.2)
  • Revision ID: package-import@ubuntu.com-20130704121455-5tvsx2qabor3nrui
Tags: 6.3-1
http://bugs.debian.org/696361
* New upstream release.
* Fixes anisotropic properties (Closes: #696361).
* New features include:
  + Multi-reference coupled cluster (MRCC) approaches
  + Hybrid DFT calculations with short-range HF 
  + New density-functionals including Minnesota (M08, M11) and HSE hybrid
    functionals
  + X-ray absorption spectroscopy (XAS) with TDDFT
  + Analytical gradients for the COSMO solvation model
  + Transition densities from TDDFT 
  + DFT+U and Electron-Transfer (ET) methods for plane wave calculations
  + Exploitation of space group symmetry in plane wave geometry optimizations
  + Local density of states (LDOS) collective variable added to Metadynamics
  + Various new XC functionals added for plane wave calculations, including
    hybrid and range-corrected ones
  + Electric field gradients with relativistic corrections 
  + Nudged Elastic Band optimization method
  + Updated basis sets and ECPs 

[ Daniel Leidert ]
* debian/watch: Fixed.

[ Andreas Tille ]
* debian/upstream: References

[ Michael Banck ]
* debian/upstream (Name): New field.
* debian/patches/02_makefile_flags.patch: Refreshed.
* debian/patches/06_statfs_kfreebsd.patch: Likewise.
* debian/patches/07_ga_target_force_linux.patch: Likewise.
* debian/patches/05_avoid_inline_assembler.patch: Removed, no longer needed.
* debian/patches/09_backported_6.1.1_fixes.patch: Likewise.
* debian/control (Build-Depends): Added gfortran-4.7 and gcc-4.7.
* debian/patches/10_force_gcc-4.7.patch: New patch, explicitly sets
  gfortran-4.7 and gcc-4.7, fixes test suite hang with gcc-4.8 (Closes:
  #701328, #713262).
* debian/testsuite: Added tests for COSMO analytical gradients and MRCC.
* debian/rules (MRCC_METHODS): New variable, required to enable MRCC methods.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/tce/mrcc/ccsd_sub/ccsd_se.F
 
1
      SUBROUTINE cxsd_e(d_f1,d_i0,d_t1,d_t2,d_v2,k_f1_offset,k_i0_offset
 
2
     &,k_t1_offset,k_t2_offset,k_v2_offset,ipg)
 
3
C     $Id: cxsd_e.F,v 1.6 2007/09/14 18:41:34 kowalski Exp $
 
4
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
5
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
6
C     i0 ( )_tf + = 1 * Sum ( p5 h6 ) * t ( p5 h6 )_t * i1 ( h6 p5 )_f
 
7
C         i1 ( h6 p5 )_f + = 1 * f ( h6 p5 )_f
 
8
C         i1 ( h6 p5 )_vt + = 1/2 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 h6 p3 p5 )_v
 
9
C     i0 ( )_vt + = 1/4 * Sum ( h3 h4 p1 p2 ) * t ( p1 p2 h3 h4 )_t * v ( h3 h4 p1 p2 )_v
 
10
      IMPLICIT NONE
 
11
#include "global.fh"
 
12
#include "mafdecls.fh"
 
13
#include "util.fh"
 
14
#include "errquit.fh"
 
15
#include "tce.fh"
 
16
#include "tce_mrcc.fh"
 
17
      INTEGER d_i0
 
18
      INTEGER k_i0_offset
 
19
      INTEGER d_t1
 
20
      INTEGER k_t1_offset
 
21
      INTEGER d_i1
 
22
      INTEGER k_i1_offset
 
23
      INTEGER d_t2
 
24
      INTEGER k_t2_offset
 
25
      INTEGER d_v2
 
26
      INTEGER k_v2_offset
 
27
      INTEGER l_i1_offset
 
28
      INTEGER d_f1
 
29
      INTEGER k_f1_offset
 
30
      INTEGER size_i1
 
31
      CHARACTER*255 filename
 
32
      integer ipg 
 
33
      CALL OFFSET_cxsd_e_1_1(l_i1_offset,k_i1_offset,size_i1)
 
34
      CALL TCE_FILENAME('cxsd_e_1_1_i1',filename)
 
35
      CALL pgCREATEFILE(filename,d_i1,size_i1,ipg)
 
36
      CALL cxsd_e_1_1(d_f1,k_f1_offset,d_i1,k_i1_offset)
 
37
      CALL cxsd_e_1_2(d_t1,k_t1_offset,d_v2,k_v2_offset,d_i1,k_i1_offset
 
38
     &)
 
39
c      CALL RECONCILEFILE(d_i1,size_i1)
 
40
      call ga_pgroup_sync(ipg)
 
41
      CALL cxsd_e_1(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset)
 
42
      CALL DELETEFILE(d_i1)
 
43
      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('cxsd_e',-1,MA_ER
 
44
     &R)
 
45
      CALL cxsd_e_2(d_t2,k_t2_offset,d_v2,k_v2_offset,d_i0,k_i0_offset)
 
46
      RETURN
 
47
      END
 
48
      SUBROUTINE cxsd_e_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
 
49
C     $Id: cxsd_e.F,v 1.6 2007/09/14 18:41:34 kowalski Exp $
 
50
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
51
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
52
C     i0 ( )_tf + = 1 * Sum ( p5 h6 ) * t ( p5 h6 )_t * i1 ( h6 p5 )_f
 
53
      IMPLICIT NONE
 
54
#include "global.fh"
 
55
#include "mafdecls.fh"
 
56
#include "sym.fh"
 
57
#include "errquit.fh"
 
58
#include "tce.fh"
 
59
#include "tce_mrcc.fh"
 
60
      INTEGER d_a
 
61
      INTEGER k_a_offset
 
62
      INTEGER d_b
 
63
      INTEGER k_b_offset
 
64
      INTEGER d_c
 
65
      INTEGER k_c_offset
 
66
      INTEGER NXTASKsub
 
67
      INTEGER nex
 
68
      INTEGER nprocs
 
69
      INTEGER count
 
70
      INTEGER dimc
 
71
      INTEGER l_c_sort
 
72
      INTEGER k_c_sort
 
73
      INTEGER p5b
 
74
      INTEGER h6b
 
75
      INTEGER p5b_1
 
76
      INTEGER h6b_1
 
77
      INTEGER h6b_2
 
78
      INTEGER p5b_2
 
79
      INTEGER dim_common
 
80
      INTEGER dima_sort
 
81
      INTEGER dima
 
82
      INTEGER dimb_sort
 
83
      INTEGER dimb
 
84
      INTEGER l_a_sort
 
85
      INTEGER k_a_sort
 
86
      INTEGER l_a
 
87
      INTEGER k_a
 
88
      INTEGER l_b_sort
 
89
      INTEGER k_b_sort
 
90
      INTEGER l_b
 
91
      INTEGER k_b
 
92
      INTEGER l_c
 
93
      INTEGER k_c
 
94
      EXTERNAL NXTASKsub
 
95
      nprocs=GA_pgroup_NNODES(int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
96
      count = 0
 
97
      nex=NXTASKsub(nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
98
      IF (nex.eq.count) THEN
 
99
      IF (0 .eq. ieor(irrep_t,irrep_f)) THEN
 
100
      dimc = 1
 
101
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
102
     & ERRQUIT('cxsd_e_1',0,MA_ERR)
 
103
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
104
      DO p5b = noab+1,noab+nvab
 
105
      DO h6b = 1,noab
 
106
      IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h6b-1)) THEN
 
107
      IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h6b-1)) .eq. irrep_t) TH
 
108
     &EN
 
109
      CALL TCE_RESTRICTED_2(p5b,h6b,p5b_1,h6b_1)
 
110
      CALL TCE_RESTRICTED_2(h6b,p5b,h6b_2,p5b_2)
 
111
      dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1)
 
112
      dima_sort = 1
 
113
      dima = dim_common * dima_sort
 
114
      dimb_sort = 1
 
115
      dimb = dim_common * dimb_sort
 
116
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
117
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
118
     & ERRQUIT('cxsd_e_1',1,MA_ERR)
 
119
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
120
     &cxsd_e_1',2,MA_ERR)
 
121
#ifdef MRCC_LOCAL_T1
 
122
ckbn @did : localize t1amp
 
123
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
124
     + int_mb(k_a_offset),(h6b_1 - 1 + noab * (p5b_1 - noab - 1)))
 
125
#else
 
126
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1
 
127
     & - 1 + noab * (p5b_1 - noab - 1)))
 
128
#endif
 
129
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1)
 
130
     &,int_mb(k_range+h6b-1),2,1,1.0d0)
 
131
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cxsd_e_1',3,MA_ERR)
 
132
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
133
     & ERRQUIT('cxsd_e_1',4,MA_ERR)
 
134
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
135
     &cxsd_e_1',5,MA_ERR)
 
136
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
137
     & - noab - 1 + nvab * (h6b_2 - 1)))
 
138
      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
 
139
     &,int_mb(k_range+p5b-1),1,2,1.0d0)
 
140
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cxsd_e_1',6,MA_ERR)
 
141
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
142
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
143
     &t),dima_sort)
 
144
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cxsd_e_1',7,MA_ERR)
 
145
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cxsd_e_1',8,MA_ERR)
 
146
      END IF
 
147
      END IF
 
148
      END IF
 
149
      END DO
 
150
      END DO
 
151
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
152
     &cxsd_e_1',9,MA_ERR)
 
153
      CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0)
 
154
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0)
 
155
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cxsd_e_1',10,MA_ERR)
 
156
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cxsd_e_1',11,MA_ERR
 
157
     &)
 
158
      END IF
 
159
      nex=NXTASKsub(nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
160
      END IF
 
161
      count = count + 1
 
162
      nex=NXTASKsub(-nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
163
      call GA_Pgroup_SYNC(int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
164
      RETURN
 
165
      END
 
166
      SUBROUTINE cxsd_e_1_1(d_a,k_a_offset,d_c,k_c_offset)
 
167
C     $Id: cxsd_e.F,v 1.6 2007/09/14 18:41:34 kowalski Exp $
 
168
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
169
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
170
C     i1 ( h6 p5 )_f + = 1 * f ( h6 p5 )_f
 
171
      IMPLICIT NONE
 
172
#include "global.fh"
 
173
#include "mafdecls.fh"
 
174
#include "sym.fh"
 
175
#include "errquit.fh"
 
176
#include "tce.fh"
 
177
#include "tce_mrcc.fh"
 
178
      INTEGER d_a
 
179
      INTEGER k_a_offset
 
180
      INTEGER d_c
 
181
      INTEGER k_c_offset
 
182
      INTEGER NXTASKsub
 
183
      INTEGER nex
 
184
      INTEGER nprocs
 
185
      INTEGER count
 
186
      INTEGER h6b
 
187
      INTEGER p5b
 
188
      INTEGER dimc
 
189
      INTEGER h6b_1
 
190
      INTEGER p5b_1
 
191
      INTEGER dim_common
 
192
      INTEGER dima_sort
 
193
      INTEGER dima
 
194
      INTEGER l_a_sort
 
195
      INTEGER k_a_sort
 
196
      INTEGER l_a
 
197
      INTEGER k_a
 
198
      INTEGER l_c
 
199
      INTEGER k_c
 
200
      EXTERNAL NXTASKsub
 
201
      nprocs=GA_pgroup_NNODES(int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
202
      count = 0
 
203
      nex=NXTASKsub(nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
204
      DO h6b = 1,noab
 
205
      DO p5b = noab+1,noab+nvab
 
206
      IF (nex.eq.count) THEN
 
207
      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p5b-1
 
208
     &).ne.4)) THEN
 
209
      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
210
      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) TH
 
211
     &EN
 
212
      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1)
 
213
      CALL TCE_RESTRICTED_2(h6b,p5b,h6b_1,p5b_1)
 
214
      dim_common = 1
 
215
      dima_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1)
 
216
      dima = dim_common * dima_sort
 
217
      IF (dima .gt. 0) THEN
 
218
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
219
     & ERRQUIT('cxsd_e_1_1',0,MA_ERR)
 
220
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
221
     &cxsd_e_1_1',1,MA_ERR)
 
222
#ifdef MRCC_LOCAL_FOCK
 
223
ckbn @did : localize fock
 
224
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
225
     + int_mb(k_a_offset), (p5b_1 - 1 + (noab+nvab) * (h6b_1 - 1)))
 
226
#else
 
227
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p5b_1
 
228
     & - 1 + (noab+nvab) * (h6b_1 - 1)))
 
229
#endif
 
230
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h6b-1)
 
231
     &,int_mb(k_range+p5b-1),2,1,1.0d0)
 
232
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cxsd_e_1_1',2,MA_ERR)
 
233
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
234
     &cxsd_e_1_1',3,MA_ERR)
 
235
      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
236
     &,int_mb(k_range+h6b-1),2,1,1.0d0)
 
237
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
238
     & noab - 1 + nvab * (h6b - 1)))
 
239
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cxsd_e_1_1',4,MA_ERR)
 
240
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cxsd_e_1_1',5,MA_ER
 
241
     &R)
 
242
      END IF
 
243
      END IF
 
244
      END IF
 
245
      END IF
 
246
      nex=NXTASKsub(nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
247
      END IF
 
248
      count = count + 1
 
249
      END DO
 
250
      END DO
 
251
      nex=NXTASKsub(-nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
252
      call GA_Pgroup_SYNC(int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
253
      RETURN
 
254
      END
 
255
      SUBROUTINE OFFSET_cxsd_e_1_1(l_a_offset,k_a_offset,size)
 
256
C     $Id: cxsd_e.F,v 1.6 2007/09/14 18:41:34 kowalski Exp $
 
257
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
258
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
259
C     i1 ( h6 p5 )_f
 
260
      IMPLICIT NONE
 
261
#include "global.fh"
 
262
#include "mafdecls.fh"
 
263
#include "sym.fh"
 
264
#include "errquit.fh"
 
265
#include "tce.fh"
 
266
#include "tce_mrcc.fh"
 
267
      INTEGER l_a_offset
 
268
      INTEGER k_a_offset
 
269
      INTEGER size
 
270
      INTEGER length
 
271
      INTEGER addr
 
272
      INTEGER h6b
 
273
      INTEGER p5b
 
274
      length = 0
 
275
      DO h6b = 1,noab
 
276
      DO p5b = noab+1,noab+nvab
 
277
      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
278
      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) TH
 
279
     &EN
 
280
      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p5b-1
 
281
     &).ne.4)) THEN
 
282
      length = length + 1
 
283
      END IF
 
284
      END IF
 
285
      END IF
 
286
      END DO
 
287
      END DO
 
288
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
289
     &set)) CALL ERRQUIT('cxsd_e_1_1',0,MA_ERR)
 
290
      int_mb(k_a_offset) = length
 
291
      addr = 0
 
292
      size = 0
 
293
      DO h6b = 1,noab
 
294
      DO p5b = noab+1,noab+nvab
 
295
      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
296
      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p5b-1)) .eq. irrep_f) TH
 
297
     &EN
 
298
      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p5b-1
 
299
     &).ne.4)) THEN
 
300
      addr = addr + 1
 
301
      int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h6b - 1)
 
302
      int_mb(k_a_offset+length+addr) = size
 
303
      size = size + int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1)
 
304
      END IF
 
305
      END IF
 
306
      END IF
 
307
      END DO
 
308
      END DO
 
309
      RETURN
 
310
      END
 
311
      SUBROUTINE cxsd_e_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset
 
312
     &)
 
313
C     $Id: cxsd_e.F,v 1.6 2007/09/14 18:41:34 kowalski Exp $
 
314
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
315
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
316
C     i1 ( h6 p5 )_vt + = 1/2 * Sum ( h4 p3 ) * t ( p3 h4 )_t * v ( h4 h6 p3 p5 )_v
 
317
      IMPLICIT NONE
 
318
#include "global.fh"
 
319
#include "mafdecls.fh"
 
320
#include "sym.fh"
 
321
#include "errquit.fh"
 
322
#include "tce.fh"
 
323
#include "tce_mrcc.fh"
 
324
      INTEGER d_a
 
325
      INTEGER k_a_offset
 
326
      INTEGER d_b
 
327
      INTEGER k_b_offset
 
328
      INTEGER d_c
 
329
      INTEGER k_c_offset
 
330
      INTEGER NXTASKsub
 
331
      INTEGER nex
 
332
      INTEGER nprocs
 
333
      INTEGER count
 
334
      INTEGER h6b
 
335
      INTEGER p5b
 
336
      INTEGER dimc
 
337
      INTEGER l_c_sort
 
338
      INTEGER k_c_sort
 
339
      INTEGER p3b
 
340
      INTEGER h4b
 
341
      INTEGER p3b_1
 
342
      INTEGER h4b_1
 
343
      INTEGER h6b_2
 
344
      INTEGER h4b_2
 
345
      INTEGER p5b_2
 
346
      INTEGER p3b_2
 
347
      INTEGER dim_common
 
348
      INTEGER dima_sort
 
349
      INTEGER dima
 
350
      INTEGER dimb_sort
 
351
      INTEGER dimb
 
352
      INTEGER l_a_sort
 
353
      INTEGER k_a_sort
 
354
      INTEGER l_a
 
355
      INTEGER k_a
 
356
      INTEGER l_b_sort
 
357
      INTEGER k_b_sort
 
358
      INTEGER l_b
 
359
      INTEGER k_b
 
360
      INTEGER l_c
 
361
      INTEGER k_c
 
362
      EXTERNAL NXTASKsub
 
363
      nprocs=GA_pgroup_NNODES(int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
364
      count = 0
 
365
      nex=NXTASKsub(nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
366
      DO h6b = 1,noab
 
367
      DO p5b = noab+1,noab+nvab
 
368
      IF (nex.eq.count) THEN
 
369
      IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p5b-1
 
370
     &).ne.4)) THEN
 
371
      IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p5b-1)) THEN
 
372
      IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_
 
373
     &v,irrep_t)) THEN
 
374
      dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1)
 
375
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
376
     & ERRQUIT('cxsd_e_1_2',0,MA_ERR)
 
377
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
378
      DO p3b = noab+1,noab+nvab
 
379
      DO h4b = 1,noab
 
380
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN
 
381
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_t) TH
 
382
     &EN
 
383
      CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1)
 
384
      CALL TCE_RESTRICTED_4(h6b,h4b,p5b,p3b,h6b_2,h4b_2,p5b_2,p3b_2)
 
385
      dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1)
 
386
      dima_sort = 1
 
387
      dima = dim_common * dima_sort
 
388
      dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1)
 
389
      dimb = dim_common * dimb_sort
 
390
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
391
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
392
     & ERRQUIT('cxsd_e_1_2',1,MA_ERR)
 
393
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
394
     &cxsd_e_1_2',2,MA_ERR)
 
395
#ifdef MRCC_LOCAL_T1
 
396
ckbn @did : localize t1amp
 
397
      CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima,
 
398
     + int_mb(k_a_offset),(h4b_1 - 1 + noab * (p3b_1 - noab - 1)))
 
399
#else
 
400
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1
 
401
     & - 1 + noab * (p3b_1 - noab - 1)))
 
402
#endif
 
403
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
404
     &,int_mb(k_range+h4b-1),2,1,1.0d0)
 
405
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cxsd_e_1_2',3,MA_ERR)
 
406
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
407
     & ERRQUIT('cxsd_e_1_2',4,MA_ERR)
 
408
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
409
     &cxsd_e_1_2',5,MA_ERR)
 
410
      IF ((h4b .le. h6b) .and. (p3b .le. p5b)) THEN
 
411
      if(.not.intorb) then
 
412
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
413
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
 
414
     &+nvab) * (h4b_2 - 1)))))
 
415
      else
 
416
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
417
     &(p5b_2
 
418
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
 
419
     &+nvab) * (h4b_2 - 1)))),p5b_2,p3b_2,h6b_2,h4b_2)
 
420
      end if
 
421
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
 
422
     &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1)
 
423
     &,4,2,1,3,1.0d0)
 
424
      END IF
 
425
      IF ((h4b .le. h6b) .and. (p5b .lt. p3b)) THEN
 
426
      if(.not.intorb) then
 
427
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
 
428
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
 
429
     &+nvab) * (h4b_2 - 1)))))
 
430
      else 
 
431
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
432
     &(p3b_2
 
433
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab
 
434
     &+nvab) * (h4b_2 - 1)))),p3b_2,p5b_2,h6b_2,h4b_2)
 
435
      end if
 
436
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1)
 
437
     &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1)
 
438
     &,3,2,1,4,-1.0d0)
 
439
      END IF
 
440
      IF ((h6b .lt. h4b) .and. (p3b .le. p5b)) THEN
 
441
      if(.not.intorb) THEN
 
442
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2
 
443
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
 
444
     &+nvab) * (h6b_2 - 1)))))
 
445
      else
 
446
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
447
     &(p5b_2
 
448
     & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
 
449
     &+nvab) * (h6b_2 - 1)))),p5b_2,p3b_2,h4b_2,h6b_2)
 
450
      end if
 
451
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
 
452
     &,int_mb(k_range+h4b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1)
 
453
     &,4,1,2,3,-1.0d0)
 
454
      END IF
 
455
      IF ((h6b .lt. h4b) .and. (p5b .lt. p3b)) THEN
 
456
      if(.not.intorb) then
 
457
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
 
458
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
 
459
     &+nvab) * (h6b_2 - 1)))))
 
460
      else
 
461
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
462
     &(p3b_2
 
463
     & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
 
464
     &+nvab) * (h6b_2 - 1)))),p3b_2,p5b_2,h4b_2,h6b_2)
 
465
      end if
 
466
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
 
467
     &,int_mb(k_range+h4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1)
 
468
     &,3,1,2,4,1.0d0)
 
469
      END IF
 
470
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cxsd_e_1_2',6,MA_ERR)
 
471
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
472
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
473
     &t),dima_sort)
 
474
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cxsd_e_1_2',7,MA_ER
 
475
     &R)
 
476
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cxsd_e_1_2',8,MA_ER
 
477
     &R)
 
478
      END IF
 
479
      END IF
 
480
      END IF
 
481
      END DO
 
482
      END DO
 
483
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
484
     &cxsd_e_1_2',9,MA_ERR)
 
485
      CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1)
 
486
     &,int_mb(k_range+h6b-1),2,1,1.0d0/2.0d0)
 
487
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b -
 
488
     & noab - 1 + nvab * (h6b - 1)))
 
489
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cxsd_e_1_2',10,MA_ERR)
 
490
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cxsd_e_1_2',11,MA_E
 
491
     &RR)
 
492
      END IF
 
493
      END IF
 
494
      END IF
 
495
      nex=NXTASKsub(nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
496
      END IF
 
497
      count = count + 1
 
498
      END DO
 
499
      END DO
 
500
      nex=NXTASKsub(-nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
501
      call GA_Pgroup_SYNC(int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
502
      RETURN
 
503
      END
 
504
      SUBROUTINE cxsd_e_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset)
 
505
C     $Id: cxsd_e.F,v 1.6 2007/09/14 18:41:34 kowalski Exp $
 
506
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
507
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
508
C     i0 ( )_vt + = 1/4 * Sum ( h3 h4 p1 p2 ) * t ( p1 p2 h3 h4 )_t * v ( h3 h4 p1 p2 )_v
 
509
      IMPLICIT NONE
 
510
#include "global.fh"
 
511
#include "mafdecls.fh"
 
512
#include "sym.fh"
 
513
#include "errquit.fh"
 
514
#include "tce.fh"
 
515
#include "tce_mrcc.fh"
 
516
      INTEGER d_a
 
517
      INTEGER k_a_offset
 
518
      INTEGER d_b
 
519
      INTEGER k_b_offset
 
520
      INTEGER d_c
 
521
      INTEGER k_c_offset
 
522
      INTEGER NXTASKsub
 
523
      INTEGER nex
 
524
      INTEGER nprocs
 
525
      INTEGER count
 
526
      INTEGER dimc
 
527
      INTEGER l_c_sort
 
528
      INTEGER k_c_sort
 
529
      INTEGER p1b
 
530
      INTEGER p2b
 
531
      INTEGER h3b
 
532
      INTEGER h4b
 
533
      INTEGER p1b_1
 
534
      INTEGER p2b_1
 
535
      INTEGER h3b_1
 
536
      INTEGER h4b_1
 
537
      INTEGER h3b_2
 
538
      INTEGER h4b_2
 
539
      INTEGER p1b_2
 
540
      INTEGER p2b_2
 
541
      INTEGER dim_common
 
542
      INTEGER dima_sort
 
543
      INTEGER dima
 
544
      INTEGER dimb_sort
 
545
      INTEGER dimb
 
546
      INTEGER l_a_sort
 
547
      INTEGER k_a_sort
 
548
      INTEGER l_a
 
549
      INTEGER k_a
 
550
      INTEGER l_b_sort
 
551
      INTEGER k_b_sort
 
552
      INTEGER l_b
 
553
      INTEGER k_b
 
554
      INTEGER nsuperp(2)
 
555
      INTEGER isuperp
 
556
      INTEGER nsubh(2)
 
557
      INTEGER isubh
 
558
      INTEGER l_c
 
559
      INTEGER k_c
 
560
      DOUBLE PRECISION FACTORIAL
 
561
      EXTERNAL NXTASKsub
 
562
      EXTERNAL FACTORIAL
 
563
      nprocs=GA_pgroup_NNODES(int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
564
      count = 0
 
565
      nex=NXTASKsub(nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
566
      IF (nex.eq.count) THEN
 
567
      IF (0 .eq. ieor(irrep_v,irrep_t)) THEN
 
568
      dimc = 1
 
569
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
570
     & ERRQUIT('cxsd_e_2',0,MA_ERR)
 
571
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
572
      DO p1b = noab+1,noab+nvab
 
573
      DO p2b = p1b,noab+nvab
 
574
      DO h3b = 1,noab
 
575
      DO h4b = h3b,noab
 
576
      IF (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h
 
577
     &3b-1)+int_mb(k_spin+h4b-1)) THEN
 
578
      IF (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),ieor(int_mb(
 
579
     &k_sym+h3b-1),int_mb(k_sym+h4b-1)))) .eq. irrep_t) THEN
 
580
      CALL TCE_RESTRICTED_4(p1b,p2b,h3b,h4b,p1b_1,p2b_1,h3b_1,h4b_1)
 
581
      CALL TCE_RESTRICTED_4(h3b,h4b,p1b,p2b,h3b_2,h4b_2,p1b_2,p2b_2)
 
582
      dim_common = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) * int_m
 
583
     &b(k_range+h3b-1) * int_mb(k_range+h4b-1)
 
584
      dima_sort = 1
 
585
      dima = dim_common * dima_sort
 
586
      dimb_sort = 1
 
587
      dimb = dim_common * dimb_sort
 
588
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
589
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
590
     & ERRQUIT('cxsd_e_2',1,MA_ERR)
 
591
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
592
     &cxsd_e_2',2,MA_ERR)
 
593
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1
 
594
     & - 1 + noab * (h3b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p1b_
 
595
     &1 - noab - 1)))))
 
596
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1)
 
597
     &,int_mb(k_range+p2b-1),int_mb(k_range+h3b-1),int_mb(k_range+h4b-1)
 
598
     &,4,3,2,1,1.0d0)
 
599
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cxsd_e_2',3,MA_ERR)
 
600
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
601
     & ERRQUIT('cxsd_e_2',4,MA_ERR)
 
602
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
603
     &cxsd_e_2',5,MA_ERR)
 
604
      if(.not.intorb) then
 
605
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2
 
606
     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
 
607
     &+nvab) * (h3b_2 - 1)))))
 
608
      else
 
609
      CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),
 
610
     &(p2b_2
 
611
     & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab
 
612
     &+nvab) * (h3b_2 - 1)))),p2b_2,p1b_2,h4b_2,h3b_2)
 
613
      end if
 
614
      CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1)
 
615
     &,int_mb(k_range+h4b-1),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1)
 
616
     &,2,1,4,3,1.0d0)
 
617
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cxsd_e_2',6,MA_ERR)
 
618
      nsuperp(1) = 1
 
619
      nsuperp(2) = 1
 
620
      isuperp = 1
 
621
      IF (p1b .eq. p2b) THEN
 
622
      nsuperp(isuperp) = nsuperp(isuperp) + 1
 
623
      ELSE
 
624
      isuperp = isuperp + 1
 
625
      END IF
 
626
      nsubh(1) = 1
 
627
      nsubh(2) = 1
 
628
      isubh = 1
 
629
      IF (h3b .eq. h4b) THEN
 
630
      nsubh(isubh) = nsubh(isubh) + 1
 
631
      ELSE
 
632
      isubh = isubh + 1
 
633
      END IF
 
634
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,4.0d0/FACTORIAL(
 
635
     &nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsubh(1))/FACTORIAL(ns
 
636
     &ubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.
 
637
     &0d0,dbl_mb(k_c_sort),dima_sort)
 
638
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cxsd_e_2',7,MA_ERR)
 
639
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cxsd_e_2',8,MA_ERR)
 
640
      END IF
 
641
      END IF
 
642
      END IF
 
643
      END DO
 
644
      END DO
 
645
      END DO
 
646
      END DO
 
647
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
648
     &cxsd_e_2',9,MA_ERR)
 
649
      CALL TCE_SORT_0(dbl_mb(k_c_sort),dbl_mb(k_c),1.0d0/4.0d0)
 
650
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),0)
 
651
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cxsd_e_2',10,MA_ERR)
 
652
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cxsd_e_2',11,MA_ERR
 
653
     &)
 
654
      END IF
 
655
      nex=NXTASKsub(nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
656
      END IF
 
657
      count = count + 1
 
658
      nex=NXTASKsub(-nprocs,1,int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
659
      call GA_Pgroup_SYNC(int_mb(k_innodes+ga_nnodes()+ga_nodeid()))
 
660
      RETURN
 
661
      END