← 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-1/global/testing/types-test.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/types-test.F
1
 
#if HAVE_CONFIG_H 
2
 
#   include "config.fh"
3
 
#endif
4
 
c $Id: test.F,v 1.64.2.11 2007-04-06 22:37:35 d3g293 Exp $
5
 
c vector boxes lack arithmetic precision 
6
 
#if defined(FUJITSU)
7
 
# define THRESH 1d-12
8
 
# define THRESHF 1e-5
9
 
#else
10
 
# define THRESH 1d-13
11
 
# define THRESHF 2e-5
12
 
#endif
13
 
 
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
 
c#define NEW_API
18
 
c#define MIRROR
19
 
#define GA3
20
 
#define NGA_GATSCAT
21
 
c#define BLOCK_CYCLIC
22
 
c#define USE_SCALAPACK_DISTR
23
 
c#define USE_RESTRICTED
24
 
 
25
 
#ifdef USE_RESTRICTED
26
 
#  define NEW_API
27
 
#endif
28
 
 
29
 
#define MEM_INC 1000
30
 
 
31
 
#ifdef BLOCK_CYCLIC
32
 
#  define NEW_API
33
 
#  undef MIRROR
34
 
#else
35
 
#  undef USE_SCALAPAC_DISTR
36
 
#endif
37
 
 
38
 
      program main
39
 
      implicit none
40
 
#include "mafdecls.fh"
41
 
#include "global.fh"
42
 
#include "testutil.fh"
43
 
      integer heap, stack, fudge, ma_heap, me, nproc, map(4096), block
44
 
      integer g_s, ndim, dim1, i
45
 
      logical status
46
 
      parameter (heap=200*200*4, fudge=100, stack=200*200)
47
 
c     
48
 
c***  Intitialize a message passing library
49
 
c
50
 
#include "mp3.fh"
51
 
c
52
 
c***  Initialize GA
53
 
c
54
 
c     There are 2 choices: ga_initialize or ga_initialize_ltd.
55
 
c     In the first case, there is no explicit limit on memory usage.
56
 
c     In the second, user can set limit (per processor) in bytes.
57
 
c
58
 
      call ga_initialize()
59
 
      nproc = ga_nnodes()
60
 
      me = ga_nodeid()
61
 
c     we can also use GA_set_memory_limit BEFORE first ga_create call
62
 
c
63
 
      ma_heap = heap/nproc + fudge 
64
 
      ma_heap = 2*ma_heap
65
 
#ifdef USE_RESTRICTED
66
 
      ma_heap = 2*ma_heap
67
 
#endif
68
 
      call GA_set_memory_limit(util_mdtob(ma_heap))
69
 
c
70
 
      if(ga_nodeid().eq.0)then
71
 
#ifdef MIRROR
72
 
         print *,' Performing tests on Mirrored Arrays'
73
 
#endif
74
 
         print *,' GA initialized '
75
 
         call ffflush(6)
76
 
      endif
77
 
c
78
 
c***  Initialize the MA package
79
 
c     MA must be initialized before any global array is allocated
80
 
c
81
 
      status = ma_init(MT_DCPL, stack, ma_heap)
82
 
      if (.not. status) call ga_error('ma_init failed',-1) 
83
 
c
84
 
c     Uncomment the below line to register external memory allocator
85
 
c     for dynamic arrays inside GA routines.
86
 
c      call register_ext_memory()
87
 
c
88
 
      if(me.eq.(nproc-1))then
89
 
        print *, 'using ', nproc,' process(es) ', ga_cluster_nnodes(),
90
 
     $           ' cluster nodes'
91
 
        print *,'process ', me, ' is on node ',ga_cluster_nodeid(),
92
 
     $          ' with ',  ga_cluster_nprocs(-1), ' processes' 
93
 
        call ffflush(6)
94
 
      endif
95
 
c
96
 
c   create array to force staggering of memory and uneven distribution
97
 
c   of pointers
98
 
c
99
 
      dim1 = MEM_INC
100
 
      map(1) = 1
101
 
      do i = 2, nproc
102
 
        map(i) = MEM_INC*(i-1)+1
103
 
        dim1 = dim1 + MEM_INC*i
104
 
      end do
105
 
      g_s = ga_create_handle()
106
 
      ndim = 1
107
 
      call ga_set_data(g_s,ndim,dim1,MT_INT)
108
 
      call ga_set_array_name(g_s,'s')
109
 
      call ga_set_irreg_distr(g_s,map,nproc)
110
 
 
111
 
c
112
 
c***  Check support for single precision complex arrays
113
 
c
114
 
      if (me.eq.0) then
115
 
         write(6,*)
116
 
         write(6,*) ' CHECKING SINGLE COMPLEX  '
117
 
         write(6,*)
118
 
         call ffflush(6)
119
 
      endif
120
 
 
121
 
      call check_complex_float()
122
 
c
123
 
c***  Check support for double precision complex arrays
124
 
c
125
 
      if (me.eq.0) then
