← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/tools/ga-5-2/global/testing/ngatest_src/ndim_NGA_DOT_PATCH.src

  • 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/tools/ga-5-2/global/testing/ngatest_src/ndim_NGA_DOT_PATCH.src
 
1
      subroutine m4_func_NGA_DOT_PATCH(m4_test_type, m4_ndim)
 
2
      implicit none
 
3
#include "mafdecls.fh"
 
4
#include "global.fh"
 
5
c     
 
6
      integer n,m
 
7
      integer ndim
 
8
      parameter (n = m4_n)
 
9
      parameter (m = (m4_n**m4_ndim)/100)
 
10
      parameter (ndim = m4_ndim)
 
11
      m4_data_type a(substr(m4_array, 1, eval(m4_ndim*2-1)))
 
12
      m4_data_type b(substr(m4_array, 1, eval(m4_ndim*2-1)))
 
13
      m4_data_type c(substr(m4_array, 1, eval(m4_ndim*2-1)))
 
14
      integer dims(ndim)
 
15
      integer g_a, g_b
 
16
      integer chunk(ndim)
 
17
      integer i, total
 
18
      integer elems, count_elems
 
19
      integer loop
 
20
      integer lop(ndim), hip(ndim), hipl(ndim)
 
21
      integer alo(ndim), ahi(ndim)
 
22
      integer blo(ndim), bhi(ndim)
 
23
      integer tlo(ndim), thi(ndim)
 
24
      m4_data_type alpha, beta
 
25
      m4_data_type m4_util_dot_patch(m4_test_type)
 
26
c     for different array dimensions
 
