← Back to branch summary

~ubuntu-branches/ubuntu/trusty/nwchem/trusty-proposed

« back to all changes in this revision

Viewing changes to src/tce/mrcc/ccsd/T2_C2.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/T2_C2.F
 
1
      SUBROUTINE T2_C2(d_i0,d_t1,d_t2,d_x1,d_x2,k_i0_offset,k_t1_offset,
 
2
     &k_t2_offset,k_x1_offset,k_x2_offset,coef)
 
3
C     $Id: tce.py,v 1.10 2002/12/01 21:37:34 sohirata 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 ( p3 p4 h1 h2 )_x + = 1 * x ( p3 p4 h1 h2 )_x
 
7
C     i0 ( p3 p4 h1 h2 )_xt + = 1 * P( 4 ) * t ( p3 h1 )_t * i1 ( p4 h2 )_x
 
8
C         i1 ( p3 h1 )_x + = 1 * x ( p3 h1 )_x
 
9
C         i1 ( p3 h1 )_t + = 1/2 * t ( p3 h1 )_t
 
10
C     i0 ( p3 p4 h1 h2 )_t + = 1 * t ( p3 p4 h1 h2 )_t
 
11
      IMPLICIT NONE
 
12
#include "global.fh"
 
13
#include "mafdecls.fh"
 
14
#include "util.fh"
 
15
#include "errquit.fh"
 
16
#include "tce.fh"
 
17
#include "tce_main.fh"
 
18
      INTEGER d_i0
 
19
      INTEGER k_i0_offset
 
20
      INTEGER d_x2
 
21
      INTEGER k_x2_offset
 
22
      INTEGER d_t1
 
23
      INTEGER k_t1_offset
 
24
      INTEGER d_i1
 
25
      INTEGER k_i1_offset
 
26
      INTEGER d_t2
 
27
      INTEGER k_t2_offset
 
28
      INTEGER l_i1_offset
 
29
      INTEGER d_x1
 
30
      INTEGER k_x1_offset
 
31
      INTEGER size_i1
 
32
      CHARACTER*255 filename
 
33
      double precision coef
 
34
      CALL T2_C2_1(d_x2,k_x2_offset,d_i0,k_i0_offset,coef)
 
35
      CALL OFFSET_T2_C2_2_1(l_i1_offset,k_i1_offset,size_i1)
 
36
      CALL TCE_FILENAME('T2_C2_2_1_i1',filename)
 
37
      CALL CREATEFILE(filename,d_i1,size_i1)
 
38
      CALL T2_C2_2_1(d_x1,k_x1_offset,d_i1,k_i1_offset)
 
39
      CALL T2_C2_2_2(d_t1,k_t1_offset,d_i1,k_i1_offset)
 
40
      CALL RECONCILEFILE(d_i1,size_i1)
 
41
      CALL T2_C2_2(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_i0_offset,
 
42
     1 coef)
 
43
      CALL DELETEFILE(d_i1)
 
44
      IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('T2_C2',-1,MA_ERR
 
45
     &)
 
46
      if(model.ne.'succsd') then
 
47
        CALL T2_C2_3(d_t2,k_t2_offset,d_i0,k_i0_offset,coef)
 
48
      endif
 
49
      RETURN
 
50
      END
 
51
      SUBROUTINE T2_C2_1(d_a,k_a_offset,d_c,k_c_offset,coef)
 
52
C     $Id: tce.py,v 1.10 2002/12/01 21:37:34 sohirata Exp $
 
53
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
54
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
55
C     i0 ( p3 p4 h1 h2 )_x + = 1 * x ( p3 p4 h1 h2 )_x
 
56
      IMPLICIT NONE
 
57
#include "global.fh"
 
58
#include "mafdecls.fh"
 
59
#include "sym.fh"
 
60
#include "errquit.fh"
 
61
#include "tce.fh"
 
62
      INTEGER d_a
 
63
      INTEGER k_a_offset
 
64
      INTEGER d_c
 
65
      INTEGER k_c_offset
 
66
      INTEGER NXTASK
 
67
      INTEGER next
 
68
      INTEGER nprocs
 
69
      INTEGER count
 
70
      INTEGER p3b
 
71
      INTEGER p4b
 
72
      INTEGER h1b
 
73
      INTEGER h2b
 