126
 
         write(6,*)
127
 
         write(6,*) ' CHECKING DOUBLE COMPLEX  '
128
 
         write(6,*)
129
 
         call ffflush(6)
130
 
      endif
131
 
 
132
 
      call check_complex()
133
 
      if(me.eq.0) call ga_print_stats()
134
 
      if(me.eq.0) print *,' ' 
135
 
      if(me.eq.0) print *,'All tests successful ' 
136
 
      status = ga_destroy(g_s)
137
 
c
138
 
c***  Tidy up the GA package
139
 
c
140
 
      call ga_terminate()
141
 
c
142
 
c***  Tidy up after message-passing library
143
 
c
144
 
      call MP_FINALIZE()
145
 
c
146
 
      end
147
 
 
148
 
 
149
 
 
150
 
 
151
 
      subroutine check_complex_float()
152
 
      implicit none
153
 
#include "mafdecls.fh"
154
 
#include "global.fh"
155
 
#include "testutil.fh"
156
 
c
157
 
      integer n,m
158
 
      parameter (n = 60)
159
 
      parameter (m = 2*n)
160
 
      complex a(n,n), b(n,n), v(m),w(m)
161
 
#ifdef MIRROR
162
 
      integer ndim, dims(2), chunk(2), p_mirror
163
 
#else
164
 
#  ifdef NEW_API
165
 
      integer ndim, dims(2), chunk(2), p_mirror
166
 
#  endif
167
 
#endif
168
 
      integer iv(m), jv(m)
169
 
      logical status
170
 
      integer g_a, g_b
171
 
      integer iran, i,j, loop,nloop,maxloop, ilo, ihi, jlo, jhi, itmp
172
 
      integer nproc, me, int, ij, inc, ii, jj, nnodes
173
 
      parameter (maxloop = 100)
174
 
      integer maxproc
175
 
      parameter (maxproc = 4096)
176
 
      double precision crap, real
177
 
      double precision nwords
178
 
      complex   x, sum1, sum2, factor
179
 
      integer lprocs, inode, iproc, lproc
180
 
      integer scpl_type, istatus
181
 
#ifdef USE_RESTRICTED
182
 
      integer num_rstrctd
183
 
      integer rstrctd_list(maxproc/2)
184
 
#endif
185
 
      intrinsic int
186
 
      iran(i) = int(drand(0)*real(i)) + 1
187
 
c
188
 
      nproc = ga_nnodes()
189
 
      me    = ga_nodeid()
190
 
      inode = ga_cluster_nodeid()
191
 
      lprocs = ga_cluster_nprocs(inode)
192
 
      nnodes = ga_cluster_nnodes()
193
 
      iproc = mod(me,lprocs)
194
 
      nloop = Min(maxloop,n)
195
 
#ifdef USE_RESTRICTED
196
 
      num_rstrctd = nproc/2
197
 
      if (num_rstrctd.eq.0) num_rstrctd = 1
198
 
      do i = 1, num_rstrctd
199
 
        rstrctd_list(i) = (num_rstrctd/2) + i-1
200
 
      end do
201
 
#endif
202
 
c
203
 
c     a() is a local copy of what the global array should start as
204
 
c
205
 
      do j = 1, n
206
 
         do i = 1, n
207
 
#ifndef MIRROR
208
 
            a(i,j) = cmplx(real(i-1), real((j-1)*n))
209
 
#else
210
 
            a(i,j) = cmplx(real(inode),0.0d00)
211
 
     +             + cmplx(real(i-1), real((j-1)*n))
212
 
#endif
213
 
            b(i,j) = cmplx(-1d0,1d0)
214
 
         enddo
215
 
      enddo
216
 
c
217
 
c     Create type
218
 
c
219
 
      scpl_type = nga_register_type(8)
220
 
c
221
 
c     Create a global array
222
 
c
223
 
c     print *,ga_nodeid(), ' creating array'
224
 
      call ffflush(6)
225
 
c     call setdbg(1)
226
 
#ifdef NEW_API
227
 
      ndim = 2
228
 
      dims(1) = n
229
 
      dims(2) = n
230
 
      g_a = ga_create_handle()
231
 
      call ga_set_data(g_a,ndim,dims,scpl_type)
232
 
      call ga_set_array_name(g_a,'a')
233
 
#ifdef USE_RESTRICTED
234
 
      call ga_set_restricted(g_a, rstrctd_list, num_rstrctd)
235
 
#endif
236
 
#  ifdef MIRROR
237
 
      p_mirror = ga_pgroup_get_mirror()
238
 
      call ga_set_pgroup(g_a,p_mirror)
239
 
#  endif
240
 
      status = ga_allocate(g_a)
241
 
#else
242
 
#  ifndef MIRROR
243
 
      status = ga_create(scpl_type, n, n, 'a', 0, 0, g_a)
244
 
#  else
245
 
      ndim = 2
246
 
      dims(1) = n
247
 
      dims(2) = n
248
 
      chunk(1) = 0
