← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/tce/diis/tce_jacobi_x2.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/diis/tce_jacobi_x2.F
1
1
      subroutine tce_jacobi_x2(d_r2,k_r2_offset)
2
2
c
3
 
c $Id: tce_jacobi_x2.F,v 1.1 2008-09-30 18:35:47 jhammond Exp $
4
 
c
5
 
      implicit none
6
 
#include "global.fh"
7
 
#include "mafdecls.fh"
8
 
#include "sym.fh"
9
 
#include "util.fh"
10
 
#include "stdio.fh"
11
 
#include "errquit.fh"
12
 
#include "tce.fh"
13
 
#include "tce_main.fh"
14
 
#include "tce_diis.fh"
15
 
      integer d_r2
16
 
      integer p1b
17
 
      integer p2b
18
 
      integer h3b
19
 
      integer h4b
20
 
      integer p1
21
 
      integer p2
22
 
      integer h3
23
 
      integer h4
24
 
      integer k_r2_offset
25
 
      integer size
26
 
      integer l_r2,k_r2
27
 
      integer i
28
 
      integer nprocs
29
 
      integer count
30
 
      integer next
31
 
cc      integer nxtval
32
 
cc      external nxtval
33
 
      INTEGER NXTASK
34
 
      EXTERNAL NXTASK
35
 
      logical nodezero
36
 
      logical noloadbalance
37
 
c
38
 
      nodezero = (ga_nodeid().eq.0)
39
 
      noloadbalance = ((ioalg.eq.4).or. 
40
 
     1                ((ioalg.eq.6).and.(.not.fileisga(d_r2))))
41
 
      nprocs = ga_nnodes()
42
 
      count = 0
43
 
cc      next = nxtval(nprocs)
44
 
      next = NXTASK(nprocs, 1)
45
 
      do p1b = noab+1,noab+nvab
46
 
        do p2b = p1b,noab+nvab
47
 
          do h3b = 1,noab
48
 
            do h4b = h3b,noab
49
 
              if (noloadbalance.or.(next.eq.count)) then
50
 
                if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1) 
51
 
     1            .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then
52
 
                if ((.not.restricted).or.
53
 
     1            (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+
54
 
     2            int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then
55
 
                if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),
56
 
     1            ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1))))
57
 
     2            .eq. irrep_x) then
58
 
                  size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1)
59
 
     1                 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1)
60
 
                  if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2))
61
 
     1              call errquit('tce_jacobi_x2: MA problem',0,MA_ERR)
62
 
                  call get_hash_block(d_r2,dbl_mb(k_r2),size,
63
 
     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
64
 
     2              *noab+h3b-1)*noab+h4b-1))
65
 
                  i = 0
66
 
                  do p1 = 1,int_mb(k_range+p1b-1)
67
 
                    do p2 = 1,int_mb(k_range+p2b-1)
68
 
                      do h3 = 1,int_mb(k_range+h3b-1)
69
 
                        do h4 = 1,int_mb(k_range+h4b-1)
70
 
                          i = i + 1
71
 
                          dbl_mb(k_r2+i-1) = dbl_mb(k_r2+i-1)
72
 
     1           / (-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1)
73
 
     2              -dbl_mb(k_evl_sorted+int_mb(k_offset+p2b-1)+p2-1)
74
 
     3              +dbl_mb(k_evl_sorted+int_mb(k_offset+h3b-1)+h3-1)
75
 
     4              +dbl_mb(k_evl_sorted+int_mb(k_offset+h4b-1)+h4-1))
76
 
                        enddo
77
 
                      enddo
78
 
                    enddo
79
 
                  enddo
80
 
                  call put_hash_block(d_r2,dbl_mb(k_r2),size,
81
 
     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
82
 
     2              *noab+h3b-1)*noab+h4b-1))
83
 
                  if (.not.ma_pop_stack(l_r2))
84
 
     1              call errquit('tce_jacobi_x2: MA problem',1,MA_ERR)
85
 
                endif
86
 
                endif
87
 
                endif
88
 
cc                next = nxtval(nprocs)
89
 
      next = NXTASK(nprocs, 1)
90
 
              endif
91
 
              count = count + 1
92
 
            enddo
93
 
          enddo
94
 
        enddo
95
 
      enddo
96
 
cc      next = nxtval(-nprocs)
97
 
      next = NXTASK(-nprocs, 1)
98
 
      call ga_sync()
99
 
      return