74
      INTEGER dimc
 
75
      INTEGER p3b_1
 
76
      INTEGER p4b_1
 
77
      INTEGER h1b_1
 
78
      INTEGER h2b_1
 
79
      INTEGER dim_common
 
80
      INTEGER dima_sort
 
81
      INTEGER dima
 
82
      INTEGER l_a_sort
 
83
      INTEGER k_a_sort
 
84
      INTEGER l_a
 
85
      INTEGER k_a
 
86
      INTEGER l_c
 
87
      INTEGER k_c
 
88
      EXTERNAL NXTASK
 
89
      double precision coef
 
90
      nprocs = GA_NNODES()
 
91
      count = 0
 
92
      next = NXTASK(nprocs,1)
 
93
      DO p3b = noab+1,noab+nvab
 
94
      DO p4b = p3b,noab+nvab
 
95
      DO h1b = 1,noab
 
96
      DO h2b = h1b,noab
 
97
      IF (next.eq.count) THEN
 
98
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
99
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
100
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
101
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
102
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
103
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_x) THEN
 
104
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
105
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
106
      CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h2b,p3b_1,p4b_1,h1b_1,h2b_1)
 
107
      dim_common = 1
 
108
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb
 
109
     &(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
110
      dima = dim_common * dima_sort
 
111
      IF (dima .gt. 0) THEN
 
112
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
113
     & ERRQUIT('T2_C2_1',0,MA_ERR)
 
114
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
115
     &T2_C2_1',1,MA_ERR)
 
116
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
117
     & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
 
118
     &1 - noab - 1)))))
 
119
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
120
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
121
     &,4,3,2,1,1.0d0)
 
122
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('T2_C2_1',2,MA_ERR)
 
123
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
124
     &T2_C2_1',3,MA_ERR)
 
125
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
126
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
127
     &,4,3,2,1,coef)
 
128
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
129
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
130
     & - 1)))))
 
131
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('T2_C2_1',4,MA_ERR)
 
132
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('T2_C2_1',5,MA_ERR)
 
133
      END IF
 
134
      END IF
 
135
      END IF
 
136
      END IF
 
137
      next = NXTASK(nprocs,1)
 
138
      END IF
 
139
      count = count + 1
 
140
      END DO
 
141
      END DO
 
142
      END DO
 
143
      END DO
 
144
      next = NXTASK(-nprocs,1)
 
145
      call GA_SYNC()
 
146
      RETURN
 
147
      END
 
148
      SUBROUTINE T2_C2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset,
 
149
     1 coef)
 
150
C     $Id: tce.py,v 1.10 2002/12/01 21:37:34 sohirata Exp $
 
151
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
152
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
153
C     i0 ( p3 p4 h1 h2 )_xt + = 1 * P( 4 ) * t ( p3 h1 )_t * i1 ( p4 h2 )_x
 
154
      IMPLICIT NONE
 
155
#include "global.fh"
 
156
#include "mafdecls.fh"
 
157
#include "sym.fh"
 
158
#include "errquit.fh"
 
159
#include "tce.fh"
 
160
      double precision coef
 
161
      INTEGER d_a
 
162
      INTEGER k_a_offset
 
163
      INTEGER d_b
 
164
      INTEGER k_b_offset
 
165
      INTEGER d_c
 
166
      INTEGER k_c_offset
 
167
      INTEGER NXTASK
 
168
      INTEGER next
 
169
      INTEGER nprocs
 
170
      INTEGER count
 
171
      INTEGER p3b
 
172
      INTEGER p4b
 
173
      INTEGER h1b
 
174
      INTEGER h2b
 
175
      INTEGER dimc
 
176
      INTEGER l_c_sort
 
177
      INTEGER k_c_sort
 
178
      INTEGER p3b_1
 
179
      INTEGER h1b_1
 
180
      INTEGER p4b_2
 
181
      INTEGER h2b_2
 
182
      INTEGER dim_common
 
183
      INTEGER dima_sort
 
184
      INTEGER dima
 
185
      INTEGER dimb_sort
 
186
      INTEGER dimb
 
187
      INTEGER l_a_sort
 
188
      INTEGER k_a_sort
 
189
      INTEGER l_a
 
190
      INTEGER k_a
 
191
      INTEGER l_b_sort
 