249
 
      chunk(2) = 0
250
 
      p_mirror = ga_pgroup_get_mirror()
251
 
      status = nga_create_config(scpl_type, ndim, dims, 'a', chunk,
252
 
     +                           p_mirror, g_a)
253
 
#  endif
254
 
#endif
255
 
      if (.not. status) then
256
 
         write(6,*) ' ga_create failed'
257
 
         call ga_error('... exiting ',0)
258
 
      endif
259
 
#ifdef NEW_API
260
 
      g_b = ga_create_handle()
261
 
      call ga_set_data(g_b,ndim,dims,scpl_type)
262
 
      call ga_set_array_name(g_b,'b')
263
 
#  ifdef MIRROR
264
 
      call ga_set_pgroup(g_b,p_mirror)
265
 
#  endif
266
 
      if (.not.ga_allocate(g_b)) then
267
 
#else
268
 
#  ifndef MIRROR
269
 
      if (.not. ga_create(scpl_type, n, n, 'b', 0, 0, g_b)) then
270
 
#  else
271
 
      if (.not. nga_create_config(scpl_type, ndim, dims, 'b', chunk,
272
 
     _                            p_mirror, g_b)) then
273
 
#  endif
274
 
#endif
275
 
         call ga_error('ga_create failed for second array ',0)
276
 
      endif
277
 
 
278
 
#ifndef MIRROR
279
 
      call ga_distribution(g_a,me,ilo, ihi, jlo, jhi)
280
 
#else
281
 
      lproc = me - ga_cluster_procid(inode,0)
282
 
      call ga_distribution(g_a, lproc, ilo, ihi, jlo, jhi)
283
 
#endif
284
 
      call ga_sync()
285
 
c
286
 
c     Zero the array
287
 
c
288
 
      if (me .eq. 0) then
289
 
         write(6,21)
290
 
 21      format(/'> Checking zero ... ')
291
 
         call ffflush(6)
292
 
      endif
293
 
      call ga_zero(g_a)
294
 
c
295
 
c     Check that it is indeed zero
296
 
c
297
 
      call ga_get(g_a, 1, n, 1, n, b, n)
298
 
      call ga_sync()
299
 
      do i = 1, n
300
 
         do j = 1, n
301
 
            if(b(i,j).ne.(0d0,0d0)) then
302
 
               write(6,*) me,' zero ', i, j, b(i,j)
303
 
               call ffflush(6)
304
 
c              call ga_error('... exiting ',0)
305
 
            endif
306
 
         enddo
307
 
      enddo
308
 
      if (me.eq.0) then
309
 
         write(6,*)
310
 
         write(6,*) ' ga_zero is OK'
311
 
         write(6,*)
312
 
      endif
313
 
      call ga_sync()
314
 
c
315
 
c     Each node fills in disjoint sections of the array
316
 
c
317
 
      if (me .eq. 0) then
318
 
         write(6,2)
319
 
 2       format(/'> Checking disjoint put ... ')
320
 
         call ffflush(6)
321
 
      endif
322
 
      call ga_sync()
323
 
c
324
 
      inc = (n-1)/4 + 1
325
 
      ij = 0
326
 
      do j = 1, n, inc
327
 
         do i = 1, n, inc
328
 
#ifndef MIRROR
329
 
            if (mod(ij,nproc) .eq. me) then
330
 
#else
331
 
            if (mod(ij,lprocs) .eq. iproc) then
332
 
#endif
333
 
               ilo = i
334
 
               ihi = min(i+inc, n)
335
 
               jlo = j
336
 
               jhi = min(j+inc, n)
337
 
               call ga_put(g_a, ilo, ihi, jlo, jhi, a(ilo, jlo), n)
338
 
            endif
339
 
            ij = ij + 1
340
 
         enddo
341
 
      enddo
342
 
      call ga_sync()
343
 
c
344
 
c     All nodes check all of a
345
 
c
346
 
      call ga_get(g_a, 1, n, 1, n, b, n)
347
 
c
348
 
      do i = 1, n
349
 
         do j = 1, n
350
 
            if (b(i,j) .ne. a(i,j)) then
351
 
               write(6,*) ' put ', me, i, j, a(i,j),b(i,j)
352
 
               call ffflush(6)
353
 
               call ga_error('... exiting ',0)
354
 
            endif
355
 
         enddo
356
 
      enddo
357
 
      if (me.eq.0) then
358
 
         write(6,*)
359
 
         write(6,*) ' ga_put is OK'
360
 
         write(6,*)
361
 
      endif
362
 
      call ga_sync()
363
 
c
364
 
c     Now check nloop random gets from each node
365
 
c
366
 
      if (me .eq. 0) then
367
 
         write(6,5) nloop
368
 
 5       format(/'> Checking random get (',i5,' calls)...')
369
 
         call ffflush(6)
370
 
      endif
371
 
      call ga_sync()
372
 
c
373
 
      nwords = 0
374
 
