← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/tools/ga-5-1/global/testing/d2test.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/tools/ga-5-1/global/testing/d2test.F
1
 
#if HAVE_CONFIG_H
2
 
#   include "config.fh"
3
 
#endif
4
 
c vector boxes lack arithmetic precision 
5
 
#ifdef CRAY_YMP
6
 
# define THRESH 1d-10
7
 
#elif defined(FUJITSU)
8
 
# define THRESH 1d-12
9
 
# define THRESHF 1e-5
10
 
#else
11
 
# define THRESH 1d-13
12
 
# define THRESHF 1e-5
13
 
#endif
14
 
#define MISMATCH(x,y) abs(x-y)/max(1d0,abs(x)).gt.THRESH
15
 
#define MISMATCHF(x,y) abs(x-y)/max(1.0,abs(x)).gt.THRESHF
16
 
 
17
 
 
18
 
      program main
19
 
      implicit none
20
 
#include "mafdecls.fh"
21
 
#include "global.fh"
22
 
#include "testutil.fh"
23
 
      integer heap, stack, fudge, ma_heap, me
24
 
      integer nmax, DIM, nwidth, MAXPROC, nloop
25
 
      parameter (nmax = 4, DIM = 2, nwidth = 2, MAXPROC = 2000)
26
 
      parameter (nloop = 1)
27
 
      integer ndim, nproc, pdims(7), type, dcnt, g_a, maxval
28
 
      integer i, j, k, dims(7), width(7), map(2*nmax)
29
 
      integer lo(7), hi(7), ld(7)
30
 
      integer lo2(7), hi2(7), ld2(7)
31
 
      integer dims3(7), ld3(7), index3, chunk(7)
32
 
      integer a(nmax, nmax), b(nmax+2*nwidth,nmax+2*nwidth)
33
 
      double precision start,finish,start1,finish1,t1,t2,t3,t4,t5,tmp
34
 
      double precision t6,t7
35
 
      logical status, safe_put, safe_get, has_data(0:MAXPROC-1)
36
 
      parameter (heap=60*60*4, fudge=100, stack=100*100)
37
 
c     
38
 
c***  Intitialize a message passing library
39
 
c
40
 
#include "mp3.fh"
41
 
c
42
 
c***  Initialize GA
43
 
c
44
 
c     There are 2 choices: ga_initialize or ga_initialize_ltd.
45
 
c     In the first case, there is no explicit limit on memory usage.
46
 
c     In the second, user can set limit (per processor) in bytes.
47
 
c
48
 
      print*
49
 
      call ga_initialize()
50
 
      nproc = ga_nnodes()
51
 
      me = ga_nodeid()
52
 
c     we can also use GA_set_memory_limit BEFORE first ga_create call
53
 
c
54
 
      ma_heap = heap + fudge 
55
 
      call GA_set_memory_limit(util_mdtob(ma_heap))
56
 
c
57
 
      if(ga_nodeid().eq.0)then
58
 
         print *,' GA initialized '
59
 
         call ffflush(6)
60
 
      endif
61
 
c
62
 
c***  Initialize the MA package
63
 
c     MA must be initialized before any global array is allocated
64
 
c
65
 
      status = ma_init(MT_DCPL, stack, ma_heap)
66
 
      if (.not. status) call ga_error('ma_init failed',-1) 
67
 
c
68
 
      if(me.eq.0)then
69
 
        print *, 'using ', nproc, ' process(es)'
70
 
        call ffflush(6)
71
 
      endif
72
 
c
73
 
c   Test ghost distributions
74
 
c
75
 
      ndim = DIM
76
 
c
77
 
c   Create irregular distribution on all nodes
78
 
c
79
 
      call factor(nproc,ndim,pdims)
80
 
      dims(1) = pdims(1) * nmax
81
 
      dims(2) = pdims(2) * nmax
82
 
      maxval = 1
83
 
      do i = 1, ndim
84
 
        maxval = dims(i)*maxval
85
 
      end do
86
 
      maxval = maxval - 1
87
 
c
88
 
      dcnt = 1
89
 
      do i = 1, pdims(1)
90
 
        map(dcnt) = (i-1)*nmax + 1
91
 
        dcnt = dcnt + 1
92
 
      end do
93
 
      do i = 1, pdims(2)
94
 
        map(dcnt) = (i-1)*nmax + 1
95
 
        dcnt = dcnt + 1
96
 
      end do
97
 
c
98
 
      do i = 1, ndim
99
 
        width(i) = nwidth
100
 
        chunk(i) = 1
101
 
        if (pdims(i).gt.dims(i)) pdims(i) = dims(i)
102
 
        if (me.eq.0) then
103
 
          write(6,*) 'Value of pdims(',i,') is ',pdims(i)
104
 
        endif
105
 
        call ffflush(6)