192
      INTEGER k_b_sort
 
193
      INTEGER l_b
 
194
      INTEGER k_b
 
195
      INTEGER l_c
 
196
      INTEGER k_c
 
197
      EXTERNAL NXTASK
 
198
      nprocs = GA_NNODES()
 
199
      count = 0
 
200
      next = NXTASK(nprocs,1)
 
201
      DO p3b = noab+1,noab+nvab
 
202
      DO p4b = noab+1,noab+nvab
 
203
      DO h1b = 1,noab
 
204
      DO h2b = 1,noab
 
205
      IF (next.eq.count) THEN
 
206
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
207
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
208
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
209
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
210
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
211
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_x,irrep_t)) TH
 
212
     &EN
 
213
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
214
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
215
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
 
216
     & ERRQUIT('T2_C2_2',0,MA_ERR)
 
217
      CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
 
218
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
219
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
220
     &EN
 
221
      CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1)
 
222
      CALL TCE_RESTRICTED_2(p4b,h2b,p4b_2,h2b_2)
 
223
      dim_common = 1
 
224
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
 
225
      dima = dim_common * dima_sort
 
226
      dimb_sort = int_mb(k_range+p4b-1) * int_mb(k_range+h2b-1)
 
227
      dimb = dim_common * dimb_sort
 
228
      IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
 
229
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
230
     & ERRQUIT('T2_C2_2',1,MA_ERR)
 
231
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
232
     &T2_C2_2',2,MA_ERR)
 
233
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
234
     & - 1 + noab * (p3b_1 - noab - 1)))
 
235
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
236
     &,int_mb(k_range+h1b-1),2,1,-1.0d0)
 
237
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('T2_C2_2',3,MA_ERR)
 
238
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
 
239
     & ERRQUIT('T2_C2_2',4,MA_ERR)
 
240
      IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
 
241
     &T2_C2_2',5,MA_ERR)
 
242
      CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h2b_2
 
243
     & - 1 + noab * (p4b_2 - noab - 1)))
 
244
      CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p4b-1)
 
245
     &,int_mb(k_range+h2b-1),2,1,1.0d0)
 
246
      IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('T2_C2_2',6,MA_ERR)
 
247
      CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
 
248
     &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
 
249
     &t),dima_sort)
 
250
      IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('T2_C2_2',7,MA_ERR)
 
251
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('T2_C2_2',8,MA_ERR)
 
252
      END IF
 
253
      END IF
 
254
      END IF
 
255
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
256
     &T2_C2_2',9,MA_ERR)
 
257
      IF ((p3b .le. p4b) .and. (h1b .le. h2b)) THEN
 
258
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
259
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
260
     &,4,2,3,1,coef)
 
261
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
262
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
263
     & - 1)))))
 
264
      END IF
 
265
      IF ((p3b .le. p4b) .and. (h2b .le. h1b)) THEN
 
266
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
267
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
268
     &,4,2,1,3,-coef)
 
269
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
270
     & 1 + noab * (h2b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
271
     & - 1)))))
 
272
      END IF
 
273
      IF ((p4b .le. p3b) .and. (h1b .le. h2b)) THEN
 
274
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
275
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
276
     &,2,4,3,1,-coef)
 
277
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
278
     & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
 
279
     & - 1)))))
 
280
      END IF
 
281
      IF ((p4b .le. p3b) .and. (h2b .le. h1b)) THEN
 
282
      CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
283
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1)
 
284
     &,2,4,1,3,coef)
 
285
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
286
     & 1 + noab * (h2b - 1 + noab * (p3b - noab - 1 + nvab * (p4b - noab
 
287
     & - 1)))))
 
288
      END IF
 
289
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('T2_C2_2',10,MA_ERR)
 
290
      IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('T2_C2_2',11,MA_ERR)
 
291
      END IF
 
292
      END IF
 
293
      END IF
 
294
      next = NXTASK(nprocs,1)
 
295
      END IF
 
296
      count = count + 1
 
297
      END DO
 
298
      END DO
 
299
      END DO
 
300
      END DO
 
301
      next = NXTASK(-nprocs,1)
 
302
      call GA_SYNC()
 
303
      RETURN
 
304
      END
 
305
      SUBROUTINE T2_C2_2_1(d_a,k_a_offset,d_c,k_c_offset)
 