c
375
 
      crap = drand(ga_nodeid()*51 +1) !Different seed for each proc
376
 
      do loop = 1, nloop
377
 
         ilo = iran(loop)
378
 
         ihi = iran(loop)
379
 
         if (ihi.lt. ilo) then
380
 
            itmp = ihi
381
 
            ihi = ilo
382
 
            ilo = itmp
383
 
         endif
384
 
         jlo = iran(loop)
385
 
         jhi = iran(loop)
386
 
         if (jhi.lt. jlo) then
387
 
            itmp = jhi
388
 
            jhi = jlo
389
 
            jlo = itmp
390
 
         endif
391
 
c
392
 
         nwords = nwords + (ihi-ilo+1)*(jhi-jlo+1)
393
 
c
394
 
         call ga_get(g_a, ilo, ihi, jlo, jhi, b(ilo, jlo), n)
395
 
         if (me .eq. 0 .and. mod(loop-1, max(1,nloop/20)).eq.0) then
396
 
            write(6,1) loop, me, ilo, ihi, jlo, jhi, nwords
397
 
 1          format(' call ',i5, ' node ',i2,' checking get ',4i4,
398
 
     $           ' total ',d9.2)
399
 
            call ffflush(6)
400
 
         endif
401
 
         do j = jlo, jhi
402
 
            do i = ilo, ihi
403
 
               if (b(i,j) .ne. a(i,j)) then
404
 
                  write(6,*)'error:', i, j, b(i,j), a(i,j)
405
 
                  call ga_error('... exiting ',0)
406
 
               endif
407
 
            enddo
408
 
         enddo
409
 
c
410
 
      enddo
411
 
      if (me.eq.0) then
412
 
         write(6,*)
413
 
         write(6,*) ' ga_get is OK'
414
 
         write(6,*)
415
 
         call ffflush(6)
416
 
      endif
417
 
      call ga_sync()
418
 
c
419
 
c     Check the ga_copy function
420
 
c
421
 
      if (me .eq. 0) then
422
 
         write(6,*)
423
 
         write(6,*)'> Checking copy'
424
 
         write(6,*)
425
 
         call ffflush(6)
426
 
      endif
427
 
      call ga_sync()
428
 
#ifndef MIRROR
429
 
      if(me.eq.0) call ga_put(g_a, 1, n, 1, n, a, n)
430
 
#else
431
 
      if(iproc.eq.0) call ga_put(g_a, 1, n, 1, n, a, n)
432
 
#endif
433
 
      call ga_copy(g_a, g_b)
434
 
      call ga_get(g_b, 1, n, 1, n, b, n)
435
 
      do j = 1, n
436
 
         do i = 1, n
437
 
            if (b(i,j) .ne. a(i,j)) then
438
 
               write(6,*) ' copy ', me, i, j, a(i,j), b(i,j)
439
 
               call ga_error('... exiting ',0)
440
 
            endif
441
 
         enddo
442
 
      enddo
443
 
      if (me.eq.0) then
444
 
         write(6,*)
445
 
         write(6,*) ' copy is OK '
446
 
         write(6,*)
447
 
      endif
448
 
c
449
 
c     Check scatter&gather
450
 
c
451
 
      call ga_sync()
452
 
      if (me .eq. 0) then
453
 
         write(6,*) '> Checking scatter/gather (might be slow)... '
454
 
         call ffflush(6)
455
 
         if(me.eq.0) call ga_put(g_a, 1, n, 1, n, a, n)
456
 
      endif
457
 
      call ga_sync()
458
 
c
459
 
      crap = drand(ga_nodeid()*51 +1) !Different seed for each proc
460
 
      do j = 1, 10
461
 
       call ga_sync()
462
 
#ifndef MIRROR
463
 
       itmp = iran(nproc)-1
464
 
       if(me.eq.itmp) then
465
 
#else
466
 
       itmp = iran(lprocs)-1
467
 
       if(iproc.eq.itmp) then
468
 
#endif
469
 
         do loop = 1,m
470
 
           ilo = iran(n)
471
 
           jlo = iran(n)
472
 
           iv(loop) = ilo
473
 
           jv(loop) = jlo
474
 
         enddo
475
 
         call ga_gather(g_a, v, iv, jv, m)
476
 
         do loop = 1,m
477
 
           ilo= iv(loop)
478
 
           jlo= jv(loop)
479
 
           call ga_get(g_a,ilo,ilo,jlo,jlo,v(loop),1)
480
 
           if(v(loop)  .ne. a(ilo,jlo))then
481
 
             write(6,*)me,' gather ', ilo,',',jlo,',', a(ilo,jlo)
482
 
     &             ,' ',v(loop)
483
 
             call ffflush(6)
484
 
             call ga_error('... exiting ',0)
485
 
           endif
486
 
         enddo
487
 
       endif
488
 
      enddo
489
 
c
490
 
      if (me.eq.0) then
491
 
         write(6,*)
492
 
         write(6,*) ' gather is  OK'
493
 
         write(6,*)