106
 
        ld(i) = nmax
107
 
      end do
108
 
      if (me.eq.0) then
109
 
        do i = 1, dcnt - 1
110
 
          write(6,'("map(",i2,") = ",i5)') i,map(i)
111
 
          call ffflush(6)
112
 
        end do
113
 
      endif
114
 
 
115
 
      type = MT_INT
116
 
      status = nga_create_ghosts_irreg (type, ndim, dims, width,
117
 
     +        "test_array", map, pdims, g_a)
118
 
      if (status.and.me.eq.0) then
119
 
        write(6,*) '*'
120
 
        write(6,*) '* Global array creation was successful'
121
 
        write(6,*) '*'
122
 
      elseif (.not.status) then
123
 
        write(6,*) 'Global array creation failure on ',me
124
 
      endif
125
 
c
126
 
c   Find processors that have data
127
 
c
128
 
      call ga_sync
129
 
      do i = 0, nproc-1
130
 
        call nga_distribution(g_a, i, lo, hi)
131
 
        has_data(i) = .true.
132
 
        do j = 1, ndim
133
 
          if (lo(j).eq.0.and.hi(j).eq.-1) has_data(i) = .false.
134
 
        end do
135
 
        if (me.eq.i) then
136
 
          write(6,*) '*'
137
 
          write(6,*) '* Distribution on processor ',i
138
 
          write(6,*) '*'
139
 
          write(6,110) lo(1), hi(1)
140
 
          write(6,110) lo(2), hi(2)
141
 
  110     format(2i10)
142
 
        endif
143
 
        call ffflush(6)
144
 
        call ga_sync
145
 
      end do
146
 
c
147
 
c     initialize g_a
148
 
c
149
 
      call ga_sync
150
 
      call nga_distribution(g_a, me, lo, hi)
151
 
      do i = 1, hi(1) - lo(1) + 1
152
 
        do j = 1, hi(2) - lo(2) + 1
153
 
          a(i,j) = (i + lo(1) - 2)*dims(1) + (j + lo(2) - 2) + 1
154
 
        end do
155
 
      end do
156
 
      safe_put = .true.
157
 
      do i = 1, ndim
158
 
        if (hi(i).lt.lo(i)) safe_put = .false.
159
 
      end do
160
 
      if (has_data(me).and.safe_put) call nga_put(g_a, lo, hi, a, ld)
161
 
c
162
 
c   print out values of a
163
 
c
164
 
      do k = 0, nproc-1
165
 
        call ga_sync
166
 
        if (k.eq.me.and.has_data(me).and.maxval.lt.10000) then
167
 
          write(6,*)
168
 
          write(6,*) 'Initial data on processor ',k
169
 
          write(6,*)
170
 
          do i = 1, min(hi(1)-lo(1)+1,10)
171
 
            write (6,101) (a(i,j),j=1,min(hi(2)-lo(2)+1,10))
172
 
          end do
173
 
          call ffflush(6)
174
 
        endif
175
 
      end do
176
 
  101 format(10x,10i5)
177
 
      call ffflush(6)
178
 
 
179
 
c      go to 122
180
 
      t1 = 0.0d00
181
 
      do i = 1, nloop
182
 
        start = util_timer()
183
 
        status = nga_update_ghost_dir(g_a,1,1,.true.)
184
 
        status = nga_update_ghost_dir(g_a,1,-1,.true.)
185
 
        status = nga_update_ghost_dir(g_a,2,1,.true.)
186
 
        status = nga_update_ghost_dir(g_a,2,-1,.true.)
187
 
        finish = util_timer()
188
 
        t1 = t1 + finish - start
189
 
      end do
190
 
      t1 = t1/dble(nloop)
191
 
 
192
 
      if (me.eq.0) then
193
 
        write(6,*) '*'
194
 
        write(6,*) '*   Completed update successfully'
195
 
        write(6,*) '*'
196
 
        call ffflush(6)
197
 
      endif
198
 
c
199
 
c     get patch with ghost cells
200
 
c
201
 
      do i = 1, ndim
202
 
        lo2(i) = lo(i) - width(i)
203
 
        hi2(i) = hi(i) + width(i)
204
 
        ld2(i) = ld(i) + 2*width(i)
205
 
      end do
206
 
      call ga_sync
207
 
      call ffflush(6)
208
 
      do i = 0, nproc-1
209
 
        if (i.eq.me) then
210
 
          write(6,*) '*'
211
 
          write(6,*) 'ghost patch dimensions on processor ',i
212
 
          write(6,*) '*'
213
 
          do j = 1, ndim
214
 
            write(6,*) 'lo(',j,') = ',lo2(j)
215
 
            write(6,*) 'hi(',j,') = ',hi2(j)
216
 
            write(6,*) 'ld(',j,') = ',ld2(j)
217
 
          end do