306
C     $Id: tce.py,v 1.10 2002/12/01 21:37:34 sohirata Exp $
 
307
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
308
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
309
C     i1 ( p3 h1 )_x + = 1 * x ( p3 h1 )_x
 
310
      IMPLICIT NONE
 
311
#include "global.fh"
 
312
#include "mafdecls.fh"
 
313
#include "sym.fh"
 
314
#include "errquit.fh"
 
315
#include "tce.fh"
 
316
      INTEGER d_a
 
317
      INTEGER k_a_offset
 
318
      INTEGER d_c
 
319
      INTEGER k_c_offset
 
320
      INTEGER NXTASK
 
321
      INTEGER next
 
322
      INTEGER nprocs
 
323
      INTEGER count
 
324
      INTEGER p3b
 
325
      INTEGER h1b
 
326
      INTEGER dimc
 
327
      INTEGER p3b_1
 
328
      INTEGER h1b_1
 
329
      INTEGER dim_common
 
330
      INTEGER dima_sort
 
331
      INTEGER dima
 
332
      INTEGER l_a_sort
 
333
      INTEGER k_a_sort
 
334
      INTEGER l_a
 
335
      INTEGER k_a
 
336
      INTEGER l_c
 
337
      INTEGER k_c
 
338
      EXTERNAL NXTASK
 
339
      nprocs = GA_NNODES()
 
340
      count = 0
 
341
      next = NXTASK(nprocs,1)
 
342
      DO p3b = noab+1,noab+nvab
 
343
      DO h1b = 1,noab
 
344
      IF (next.eq.count) THEN
 
345
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h1b-1
 
346
     &).ne.4)) THEN
 
347
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
348
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH
 
349
     &EN
 
350
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
 
351
      CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1)
 
352
      dim_common = 1
 
353
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
 
354
      dima = dim_common * dima_sort
 
355
      IF (dima .gt. 0) THEN
 
356
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
357
     & ERRQUIT('T2_C2_2_1',0,MA_ERR)
 
358
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
359
     &T2_C2_2_1',1,MA_ERR)
 
360
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
361
     & - 1 + noab * (p3b_1 - noab - 1)))
 
362
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
363
     &,int_mb(k_range+h1b-1),2,1,1.0d0)
 
364
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('T2_C2_2_1',2,MA_ERR)
 
365
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
366
     &T2_C2_2_1',3,MA_ERR)
 
367
      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
 
368
     &,int_mb(k_range+p3b-1),2,1,1.0d0)
 
369
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
370
     & 1 + noab * (p3b - noab - 1)))
 
371
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('T2_C2_2_1',4,MA_ERR)
 
372
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('T2_C2_2_1',5,MA_ERR
 
373
     &)
 
374
      END IF
 
375
      END IF
 
376
      END IF
 
377
      END IF
 
378
      next = NXTASK(nprocs,1)
 
379
      END IF
 
380
      count = count + 1
 
381
      END DO
 
382
      END DO
 
383
      next = NXTASK(-nprocs,1)
 
384
      call GA_SYNC()
 
385
      RETURN
 
386
      END
 
387
      SUBROUTINE OFFSET_T2_C2_2_1(l_a_offset,k_a_offset,size)
 
388
C     $Id: tce.py,v 1.10 2002/12/01 21:37:34 sohirata Exp $
 
389
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
390
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
391
C     i1 ( p3 h1 )_x
 
392
      IMPLICIT NONE
 
393
#include "global.fh"
 
394
#include "mafdecls.fh"
 
395
#include "sym.fh"
 
396
#include "errquit.fh"
 
397
#include "tce.fh"
 
398
      INTEGER l_a_offset
 
399
      INTEGER k_a_offset
 
400
      INTEGER size
 
401
      INTEGER length
 
402
      INTEGER addr
 
403
      INTEGER p3b
 
404
      INTEGER h1b
 
405
      length = 0
 
406
      DO p3b = noab+1,noab+nvab
 
407
      DO h1b = 1,noab
 
408
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
409
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH
 
410
     &EN
 
411
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h1b-1
 
412
     &).ne.4)) THEN
 
413
      length = length + 1
 
414
      END IF
 
415
      END IF
 
416
      END IF
 
417
      END DO
 
