← Back to branch summary

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

« 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, 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/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