218
 
          write(6,*) '*'
219
 
        endif
220
 
        call ga_sync
221
 
        call ffflush(6)
222
 
      end do
223
 
      safe_get = .true.
224
 
 
225
 
      t2 = 0.0d00
226
 
      t3 = 0.0d00
227
 
      do i = 1, nloop
228
 
        start = util_timer()
229
 
        call ga_sync
230
 
        start1 = util_timer()
231
 
        if (has_data(me).and.safe_get)
232
 
     +    call nga_periodic_get(g_a, lo2, hi2, b, ld2)
233
 
        finish1 = util_timer()
234
 
        call ga_sync
235
 
        finish = util_timer()
236
 
        t2 = t2 + finish1 - start1
237
 
        t3 = t3 + finish - start
238
 
      end do
239
 
      t2 = t2/dble(nloop)
240
 
      t3 = t3/dble(nloop)
241
 
 
242
 
      if (me.eq.0.and.maxval.lt.10000) then
243
 
        write(6,*) '*'
244
 
        write(6,*) '*   Write out contents of local patch using'
245
 
        write(6,*) '*   nga_periodic_get'
246
 
        write(6,*) '*'
247
 
        call ffflush(6)
248
 
      endif
249
 
      do k = 0, nproc-1
250
 
        call ga_sync
251
 
        if (me.eq.k.and.has_data(me).and.maxval.lt.10000) then
252
 
          write(6,*) '*'
253
 
          write(6,*) '*    Data on processor ',k
254
 
          write(6,*) '*'
255
 
          do i = 1, min(hi2(1)-lo2(1)+1,12)
256
 
            write (6,102) (b(i,j),j=1,min(hi2(2)-lo2(2)+1,12))
257
 
          end do
258
 
          call ffflush(6)
259
 
        endif
260
 
      end do
261
 
  102 format(14i5)
262
 
      if (me.eq.0) then
263
 
        write(6,*) '*'
264
 
        write(6,*) '*   Performing nga_access_ghosts'
265
 
        write(6,*) '*'
266
 
        call ffflush(6)
267
 
      endif
268
 
      if (has_data(me)) call nga_access_ghosts(g_a, dims3,
269
 
     +    index3, ld3)
270
 
      call ga_sync
271
 
      if (maxval.lt.10000)
272
 
     +      call aprint(int_mb(index3),dims3(1),dims3(2),ld3,has_data)
273
 
      call atest(int_mb(index3),dims3(1),dims3(2),ld3,b,
274
 
     +           nmax+2*nwidth,has_data)
275
 
      call ga_sync
276
 
      tmp = t1
277
 
      call ga_dgop(1,tmp,1,'max')
278
 
      if (me.eq.0) then
279
 
        write(6,*) 'Maximum time for nga_update_ghosts ',tmp
280
 
      endif
281
 
      tmp = t1
282
 
      call ga_dgop(2,tmp,1,'min')
283
 
      if (me.eq.0) then
284
 
        write(6,*) 'Minimum time for nga_update_ghosts ',tmp
285
 
      endif
286
 
      tmp = t1
287
 
      call ga_dgop(3,tmp,1,'+')
288
 
      if (me.eq.0) then
289
 
        write(6,*) 'Average time for nga_update_ghosts ',tmp/dble(nproc)
290
 
      endif
291
 
      tmp = t2
292
 
      call ga_dgop(4,tmp,1,'max')
293
 
      if (me.eq.0) then
294
 
        write(6,*) 'Maximum time for nga_periodic_get ',tmp
295
 
      endif
296
 
      tmp = t2
297
 
      call ga_dgop(5,tmp,1,'min')
298
 
      if (me.eq.0) then
299
 
        write(6,*) 'Minimum time for nga_periodic_get ',tmp
300
 
      endif
301
 
      tmp = t2
302
 
      call ga_dgop(6,tmp,1,'+')
303
 
      if (me.eq.0) then
304
 
        write(6,*) 'Average time for nga_periodic_get ',tmp/dble(nproc)
305
 
      endif
306
 
      tmp = t3
307
 
      call ga_dgop(4,tmp,1,'max')
308
 
      if (me.eq.0) then
309
 
        write(6,*) 'Maximum time for (sync)nga_periodic_get ',tmp
310
 
      endif
311
 
      tmp = t3
312
 
      call ga_dgop(5,tmp,1,'min')
313
 
      if (me.eq.0) then
314
 
        write(6,*) 'Minimum time for (sync)nga_periodic_get ',tmp
315
 
      endif
316
 
      tmp = t3
317
 
      call ga_dgop(6,tmp,1,'+')
318
 
      if (me.eq.0) then
319
 
        write(6,*) 'Average time for (sync)nga_periodic_get ',
320
 
     +              tmp/dble(nproc)
321
 
      endif
322
 
  127 continue
323
 