494
 
         call ffflush(6)
495
 
      endif
496
 
c
497
 
      do j = 1,10
498
 
       call ga_sync()
499
 
#ifndef MIRROR
500
 
       if(me.eq.iran(ga_nnodes())-1) then
501
 
#else
502
 
       if(me.eq.iran(lprocs)-1) then
503
 
#endif
504
 
         do loop = 1,m
505
 
           ilo = iran(n)
506
 
           jlo = iran(n)
507
 
           iv(loop) = ilo
508
 
           jv(loop) = jlo
509
 
           v(loop) = (1d0,-1d0) *(ilo+jlo)
510
 
         enddo
511
 
         call ga_scatter(g_a, v, iv, jv, m)
512
 
         do loop = 1,m
513
 
           ilo= iv(loop)
514
 
           jlo= jv(loop)
515
 
           call ga_get(g_a,ilo,ilo,jlo,jlo,w(loop),1)
516
 
           if(w(loop)  .ne. (1d0,-1d0) *(ilo+jlo) )then
517
 
             write(6,*)me,' scatter ', ilo,',',jlo,',',w(loop)
518
 
     &             ,' ', (1d0,-1d0) *(ilo+jlo)
519
 
             call ffflush(6)
520
 
           endif
521
 
         enddo
522
 
       endif
523
 
       call ga_sync()
524
 
      enddo
525
 
c
526
 
      if (me.eq.0) then
527
 
         write(6,*)
528
 
         write(6,*) ' scatter is  OK'
529
 
         write(6,*)
530
 
      endif
531
 
c
532
 
c     Delete the global arrays
533
 
c
534
 
 
535
 
      status = ga_destroy(g_b)
536
 
      status = ga_destroy(g_a)
537
 
c
538
 
      istatus = nga_deregister_type(scpl_type)
539
 
c
540
 
      end
541
 
c-----------------------------------------------------------------
542
 
 
543
 
      subroutine check_complex()
544
 
      implicit none
545
 
#include "mafdecls.fh"
546
 
#include "global.fh"
547
 
#include "testutil.fh"
548
 
c
549
 
      integer n,m
550
 
      parameter (n = 60)
551
 
      parameter (m = 2*n)
552
 
      double complex a(n,n), b(n,n), v(m),w(m)
553
 
#ifdef MIRROR
554
 
      integer ndim, dims(2), chunk(2), p_mirror
555
 
#else
556
 
#  ifdef NEW_API
557
 
      integer ndim, dims(2), chunk(2), p_mirror
558
 
#  endif
559
 
#endif
560
 
      integer iv(m), jv(m)
561
 
      logical status
562
 
      integer g_a, g_b
563
 
      integer iran, i,j, loop,nloop,maxloop, ilo, ihi, jlo, jhi, itmp
564
 
      integer nproc, me, int, ij, inc, ii, jj, nnodes
565
 
      parameter (maxloop = 100)
566
 
      integer maxproc
567
 
      parameter (maxproc = 4096)
568
 
      double precision crap, real
569
 
      double precision nwords
570
 
      double complex   x, sum1, sum2, factor
571
 
      integer lprocs, inode, iproc, lproc
572
 
      integer dcpl_type, istatus
573
 
#ifdef USE_RESTRICTED
574
 
      integer num_rstrctd
575
 
      integer rstrctd_list(maxproc/2)
576
 
#endif
577
 
#ifdef BLOCK_CYCLIC
578
 
      integer block_size(2), proc_grid(2)
579
 
#endif
580
 
      intrinsic int
581
 
      iran(i) = int(drand(0)*real(i)) + 1
582
 
c
583
 
      nproc = ga_nnodes()
584
 
      me    = ga_nodeid()
585
 
      inode = ga_cluster_nodeid()
586
 
      lprocs = ga_cluster_nprocs(inode)
587
 
      nnodes = ga_cluster_nnodes()
588
 
      iproc = mod(me,lprocs)
589
 
      nloop = Min(maxloop,n)
590
 
#ifdef USE_RESTRICTED
591
 
      num_rstrctd = nproc/2
592
 
      if (num_rstrctd.eq.0) num_rstrctd = 1
593
 
      do i = 1, num_rstrctd
594
 
        rstrctd_list(i) = (num_rstrctd/2) + i-1
595
 
      end do
596
 
#endif
597
 
#ifdef BLOCK_CYCLIC
598
 
      block_size(1) = 32
599
 
      block_size(2) = 32
600
 
#ifdef USE_SCALAPACK_DISTR
601
 
      if (mod(nproc,2).ne.0)
602
 
     +  call ga_error("Available procs must be divisible by 2",0)
603
 
      proc_grid(1) = 2
604
 
      proc_grid(2) = nproc/2
605
 
#endif
606
 
#endif
607
 
c
608
 
c     a() is a local copy of what the global array should start as
609
 
c
610
 
      do j = 1, n
611
 
         do i = 1, n
612
 