100
 
      end
 
3
c $Id: tce_jacobi_x2.F 21255 2011-10-20 18:40:40Z kowalski $
 
4
c
 
5
      implicit none
 
6
#include "global.fh"
 
7
#include "mafdecls.fh"
 
8
#include "sym.fh"
 
9
#include "util.fh"
 
10
#include "stdio.fh"
 
11
#include "errquit.fh"
 
12
#include "tce.fh"
 
13
#include "tce_main.fh"
 
14
#include "tce_diis.fh"
 
15
      integer d_r2
 
16
      integer p1b
 
17
      integer p2b
 
18
      integer h3b
 
19
      integer h4b
 
20
      integer p1
 
21
      integer p2
 
22
      integer h3
 
23
      integer h4
 
24
      integer k_r2_offset
 
25
      integer size
 
26
      integer l_r2,k_r2
 
27
      integer i
 
28
      integer nprocs
 
29
      integer count
 
30
      integer next
 
31
cc      integer nxtval
 
32
cc      external nxtval
 
33
      INTEGER NXTASK
 
34
      EXTERNAL NXTASK
 
35
      logical nodezero
 
36
      logical noloadbalance
 
37
c
 
38
      nodezero = (ga_nodeid().eq.0)
 
39
      noloadbalance = ((ioalg.eq.4).or. 
 
40
     1                ((ioalg.eq.6).and.(.not.fileisga(d_r2))))
 
41
      nprocs = ga_nnodes()
 
42
      count = 0
 
43
cc      next = nxtval(nprocs)
 
44
      next = NXTASK(nprocs, 1)
 
45
      do p1b = noab+1,noab+nvab
 
46
        do p2b = p1b,noab+nvab
 
47
          do h3b = 1,noab
 
48
            do h4b = h3b,noab
 
49
              if (noloadbalance.or.(next.eq.count)) then
 
50
                if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1) 
 
51
     1            .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then
 
52
                if ((.not.restricted).or.
 
53
     1            (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+
 
54
     2            int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then
 
55
                if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),
 
56
     1            ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1))))
 
57
     2            .eq. irrep_x) then
 
58
                  size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1)
 
59
     1                 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1)
 
60
                  if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2))
 
61
     1              call errquit('tce_jacobi_x2: MA problem',0,MA_ERR)
 
62
                  call get_hash_block(d_r2,dbl_mb(k_r2),size,
 
63
     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
 
64
     2              *noab+h3b-1)*noab+h4b-1))
 
65
                  i = 0
 
66
                  do p1 = 1,int_mb(k_range+p1b-1)
 
67
                    do p2 = 1,int_mb(k_range+p2b-1)
 
68
                      do h3 = 1,int_mb(k_range+h3b-1)
 
69
                        do h4 = 1,int_mb(k_range+h4b-1)
 
70
                          i = i + 1
 
71
                          dbl_mb(k_r2+i-1) = dbl_mb(k_r2+i-1)
 
72
     1           / (-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1)
 
73
     2              -dbl_mb(k_evl_sorted+int_mb(k_offset+p2b-1)+p2-1)
 
74
     3              +dbl_mb(k_evl_sorted+int_mb(k_offset+h3b-1)+h3-1)
 
75
     4              +dbl_mb(k_evl_sorted+int_mb(k_offset+h4b-1)+h4-1))
 
76
                        enddo
 
77
                      enddo
 
78
                    enddo
 
79
                  enddo
 
80
                  call put_hash_block(d_r2,dbl_mb(k_r2),size,
 
81
     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
 
82
     2              *noab+h3b-1)*noab+h4b-1))
 
83
                  if (.not.ma_pop_stack(l_r2))
 
84
     1              call errquit('tce_jacobi_x2: MA problem',1,MA_ERR)
 
85
                endif
 
86
                endif
 
87
                endif
 
88
cc                next = nxtval(nprocs)
 
89
      next = NXTASK(nprocs, 1)
 
90
              endif
 
91
              count = count + 1
 
92
            enddo
 
93
          enddo
 
94
        enddo
 
95
      enddo
 
96
cc      next = nxtval(-nprocs)
 
97
      next = NXTASK(-nprocs, 1)
 
98
      call ga_sync()
 
99
      return
 
100
      end
 
101
c
 
102
c
 
103
c
 
104
      subroutine tce_jacobi_x2a(d_r2,k_r2_offset,omega)
 
105
c
 