c
324
 
c*** Print success
325
 
c
326
 
      if (me.eq.0) then
327
 
        write(6,*)
328
 
        write(6,*) 'All tests successful'
329
 
        write(6,*)
330
 
      endif
331
 
c
332
 
c***  Tidy up the GA package
333
 
c
334
 
      call ga_terminate()
335
 
c
336
 
c***  Tidy up after message-passing library
337
 
c
338
 
      call MP_FINALIZE()
339
 
 
340
 
c
341
 
      stop
342
 
      end
343
 
c
344
 
      subroutine aprint(a,nrow,ncol,ld,has_data)
345
 
#include "global.fh"
346
 
      integer ld
347
 
      integer a(ld,*)
348
 
      integer i, j, k, nproc
349
 
      logical has_data(0:1999)
350
 
       
351
 
      nproc = ga_nnodes()
352
 
      do k = 1, nproc
353
 
        call ga_sync
354
 
        if (k-1.eq.ga_nodeid().and.has_data(k-1)) then
355
 
          write(6,*) '*'
356
 
          write(6,*) '*   Data on processor ',k-1
357
 
          write(6,*) '*'
358
 
          do i = 1, min(nrow,12)
359
 
            write (6,102) (a(i,j), j = 1, min(ncol,12))
360
 
  102       format(14i5)
361
 
          end do
362
 
        endif
363
 
        call ffflush(6)
364
 
      enddo
365
 
c
366
 
      return
367
 
      end
368
 
c
369
 
      subroutine atest(a,nrow,ncol,ld,b,ld2,has_data)
370
 
#include "global.fh"
371
 
      integer ld
372
 
      integer a(ld,*), b(ld2,*)
373
 
      integer i, j, k, nproc
374
 
      logical has_data(0:1999), check_data
375
 
 
376
 
      nproc = ga_nnodes()
377
 
      check_data = .true.
378
 
      do k = 1, nproc
379
 
        call ga_sync
380
 
        if (k-1.eq.ga_nodeid().and.has_data(k-1)) then
381
 
          do i = 1, nrow
382
 
            do j = 1, ncol
383
 
              if (a(i,j).ne.b(i,j)) check_data = .false.
384
 
            end do
385
 
          end do
386
 
          if (check_data) then
387
 
            write(6,*) '*'
388
 
            write(6,*) '*   Data from nga_access_ghosts and'
389
 
            write(6,*) '*   nga_periodic_get is the same on'
390
 
            write(6,*) '*   processor ',k-1
391
 
            write(6,*) '*'
392
 
          else
393
 
            write(6,*) '*'
394
 
            write(6,*) '*   Data from nga_access_ghosts and'
395
 
            write(6,*) '*   nga_periodic_get is NOT the same on'
396
 
            write(6,*) '*   processor ',k-1
397
 
            write(6,*) '*'
398
 
          endif
399
 
        endif
400
 
        call ffflush(6)
401
 
      enddo
402
 
c
403
 
      return
404
 
      end
405
 
c
406
 
      subroutine factor(p,ndim,dims)
407
 
      implicit none
408
 
      integer i,j,p,ndim,dims(7),imin,mdim
409
 
      integer ip,ifac,pmax,prime(1000)
410
 
      integer fac(1000)
411
 
c
412
 
      i = 1
413
 
      ip = p
414
 
      do i = 1, ndim
415
 
        dims(i) = 1
416
 
      end do
417
 
c
418
 
c    factor p completely
419
 
c    first, find all prime numbers less than or equal to p
420
 
c
421
 
      pmax = 0
422
 
      do i = 2, p
423
 
        do j = 1, pmax
424
 
          if (mod(i,prime(j)).eq.0) go to 100
425
 
        end do
426
 
        pmax = pmax + 1
427
 
        prime(pmax) = i
428
 
  100   continue
429
 
      end do
430
 
c
431
 
c    find all prime factors of p
432
 
c
433
 
      ifac = 0
434
 
      do i = 1, pmax
435
 
  200   if (mod(ip,prime(i)).eq.0) then
436
 
          ifac = ifac + 1
437
 
          fac(ifac) = prime(i)
438
 
          ip = ip/prime(i)
439
 
          go to 200
440
 
        endif
441
 
      end do
442
 
c
443
 
c    determine dimensions of processor grid
444
 
c
445
 
      do i = ifac, 1, -1
446
 
c
447
 
c    find dimension with minimum value
448
 
c
449
 
        imin = dims(1)
450
 
        mdim = 1
451
 
        do j = 2, ndim
452
 
          if (dims(j).lt.imin) then
453
 
            imin = dims(j)
454
 
            mdim = j
455
 
          endif
456
 
        end do
457
 
        dims(mdim) = dims(mdim)*fac(i)
458
 
      end do
459
 
c
460
 
      return
461
 
      end