#ifndef MIRROR
613
 
            a(i,j) = cmplx(dble(i-1), dble((j-1)*n))
614
 
#else
615
 
            a(i,j) = cmplx(dble(inode),0.0d00)
616
 
     +             + cmplx(dble(i-1), dble((j-1)*n))
617
 
#endif
618
 
            b(i,j) = cmplx(-1d0,1d0)
619
 
         enddo
620
 
      enddo
621
 
c
622
 
c     Create  type
623
 
c
624
 
      dcpl_type = nga_register_type(16)
625
 
c
626
 
c     Create a global array
627
 
c
628
 
c     print *,ga_nodeid(), ' creating array'
629
 
      call ffflush(6)
630
 
c     call setdbg(1)
631
 
#ifdef NEW_API
632
 
      ndim = 2
633
 
      dims(1) = n
634
 
      dims(2) = n
635
 
      g_a = ga_create_handle()
636
 
      call ga_set_data(g_a,ndim,dims,dcpl_type)
637
 
      call ga_set_array_name(g_a,'a')
638
 
#ifdef USE_RESTRICTED
639
 
      call ga_set_restricted(g_a, rstrctd_list, num_rstrctd)
640
 
#endif
641
 
#ifdef BLOCK_CYCLIC
642
 
#ifdef USE_SCALAPACK_DISTR
643
 
      call ga_set_block_cyclic_proc_grid(g_a,block_size,proc_grid)
644
 
#else
645
 
      call ga_set_block_cyclic(g_a,block_size)
646
 
#endif
647
 
#endif
648
 
#  ifdef MIRROR
649
 
      p_mirror = ga_pgroup_get_mirror()
650
 
      call ga_set_pgroup(g_a,p_mirror)
651
 
#  endif
652
 
      status = ga_allocate(g_a)
653
 
#else
654
 
#  ifndef MIRROR
655
 
      status = ga_create(dcpl_type, n, n, 'a', 0, 0, g_a)
656
 
#  else
657
 
      ndim = 2
658
 
      dims(1) = n
659
 
      dims(2) = n
660
 
      chunk(1) = 0
661
 
      chunk(2) = 0
662
 
      p_mirror = ga_pgroup_get_mirror()
663
 
      status = nga_create_config(dcpl_type, ndim, dims, 'a', chunk,
664
 
     +                           p_mirror, g_a)
665
 
#  endif
666
 
#endif
667
 
      if (.not. status) then
668
 
         write(6,*) ' ga_create failed'
669
 
         call ga_error('... exiting ',0)
670
 
      endif
671
 
#ifdef NEW_API
672
 
      g_b = ga_create_handle()
673
 
      call ga_set_data(g_b,ndim,dims,dcpl_type)
674
 
      call ga_set_array_name(g_b,'b')
675
 
#ifdef BLOCK_CYCLIC
676
 
#ifdef USE_SCALAPACK_DISTR
677
 
      call ga_set_block_cyclic_proc_grid(g_b,block_size,proc_grid)
678
 
#else
679
 
      call ga_set_block_cyclic(g_b,block_size)
680
 
#endif
681
 
#endif
682
 
#  ifdef MIRROR
683
 
      call ga_set_pgroup(g_b,p_mirror)
684
 
#  endif
685
 
      if (.not.ga_allocate(g_b)) then
686
 
#else
687
 
#  ifndef MIRROR
688
 
      if (.not. ga_create(dcpl_type, n, n, 'b', 0, 0, g_b)) then
689
 
#  else
690
 
      if (.not. nga_create_config(dcpl_type, ndim, dims, 'b', chunk,
691
 
     _                            p_mirror, g_b)) then
692
 
#  endif
693
 
#endif
694
 
         call ga_error('ga_create failed for second array ',0)
695
 
      endif
696
 
 
697
 
#ifndef MIRROR
698
 
      call ga_distribution(g_a,me,ilo, ihi, jlo, jhi)
699
 
#else
700
 
      lproc = me - ga_cluster_procid(inode,0)
701
 
      call ga_distribution(g_a, lproc, ilo, ihi, jlo, jhi)
702
 
#endif
703
 
      call ga_sync()
704
 
c
705
 
c     Zero the array
706
 
c
707
 
      if (me .eq. 0) then
708
 
         write(6,21)
709
 
 21      format('> Checking zero ... ')
710
 
         call ffflush(6)
711
 
      endif
712
 
      call ga_zero(g_a)
713
 
c
714
 
c     Check that it is indeed zero
715
 
c
716
 
      call ga_get(g_a, 1, n, 1, n, b, n)
717
 
      call ga_sync()
718
 
      do i = 1, n
719
 
         do j = 1, n
720
 
            if(b(i,j).ne.(0d0,0d0)) then
721
 
               write(6,*) me,' zero ', i, j, b(i,j)
722
 
               call ffflush(6)
723
 
c              call ga_error('... exiting ',0)
724
 
            endif
725
 
         enddo
726
 
      enddo
727
 
      if (me.eq.0) then