106
c $Id: tce_jacobi_x2.F 21255 2011-10-20 18:40:40Z kowalski $
 
107
c
 
108
      implicit none
 
109
#include "global.fh"
 
110
#include "mafdecls.fh"
 
111
#include "sym.fh"
 
112
#include "util.fh"
 
113
#include "stdio.fh"
 
114
#include "errquit.fh"
 
115
#include "tce.fh"
 
116
#include "tce_main.fh"
 
117
#include "tce_diis.fh"
 
118
      integer d_r2
 
119
      integer p1b
 
120
      integer p2b
 
121
      integer h3b
 
122
      integer h4b
 
123
      integer p1
 
124
      integer p2
 
125
      integer h3
 
126
      integer h4
 
127
      integer k_r2_offset
 
128
      integer size
 
129
      integer l_r2,k_r2
 
130
      integer i
 
131
      LOGICAL is_active_1,is_active_2,is_active_3,is_active_4
 
132
      integer nprocs
 
133
      integer count
 
134
      integer next
 
135
      double precision omega
 
136
cc      integer nxtval
 
137
cc      external nxtval
 
138
      INTEGER NXTASK
 
139
      EXTERNAL NXTASK
 
140
      logical nodezero
 
141
      logical noloadbalance
 
142
c
 
143
      nodezero = (ga_nodeid().eq.0)
 
144
      noloadbalance = ((ioalg.eq.4).or. 
 
145
     1                ((ioalg.eq.6).and.(.not.fileisga(d_r2))))
 
146
      nprocs = ga_nnodes()
 
147
      count = 0
 
148
cc      next = nxtval(nprocs)
 
149
      next = NXTASK(nprocs, 1)
 
150
      do p1b = noab+1,noab+nvab
 
151
        do p2b = p1b,noab+nvab
 
152
          do h3b = 1,noab
 
153
            do h4b = h3b,noab
 
154
              if (noloadbalance.or.(next.eq.count)) then
 
155
                IF(is_active_4(p1b,p2b,h3b,h4b)) THEN
 
156
                if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1) 
 
157
     1            .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then
 
158
                if ((.not.restricted).or.
 
159
     1            (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+
 
160
     2            int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then
 
161
                if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),
 
162
     1            ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1))))
 
163
     2            .eq. irrep_x) then
 
164
                  size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1)
 
165
     1                 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1)
 
166
                  if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2))
 
167
     1              call errquit('tce_jacobi_x2: MA problem',0,MA_ERR)
 
168
                  call get_hash_block(d_r2,dbl_mb(k_r2),size,
 
169
     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
 
170
     2              *noab+h3b-1)*noab+h4b-1))
 
171
                  i = 0
 
172
                  do p1 = 1,int_mb(k_range+p1b-1)
 
173
                    do p2 = 1,int_mb(k_range+p2b-1)
 
174
                      do h3 = 1,int_mb(k_range+h3b-1)
 
175
                        do h4 = 1,int_mb(k_range+h4b-1)
 
176
                          i = i + 1
 
177
                          dbl_mb(k_r2+i-1) = dbl_mb(k_r2+i-1)
 
178
     1           / (-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1)
 
179
     2              -dbl_mb(k_evl_sorted+int_mb(k_offset+p2b-1)+p2-1)
 
180
     3              +dbl_mb(k_evl_sorted+int_mb(k_offset+h3b-1)+h3-1)
 
181
     4              +dbl_mb(k_evl_sorted+int_mb(k_offset+h4b-1)+h4-1))
 
182
                        enddo
 
183
                      enddo
 
184
                    enddo
 
185
                  enddo
 
186
                  call put_hash_block(d_r2,dbl_mb(k_r2),size,
 
187
     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
 
188
     2              *noab+h3b-1)*noab+h4b-1))
 
189
                  if (.not.ma_pop_stack(l_r2))
 
190
     1              call errquit('tce_jacobi_x2: MA problem',1,MA_ERR)
 
191
                endif
 
192
                endif
 
193
                endif
 
194
                endif
 
195
cc                next = nxtval(nprocs)
 
196
      next = NXTASK(nprocs, 1)
 
197
              endif
 
198
              count = count + 1
 
199
            enddo
 
200
          enddo
 
201
        enddo
 
202
      enddo
 
203
cc      next = nxtval(-nprocs)
 
204
      next = NXTASK(-nprocs, 1)
 
205
      call ga_sync()
 
206
      return
 
207
      end
 
208
c