418
      END DO
 
419
      IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off
 
420
     &set)) CALL ERRQUIT('T2_C2_2_1',0,MA_ERR)
 
421
      int_mb(k_a_offset) = length
 
422
      addr = 0
 
423
      size = 0
 
424
      DO p3b = noab+1,noab+nvab
 
425
      DO h1b = 1,noab
 
426
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
427
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH
 
428
     &EN
 
429
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h1b-1
 
430
     &).ne.4)) THEN
 
431
      addr = addr + 1
 
432
      int_mb(k_a_offset+addr) = h1b - 1 + noab * (p3b - noab - 1)
 
433
      int_mb(k_a_offset+length+addr) = size
 
434
      size = size + int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
 
435
      END IF
 
436
      END IF
 
437
      END IF
 
438
      END DO
 
439
      END DO
 
440
      RETURN
 
441
      END
 
442
      SUBROUTINE T2_C2_2_2(d_a,k_a_offset,d_c,k_c_offset)
 
443
C     $Id: tce.py,v 1.10 2002/12/01 21:37:34 sohirata Exp $
 
444
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
445
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
446
C     i1 ( p3 h1 )_t + = 1/2 * t ( p3 h1 )_t
 
447
      IMPLICIT NONE
 
448
#include "global.fh"
 
449
#include "mafdecls.fh"
 
450
#include "sym.fh"
 
451
#include "errquit.fh"
 
452
#include "tce.fh"
 
453
      INTEGER d_a
 
454
      INTEGER k_a_offset
 
455
      INTEGER d_c
 
456
      INTEGER k_c_offset
 
457
      INTEGER NXTASK
 
458
      INTEGER next
 
459
      INTEGER nprocs
 
460
      INTEGER count
 
461
      INTEGER p3b
 
462
      INTEGER h1b
 
463
      INTEGER dimc
 
464
      INTEGER p3b_1
 
465
      INTEGER h1b_1
 
466
      INTEGER dim_common
 
467
      INTEGER dima_sort
 
468
      INTEGER dima
 
469
      INTEGER l_a_sort
 
470
      INTEGER k_a_sort
 
471
      INTEGER l_a
 
472
      INTEGER k_a
 
473
      INTEGER l_c
 
474
      INTEGER k_c
 
475
      EXTERNAL NXTASK
 
476
      nprocs = GA_NNODES()
 
477
      count = 0
 
478
      next = NXTASK(nprocs,1)
 
479
      DO p3b = noab+1,noab+nvab
 
480
      DO h1b = 1,noab
 
481
      IF (next.eq.count) THEN
 
482
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h1b-1
 
483
     &).ne.4)) THEN
 
484
      IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN
 
485
      IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH
 
486
     &EN
 
487
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
 
488
      CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1)
 
489
      dim_common = 1
 
490
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1)
 
491
      dima = dim_common * dima_sort
 
492
      IF (dima .gt. 0) THEN
 
493
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
494
     & ERRQUIT('T2_C2_2_2',0,MA_ERR)
 
495
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
496
     &T2_C2_2_2',1,MA_ERR)
 
497
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1
 
498
     & - 1 + noab * (p3b_1 - noab - 1)))
 
499
      CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
500
     &,int_mb(k_range+h1b-1),2,1,-1.0d0)
 
501
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('T2_C2_2_2',2,MA_ERR)
 
502
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
503
     &T2_C2_2_2',3,MA_ERR)
 
504
      CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1)
 
505
     &,int_mb(k_range+p3b-1),2,1,1.0d0/2.0d0)
 
506
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b -
 
507
     & 1 + noab * (p3b - noab - 1)))
 
508
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('T2_C2_2_2',4,MA_ERR)
 
509
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('T2_C2_2_2',5,MA_ERR
 
510
     &)
 
511
      END IF
 
512
      END IF
 
513
      END IF
 
514
      END IF
 
515
      next = NXTASK(nprocs,1)
 
516
      END IF
 
517
      count = count + 1
 
518
      END DO
 
519
      END DO
 
520
      next = NXTASK(-nprocs,1)
 
521
      call GA_SYNC()
 
522
      RETURN
 
523
      END
 
524
      SUBROUTINE T2_C2_3(d_a,k_a_offset,d_c,k_c_offset,coef)
 