728
 
         write(6,*)
729
 
         write(6,*) ' ga_zero is OK'
730
 
         write(6,*)
731
 
      endif
732
 
      call ga_sync()
733
 
c
734
 
c     Each node fills in disjoint sections of the array
735
 
c
736
 
      if (me .eq. 0) then
737
 
         write(6,2)
738
 
 2       format('> Checking disjoint put ... ')
739
 
         call ffflush(6)
740
 
      endif
741
 
      call ga_sync()
742
 
c
743
 
      inc = (n-1)/20 + 1
744
 
      ij = 0
745
 
      do j = 1, n, inc
746
 
         do i = 1, n, inc
747
 
#ifndef MIRROR
748
 
            if (mod(ij,nproc) .eq. me) then
749
 
#else
750
 
            if (mod(ij,lprocs) .eq. iproc) then
751
 
#endif
752
 
               ilo = i
753
 
               ihi = min(i+inc, n)
754
 
               jlo = j
755
 
               jhi = min(j+inc, n)
756
 
               call ga_put(g_a, ilo, ihi, jlo, jhi, a(ilo, jlo), n)
757
 
            endif
758
 
            ij = ij + 1
759
 
         enddo
760
 
      enddo
761
 
      call ga_sync()
762
 
c
763
 
c     All nodes check all of a
764
 
c
765
 
      call util_qfill(n*n, (0d0,0d0), b, 1)
766
 
      call ga_get(g_a, 1, n, 1, n, b, n)
767
 
c
768
 
      do i = 1, n
769
 
         do j = 1, n
770
 
            if (b(i,j) .ne. a(i,j)) then
771
 
               write(6,*) ' put ', me, i, j, a(i,j),b(i,j)
772
 
               call ffflush(6)
773
 
               call ga_error('... exiting ',0)
774
 
            endif
775
 
         enddo
776
 
      enddo
777
 
      if (me.eq.0) then
778
 
         write(6,*)
779
 
         write(6,*) ' ga_put is OK'
780
 
         write(6,*)
781
 
      endif
782
 
      call ga_sync()
783
 
c
784
 
c     Now check nloop random gets from each node
785
 
c
786
 
      if (me .eq. 0) then
787
 
         write(6,5) nloop
788
 
 5       format('> Checking random get (',i5,' calls)...')
789
 
         call ffflush(6)
790
 
      endif
791
 
      call ga_sync()
792
 
c
793
 
      nwords = 0
794
 
c
795
 
      crap = drand(ga_nodeid()*51 +1) !Different seed for each proc
796
 
      do loop = 1, nloop
797
 
         ilo = iran(loop)
798
 
         ihi = iran(loop)
799
 
         if (ihi.lt. ilo) then
800
 
            itmp = ihi
801
 
            ihi = ilo
802
 
            ilo = itmp
803
 
         endif
804
 
         jlo = iran(loop)
805
 
         jhi = iran(loop)
806
 
         if (jhi.lt. jlo) then
807
 
            itmp = jhi
808
 
            jhi = jlo
809
 
            jlo = itmp
810
 
         endif
811
 
c
812
 
         nwords = nwords + (ihi-ilo+1)*(jhi-jlo+1)
813
 
c
814
 
         call util_qfill(n*n, (0.0d0,0d0), b, 1)
815
 
         call ga_get(g_a, ilo, ihi, jlo, jhi, b(ilo, jlo), n)
816
 
         if (me .eq. 0 .and. mod(loop-1, max(1,nloop/20)).eq.0) then
817
 
            write(6,1) loop, me, ilo, ihi, jlo, jhi, nwords
818
 
 1          format(' call ',i5, ' node ',i2,' checking get ',4i4,
819
 
     $           ' total ',d9.2)
820
 
            call ffflush(6)
821
 
         endif
822
 
         do j = jlo, jhi
823
 
            do i = ilo, ihi
824
 
               if (b(i,j) .ne. a(i,j)) then
825
 
                  write(6,*)'error:', i, j, b(i,j), a(i,j)
826
 
                  call ga_error('... exiting ',0)
827
 
               endif
828
 
            enddo
829
 
         enddo
830
 
c
831
 
      enddo
832
 
      if (me.eq.0) then
833
 
         write(6,*)
834
 
         write(6,*) ' ga_get is OK'
835
 
         write(6,*)
836
 
         call ffflush(6)
837
 
      endif
838
 
      call ga_sync()
839
 
c
840
 
c     Check the ga_copy function
841
 
c
842
 
      if (me .eq. 0) then
843
 
         write(6,*)
844
 
         write(6,*)'> Checking copy'
845
 
         write(6,*)
846
 
         call ffflush(6)
847
 
      endif
848
 
      call ga_sync()
849
 
#ifndef MIRROR
850
 
      if(me.eq.0) call ga_put(g_a, 1, n, 1, n, a, n)
851
 
#else
852
 
      if(iproc.eq.0) call ga_put(g_a, 1, n, 1, n, a, n)