27
      ifelse(m4_ndim,1,`',`
 
28
      m4_data_type d(substr(m4_array, 1, eval((m4_ndim-1)*2-1)))
 
29
      integer dndim
 
30
      parameter (dndim = m4_ndim-1)
 
31
      integer ddims(dndim),dlo(dndim),dhi(dndim),dtotal
 
32
      ')
 
33
c      
 
34
      integer nproc, me
 
35
      logical status
 
36
      integer repeat
 
37
c     
 
38
      nproc = ga_nnodes()
 
39
      me    = ga_nodeid()
 
40
c     
 
41
c---------------------- initialize the GA -----------------------
 
42
c     initialize the chunk, dims, ld, and calculate the number 
 
43
c     of elements
 
44
      total=1
 
45
      do i = 1,ndim
 
46
         chunk(i) = 0
 
47
         dims(i) = n
 
48
         total = total * dims(i)
 
49
      enddo
 
50
c
 
51
c***  Create global arrays
 
52
      if (.not. nga_create(m4_MT, ndim, dims, 'a', chunk, g_a))
 
53
     $     call ga_error(' ga_create failed ',1)
 
54
c
 
55
c     test the same distribution and different distribution seperately
 
56
      do repeat=1,2
 
57
         if(repeat.eq.1) then
 
58
            status = ga_duplicate(g_a, g_b, 'a_duplicated')
 
59
            if(.not.ga_compare_distr(g_a, g_b))
 
60
     $           call ga_error("g_b distribution different",0)
 
61
c
 
62
         else
 
63
            do i = 1,ndim
 
64
               if(mod(i,2).eq.0) chunk(i) = n
 
65
            enddo
 
66
            if (.not. nga_create(m4_MT, ndim, dims, 'b', chunk, g_b))
 
67
     $           call ga_error(' ga_create failed ',1)
 
68
         endif
 
69
c
 
70
         call ga_sync()
 
71
c     
 
72
c---------------------------NGA_DOT_PATCH -------------------------
 
73
c
 
74
      if(repeat.eq.1) then
 
75
         m4_print_info(m4_nga_dot_patch(m4_dot))
 
76
         if(me.eq.0) print *, 'Testing with the same distributions'
 
77
      else
 
78
         if(me.eq.0) print *, 'Testing with different distributions'
 
79
      endif
 
80
c     
 
81
c     initialize GA
 
82
      call m4_util_init_array(m4_test_type)(a,total)
 
83
      call nga_distribution(g_a, me, lop, hip)
 
84
      elems = count_elems(lop, hip, ndim)
 
85
      if(elems.gt.0) call nga_put(g_a,lop,hip,
 
86
     $     a(substr(m4_lop_all, 1, eval(m4_ndim*7-1))),dims)
 
87
      call m4_util_init_array(m4_test_type)(b,total)
 
88
      call nga_distribution(g_b, me, lop, hip)
 
89
      elems = count_elems(lop, hip, ndim)
 
90
      if(elems.gt.0) call nga_put(g_b,lop,hip,
 
91
     $     b(substr(m4_lop_all, 1, eval(m4_ndim*7-1))),dims)
 
92
c     
 
93
      call ga_sync()
 
94
      do i = 1,ndim
 
95
         lop(i) = 1
 
96
         hipl(i) = n-1
 
97
         hip(i) = n
 
98
      enddo
 
99
c     
 
100
c---  
 
101
      do loop=1, 10
 
102
         call random_range(lop,hipl,alo,ahi,ndim)
 
103
         do i=1, ndim
 
104
            blo(i) = alo(i) + 1
 
105
            bhi(i) = ahi(i) + 1
 
106
         enddo
 
107
         if(me.eq.0)then
 
108
            call dot_range(loop,alo,ahi,ndim,blo,bhi,ndim)
 
109
c$$$            print *, loop,'dot: [',(alo(i),':',ahi(i), i=1,ndim),']', 
 
110
c$$$     $           ',', '[',(blo(i),':',bhi(i), i=1,ndim),']'
 
111
         endif
 
112
c
 
113
         alpha=m4_nga_dot_patch(m4_dot)(g_a,'n',alo,ahi,g_b,'n',blo,bhi)
 
114
c
 
115
c        the result should be 
 
116
         beta = m4_util_dot_patch(m4_test_type)(total,
 
117
     $        a,alo,ahi,ndim,dims,b,blo,bhi,ndim,dims)
 
118
c     
 
119
         if(ABS(beta-alpha).gt.1d-6*ABS(alpha)) then
 
120
            print *,me, ' error ', beta, alpha
 
121
            call ga_error('exiting ...',0)
 
122
         endif
 
123
c
 
124
      enddo
 
125
c     
 
126
      call ga_sync()
 
127
      if(me.eq.0)then
 
128
         print *, ' without transpose OK'
 
129
         print *, ' '
 
130
         call ffflush(6)
 
131
      endif
 
132
c---  
 
133
c     prepare array a, make it transposed
 
134
      call m4_util_transpose(m4_test_type)(b,c,total,ndim,dims)
 
135
c
 
136
      do loop=1, 10
 
137
         call random_range(lop,hipl,alo,ahi,ndim)
 
138
         do i=1, ndim
 
139
            blo(i) = alo(i) + 1
 
140
            bhi(i) = ahi(i) + 1
 
141
         enddo
 
142
         if(me.eq.0)then
 
143
            call dot_range(loop,alo,ahi,ndim,blo,bhi,ndim)
 
144
c$$$            print *, loop,'dot: [',(alo(i),':',ahi(i), i=1,ndim),']', 
 
145
c$$$     $           ',', '[',(blo(i),':',bhi(i), i=1,ndim),']'
 
146
         endif
 
147
c
 
148
         alpha=m4_nga_dot_patch(m4_dot)(g_a,'n',alo,ahi,g_b,'t',blo,bhi)
 
149
c
 
150
c        adjust index of array a
 
151
         do i=1,ndim
 
152
            tlo(i) = blo(ndim-i+1)
 
153
            thi(i) = bhi(ndim-i+1)
 
154
         enddo
 
155
c     
 
156
c        the result should be 
 
157
         beta = m4_util_dot_patch(m4_test_type)(total,
 
158
     $        a,alo,ahi,ndim,dims,b,tlo,thi,ndim,dims)
 
159
c     
 
160
         if(ABS(beta-alpha).gt.1d-6*ABS(alpha)) then
 
161
            print *,me, ' error ', beta, alpha
 
162
            call ga_error('exiting ...',0)
 
163
         endif
 
164
c
 
165
      enddo
 
166
c     
 
167
      call ga_sync()
 
168
      if(me.eq.0)then
 
169
         print *, ' with transpose OK'
 
170
         print *, ' '
 
171
         call ffflush(6)
 
172
      endif
 
173
c---------------------------
 
174
c     
 
175
         status = ga_destroy(g_b)
 
176
      enddo
 
177
c
 
178
c-----------------------------------------------------------------
 
179
      changequote({,})
 
180
      ifelse(m4_ndim,1,{},{
 
181
c     testing copy on differet dimensions
 
182
      dtotal = 1
 
183
      do i = 1,dndim
 
184
         ddims(i) = n
 
185
         dtotal = dtotal * ddims(i)
 
186
      enddo
 
187
c     
 
188
      if (.not. nga_create(m4_MT, dndim, ddims, 'd', chunk, g_b))
 
189
     $     call ga_error(' ga_create failed ',1)
 
190
c     
 
191
      if(me.eq.0) 
 
192
     $     print *, 'Testing dot patch on different dimensions'
 
193
c     
 
194
c     initialize GAs
 
195
      call m4_util_init_array(m4_test_type)(a,total)
 
196
      call nga_distribution(g_a, me, lop, hip)
 
197
      elems = count_elems(lop, hip, ndim)
 
198
      if(elems.gt.0) call nga_put(g_a,lop,hip,
 
199
     $     a(substr(m4_lop_all, 1, eval(m4_ndim*7-1))),dims)
 
200
      call m4_util_init_array(m4_test_type)(d,dtotal)
 
201
      call nga_distribution(g_b, me, dlo, dhi)
 
202
      elems = count_elems(dlo, dhi, dndim)
 
203
      if(elems.gt.0) call nga_put(g_b,dlo,dhi,
 
204
     $     d(substr(m4_dlo_all, 1, eval((m4_ndim-1)*7-1))),ddims)
 
205
c     
 
206
      call ga_sync()
 
207
c     
 
208
c     calculate the maximum range of g_a that can fit into g_b
 
209
      do i = 1,ndim
 
210
         lop(i) = 1
 
211
         hip(i) = n
 
212
      enddo
 
213
      hip(dndim) = 1
 
214
c     
 
215
      do loop=1, 10
 
216
         call random_range(lop,hip,alo,ahi,ndim)
 
217
c     
 
218
         do i=1, dndim
 
219
            dlo(i) = alo(dndim-i+1)
 
220
            dhi(i) = ahi(dndim-i+1)
 
221
         enddo
 
222
         dlo(1) = alo(ndim)
 
223
         dhi(1) = ahi(ndim)
 
224
c     
 
225
         if(me.eq.0) then
 
226
            call dot_range(loop,alo,ahi,ndim,dlo,dhi,dndim)
 
227
c$$$            print *,loop,'dot: [',(alo(i),':',ahi(i), i=1,ndim),']', 
 
228
c$$$     $           ',', '[',(dlo(i),':',dhi(i), i=1,dndim),']'
 
229
         endif
 
230
c     
 
231
         alpha=m4_nga_dot_patch(m4_dot)(g_a,'n',alo,ahi,
 
232
     $        g_b,'n',dlo,dhi)
 
233
c     
 
234
c     the result should be 
 
235
         beta = m4_util_dot_patch(m4_test_type)(total,
 
236
     $        a,alo,ahi,ndim,dims,d,dlo,dhi,dndim,ddims)
 
237
c     
 
238
         if(ABS(beta-alpha).gt.1d-6*ABS(alpha)) then
 
239
            print *,me, ' error ', beta, alpha
 
240
            call ga_error('exiting ...',0)
 
241
         endif
 
242
c     
 
243
      enddo
 
244
c     
 
245
      call ga_sync()
 
246
      if(me.eq.0)then
 
247
         print *, '  dot patch on different dimensions: OK'
 
248
         print *, ' '
 
249
         call ffflush(6)
 
250
      endif            
 
251
c     
 
252
      status = ga_destroy(g_b)
 
253
      })
 
254
      changequote(`,')
 
255
c---  
 
256
      status = ga_destroy(g_a)
 
257
      end