525
C     $Id: tce.py,v 1.10 2002/12/01 21:37:34 sohirata Exp $
 
526
C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
 
527
C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
 
528
C     i0 ( p3 p4 h1 h2 )_t + = 1 * t ( p3 p4 h1 h2 )_t
 
529
      IMPLICIT NONE
 
530
#include "global.fh"
 
531
#include "mafdecls.fh"
 
532
#include "sym.fh"
 
533
#include "errquit.fh"
 
534
#include "tce.fh"
 
535
      double precision coef
 
536
      INTEGER d_a
 
537
      INTEGER k_a_offset
 
538
      INTEGER d_c
 
539
      INTEGER k_c_offset
 
540
      INTEGER NXTASK
 
541
      INTEGER next
 
542
      INTEGER nprocs
 
543
      INTEGER count
 
544
      INTEGER p3b
 
545
      INTEGER p4b
 
546
      INTEGER h1b
 
547
      INTEGER h2b
 
548
      INTEGER dimc
 
549
      INTEGER p3b_1
 
550
      INTEGER p4b_1
 
551
      INTEGER h1b_1
 
552
      INTEGER h2b_1
 
553
      INTEGER dim_common
 
554
      INTEGER dima_sort
 
555
      INTEGER dima
 
556
      INTEGER l_a_sort
 
557
      INTEGER k_a_sort
 
558
      INTEGER l_a
 
559
      INTEGER k_a
 
560
      INTEGER l_c
 
561
      INTEGER k_c
 
562
      EXTERNAL NXTASK
 
563
      nprocs = GA_NNODES()
 
564
      count = 0
 
565
      next = NXTASK(nprocs,1)
 
566
      DO p3b = noab+1,noab+nvab
 
567
      DO p4b = p3b,noab+nvab
 
568
      DO h1b = 1,noab
 
569
      DO h2b = h1b,noab
 
570
      IF (next.eq.count) THEN
 
571
      IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1
 
572
     &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN
 
573
      IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h
 
574
     &1b-1)+int_mb(k_spin+h2b-1)) THEN
 
575
      IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p4b-1),ieor(int_mb(
 
576
     &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN
 
577
      dimc = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb(k_ra
 
578
     &nge+h1b-1) * int_mb(k_range+h2b-1)
 
579
      CALL TCE_RESTRICTED_4(p3b,p4b,h1b,h2b,p3b_1,p4b_1,h1b_1,h2b_1)
 
580
      dim_common = 1
 
581
      dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_mb
 
582
     &(k_range+h1b-1) * int_mb(k_range+h2b-1)
 
583
      dima = dim_common * dima_sort
 
584
      IF (dima .gt. 0) THEN
 
585
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
 
586
     & ERRQUIT('T2_C2_3',0,MA_ERR)
 
587
      IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
 
588
     &T2_C2_3',1,MA_ERR)
 
589
      CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1
 
590
     & - 1 + noab * (h1b_1 - 1 + noab * (p4b_1 - noab - 1 + nvab * (p3b_
 
591
     &1 - noab - 1)))))
 
592
      CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1)
 
593
     &,int_mb(k_range+p4b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1)
 
594
     &,4,3,2,1,1.0d0)
 
595
      IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('T2_C2_3',2,MA_ERR)
 
596
      IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
 
597
     &T2_C2_3',3,MA_ERR)
 
598
      CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h2b-1)
 
599
     &,int_mb(k_range+h1b-1),int_mb(k_range+p4b-1),int_mb(k_range+p3b-1)
 
600
     &,4,3,2,1,-coef)
 
601
      CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b -
 
602
     & 1 + noab * (h1b - 1 + noab * (p4b - noab - 1 + nvab * (p3b - noab
 
603
     & - 1)))))
 
604
      IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('T2_C2_3',4,MA_ERR)
 
605
      IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('T2_C2_3',5,MA_ERR)
 
606
      END IF
 
607
      END IF
 
608
      END IF
 
609
      END IF
 
610
      next = NXTASK(nprocs,1)
 
611
      END IF
 
612
      count = count + 1
 
613
      END DO
 
614
      END DO
 
615
      END DO
 
616
      END DO
 
617
      next = NXTASK(-nprocs,1)
 
618
      call GA_SYNC()
 
619
      RETURN
 
620
      END