853
 
#endif
854
 
      call ga_copy(g_a, g_b)
855
 
      call ga_get(g_b, 1, n, 1, n, b, n)
856
 
      do j = 1, n
857
 
         do i = 1, n
858
 
            if (b(i,j) .ne. a(i,j)) then
859
 
               write(6,*) ' copy ', me, i, j, a(i,j), b(i,j)
860
 
               call ga_error('... exiting ',0)
861
 
            endif
862
 
         enddo
863
 
      enddo
864
 
      if (me.eq.0) then
865
 
         write(6,*)
866
 
         write(6,*) ' copy is OK '
867
 
         write(6,*)
868
 
      endif
869
 
c
870
 
c     Check scatter&gather
871
 
c
872
 
      call ga_sync()
873
 
      if (me .eq. 0) then
874
 
         write(6,*) '> Checking scatter/gather (might be slow)... '
875
 
         call ffflush(6)
876
 
         if(me.eq.0) call ga_put(g_a, 1, n, 1, n, a, n)
877
 
      endif
878
 
      call ga_sync()
879
 
c
880
 
      crap = drand(ga_nodeid()*51 +1) !Different seed for each proc
881
 
      do j = 1, 10
882
 
       call ga_sync()
883
 
#ifndef MIRROR
884
 
       itmp = iran(nproc)-1
885
 
       if(me.eq.itmp) then
886
 
#else
887
 
       itmp = iran(lprocs)-1
888
 
       if(iproc.eq.itmp) then
889
 
#endif
890
 
         do loop = 1,m
891
 
           ilo = iran(n)
892
 
           jlo = iran(n)
893
 
           iv(loop) = ilo
894
 
           jv(loop) = jlo
895
 
         enddo
896
 
         call ga_gather(g_a, v, iv, jv, m)
897
 
         do loop = 1,m
898
 
           ilo= iv(loop)
899
 
           jlo= jv(loop)
900
 
           call ga_get(g_a,ilo,ilo,jlo,jlo,v(loop),1)
901
 
           if(v(loop)  .ne. a(ilo,jlo))then
902
 
             write(6,*)me,' gather ', ilo,',',jlo,',', a(ilo,jlo)
903
 
     &             ,' ',v(loop)
904
 
             call ffflush(6)
905
 
             call ga_error('... exiting ',0)
906
 
           endif
907
 
         enddo
908
 
       endif
909
 
      enddo
910
 
c
911
 
      if (me.eq.0) then
912
 
         write(6,*)
913
 
         write(6,*) ' gather is  OK'
914
 
         write(6,*)
915
 
         call ffflush(6)
916
 
      endif
917
 
c
918
 
      do j = 1,10
919
 
       call ga_sync()
920
 
#ifndef MIRROR
921
 
       if(me.eq.iran(ga_nnodes())-1) then
922
 
#else
923
 
       if(me.eq.iran(lprocs)-1) then
924
 
#endif
925
 
         do loop = 1,m
926
 
           ilo = iran(n)
927
 
           jlo = iran(n)
928
 
           iv(loop) = ilo
929
 
           jv(loop) = jlo
930
 
           v(loop) = (1d0,-1d0) *(ilo+jlo)
931
 
         enddo
932
 
         call ga_scatter(g_a, v, iv, jv, m)
933
 
         do loop = 1,m
934
 
           ilo= iv(loop)
935
 
           jlo= jv(loop)
936
 
           call ga_get(g_a,ilo,ilo,jlo,jlo,w(loop),1)
937
 
           if(w(loop)  .ne. (1d0,-1d0) *(ilo+jlo) )then
938
 
             write(6,*)me,' scatter ', ilo,',',jlo,',',w(loop)
939
 
     &             ,' ', (1d0,-1d0) *(ilo+jlo)
940
 
             call ffflush(6)
941
 
           endif
942
 
         enddo
943
 
       endif
944
 
       call ga_sync()
945
 
      enddo
946
 
c
947
 
      if (me.eq.0) then
948
 
         write(6,*)
949
 
         write(6,*) ' scatter is  OK'
950
 
         write(6,*)
951
 
      endif
952
 
c
953
 
c     Delete the global arrays
954
 
c
955
 
      status = ga_destroy(g_b)
956
 
      status = ga_destroy(g_a)
957
 
c
958
 
      istatus = nga_deregister_type(dcpl_type)
959
 
c
960
 
      end
961
 
 
962
 
      subroutine util_qfill(n,val,a,ia)
963
 
      implicit none
964
 
      double  complex  a(*), val
965
 
      integer n, ia, i
966
 
c
967
 
c     initialise double complex array to scalar value
968
 
c
969
 
      if (ia.eq.1) then
970
 
         do 10 i = 1, n
971
 
            a(i) = val
972
 
 10      continue
973
 
      else
974
 
         do 20 i = 1,(n-1)*ia+1,ia
975
 
            a(i) = val
976
 
 20      continue
977
 
      endif
978
 
c
979
 
      end
980