1c$Id$
2#define  MAXLOOP 100
3
4      subroutine util_ndim_test
5      implicit none
6#include "mafdecls.fh"
7#include "global.fh"
8#include "testutil.fh"
9      integer nproc
10      logical status
11c
12c***  Intitialize a message passing library
13c
14#ifdef MPI
15c     integer ierr
16c     call mpi_init(ierr)
17#else
18c     call pbeginf
19#endif
20c     Intitialize the GA package
21c
22c     call ga_initialize()
23      nproc = ga_nnodes()
24c     if(ga_nodeid().eq.0)print *,nproc,' nodes'
25c
26c     Initialize the MA package
27c
28c     status = ma_init(MT_DBL, 500000/nproc, 50000)
29c     if(.not. status) call ga_error("ma_init failed",0)
30c
31c
32      if(ga_nodeid().eq.0) then
33       write(6,'(A)') ' Checking 3-Dimensional Arrays'
34       write(6,*)
35      endif
36      call testit()
37      if(ga_nodeid().eq.0) then
38       write(6,*)
39       write(6,'(A)') ' Checking 4-Dimensional Arrays'
40       write(6,*)
41      endif
42      call testit4()
43c     call ga_terminate()
44c
45c***  Tidy up after message-passing library
46c
47#ifdef MPI
48c     call mpi_finalize(ierr)
49#else
50c     call pend()
51#endif
52      end
53
54
55c-----------------
56
57
58
59      subroutine testit()
60      implicit none
61#include "mafdecls.fh"
62#include "global.fh"
63#include "testutil.fh"
64c
65      integer n
66      integer ndim
67      parameter (n = 38)
68      parameter (ndim = 3)
69      double precision a(n,n,n),b(n,n,n)
70      integer g_a
71      integer  i,  lo(ndim),hi(ndim), lop(ndim),hip(ndim),elems
72      integer nproc, me, proc, loop, maxloop
73      integer chunk(ndim), dims(ndim), adims(ndim), ld(ndim)
74      logical status, compare_patches
75      integer count_elems
76      double precision crap,alpha
77c
78      nproc = ga_nnodes()
79      me    = ga_nodeid()
80c
81
82      call ifill_array(chunk,ndim,0)
83      call ifill_array(adims,ndim,n-1)
84      call ifill_array(dims,ndim,n)
85      call ifill_array(ld,ndim,n)
86      call dfill_array(a,n*n*n,dble(me))
87      call dfill_array(b,n*n*n,-1d0)
88c
89c***  Create global arrays
90      if (.not. nga_create(MT_DBL, ndim, adims, 'a', chunk, g_a))
91     $     call ga_error(' ga_create failed ',1)
92c
93      call ga_sync()
94c     if(me.eq.0)then
95c        write(6,'(i2,21H-dimensional Array A:  ,10i6)')
96c    $   ndim,(adims(i),i=1,ndim)
97c        print *,'distribution information for all processors'
98c        print *,'-------------------------------------------'
99c        call ffflush(6)
100c     endif
101      call ga_sync()
102      call nga_distribution(g_a, me, lo,hi)
103      elems = count_elems(lo,hi,ndim)
104c
105      do i = 0, nproc-1
106c       if (me .eq. i) then
107c100      format(i4,' has',i8,' elements of A, range:',10(i3,':',i3,','))
108c        write(*,100)me,elems,(lo(j),hi(j),j=1,ndim)
109c         call print_range(me, lo, hi, ndim)
110c         call ffflush(6)
111c       endif
112       call ga_sync()
113      enddo
114c
115c------------------------------- GA_FILL ----------------------------
116      call ga_fill(g_a,dble(me))
117c     if(me.eq.0)then
118c       print *, ' '
119c       print *, 'Filling array A'
120c       call ffflush(6)
121c     endif
122c     call ga_print(g_a)
123      call ga_sync()
124c
125      if(elems.gt.0) then
126        call nga_get(g_a,lo,hi,b(lo(1),lo(2),lo(3)),ld)
127
128        if(compare_patches(me,0d0,ndim,a,lo,hi,dims,b,lo,hi,dims))
129     $             call ga_error('bye',0)
130      endif
131
132      call ga_sync()
133      if(me.eq.0)then
134        write(6,'(A)') ' ga_fill .......................... OK'
135c       print *, 'OK'
136c       print *, ' '
137c       print *, 'Testing random PUT'
138c       print *,'(only process 0 prints range for its every 10-th put)'
139        call ffflush(6)
140      endif
141      call ga_fill(g_a,-1d0)
142c
143c------------------------------- NGA_PUT ----------------------------
144c     if(nproc.gt.0)return
145      proc =  nproc-1 -me ! access other process memory
146      call nga_distribution(g_a, proc, lo,hi)
147      elems = count_elems(lo,hi,ndim)
148      call init_array(a,ndim,dims)
149c
150      call ga_sync()
151      if(elems.gt.0) then
152         call nga_put(g_a,lo,hi,a(lo(1),lo(2),lo(3)),ld)
153         do loop = 1, MAXLOOP
154            call random_range(lo,hi,lop,hip,ndim)
155c           if(me.eq.0 .and. Mod(loop,10).eq.0)then
156c              call print_range(loop,lop,hip,ndim)
157c           endif
158            call nga_put(g_a,lop,hip,a(lop(1),lop(2),lop(3)),ld)
159         enddo
160
161         call nga_get(g_a,lo,hi,b(lo(1),lo(2),lo(3)),ld)
162
163         if(compare_patches(me,0d0,ndim,a,lo,hi,dims,b,lo,hi,dims))
164     $             call ga_error('bye',0)
165
166      endif
167c
168      call ga_sync()
169      if(me.eq.0)then
170        write(6,'(A)') ' nga_put .......................... OK'
171c       print *, 'OK'
172c       print *, ' '
173c       print *, 'Testing random GET'
174c       print *,'(only process 0 prints range for its every 10-th get)'
175        call ffflush(6)
176      endif
177c------------------------------- NGA_GET ----------------------------
178      call ga_sync()
179      call ifill_array(lop,ndim,1)
180      call ifill_array(hip,ndim,n-1)
181      do loop = 1, MAXLOOP
182         call random_range(lop,hip,lo,hi,ndim)
183c        if(me.eq.0 .and. Mod(loop,10).eq.1)then
184c           call print_range(loop,lo,hi,ndim)
185c        endif
186         call nga_get(g_a,lo,hi,b(lo(1),lo(2),lo(3)),ld)
187         if(compare_patches(me,0d0,ndim,a,lo,hi,dims,b,lo,hi,dims))
188     $             call ga_error('bye',0)
189      enddo
190c------------------------------- NGA_ACC ----------------------------
191      call ga_sync()
192      if(me.eq.0)then
193        write(6,'(A)') ' nga_get .......................... OK'
194c       print *, 'OK'
195c       print *, ' '
196c       print *, 'Testing Accumulate'
197        call ffflush(6)
198      endif
199c
200      call ga_sync()
201      call ifill_array(lop,ndim,1)
202      call ifill_array(hip,ndim,n-1)
203      call random_range(lop,hip,lo,hi,ndim)
204      crap = util_drand(1)
205      maxloop = 10
206      alpha = .1d0 ! alpha must be 1/maxloop
207      call ga_sync()
208c
209      do loop=1, maxloop
210       call nga_acc(g_a,lop,hip,a(lop(1),lop(2),lop(3)),ld,alpha)
211      enddo
212      call ga_sync()
213      if(me.eq.0)then
214c       print *, 'multiple accumulate target same array section'
215c       call print_range(maxloop,lo,hi,ndim)
216        call nga_get(g_a,lo,hi,b(lo(1),lo(2),lo(3)),ld)
217        call scale_patch(dble(nproc+1),ndim, a(lo(1),lo(2),lo(3)),
218     $                    lo, hi, dims)
219        if(compare_patches(me,1d-2,ndim,a,lo,hi,dims,b,lo,hi,dims))
220     $             call ga_error('bye',0)
221        write(6,'(A)') ' nga_acc .......................... OK'
222c       print *, 'OK'
223        call ffflush(6)
224      endif
225c
226      status= ga_destroy(g_a)
227      end
228
229
230      subroutine testit4()
231      implicit none
232#include "mafdecls.fh"
233#include "global.fh"
234#include "testutil.fh"
235c
236      integer n
237      integer ndim
238      parameter (n = 25)
239      parameter (ndim = 4)
240      double precision a(n,n,n,n),b(n,n,n,n)
241      integer g_a
242      integer  i, lo(ndim),hi(ndim), lop(ndim),hip(ndim),elems
243      integer nproc, me, proc, loop, maxloop
244      integer chunk(ndim), dims(ndim), ld(ndim)
245      logical status, compare_patches
246      integer count_elems
247      double precision crap,alpha
248c
249      nproc = ga_nnodes()
250      me    = ga_nodeid()
251c
252
253      call ifill_array(chunk,ndim,0)
254      call ifill_array(dims,ndim,n)
255      call ifill_array(ld,ndim,n)
256      elems=1
257      do i = 1,ndim
258         elems = elems * dims(i)
259      enddo
260      call dfill_array(a,elems,dble(me))
261      call dfill_array(b,elems,-1d0)
262c
263c***  Create global arrays
264      if (.not. nga_create(MT_DBL, ndim, dims, 'a', chunk, g_a))
265     $     call ga_error(' ga_create failed ',1)
266c
267      call ga_sync()
268c     if(me.eq.0)then
269c        write(6,'(i2,21H-dimensional Array A:  ,10i6)')
270c    $   ndim,(dims(i),i=1,ndim)
271c        print *,'distribution information for all processors'
272c        print *,'-------------------------------------------'
273c        call ffflush(6)
274c     endif
275      call ga_sync()
276      call nga_distribution(g_a, me, lo,hi)
277      elems = count_elems(lo,hi,ndim)
278c
279      do i = 0, nproc-1
280c       if (me .eq. i) then
281c100      format(i4,' has',i8,' elements of A, range:',10(i3,':',i3,','))
282cc        write(*,100)me,elems,(lo(j),hi(j),j=1,ndim)
283c         call print_range(me, lo, hi, ndim)
284c         call ffflush(6)
285c       endif
286       call ga_sync()
287      enddo
288c
289c------------------------------- GA_FILL ----------------------------
290      call ga_fill(g_a,dble(me))
291c     if(me.eq.0)then
292c       print *, ' '
293c       print *, 'Filling array A'
294c       call ffflush(6)
295c     endif
296c     call ga_print(g_a)
297      call ga_sync()
298c
299      if(elems.gt.0) then
300        call nga_get(g_a,lo,hi,b(lo(1),lo(2),lo(3),lo(4)),ld)
301
302        if(compare_patches(me,0d0,ndim,a,lo,hi,dims,b,lo,hi,dims))
303     $             call ga_error('bye',0)
304      endif
305
306      call ga_sync()
307      if(me.eq.0)then
308        write(6,'(A)') ' ga_fill .......................... OK'
309c       print *, 'OK'
310c       print *, ' '
311c       print *, 'Testing random PUT'
312c       print *,'(only process 0 prints range for its every 10-th put)'
313        call ffflush(6)
314      endif
315      call ga_fill(g_a,-1d0)
316c
317c------------------------------- NGA_PUT ----------------------------
318c     if(nproc.gt.0)return
319      proc =  nproc-1 -me ! access other process memory
320      call nga_distribution(g_a, proc, lo,hi)
321      elems = count_elems(lo,hi,ndim)
322      call init_array(a,ndim,dims)
323c
324      call ga_sync()
325      if(elems.gt.0) then
326         call nga_put(g_a,lo,hi,a(lo(1),lo(2),lo(3),lo(4)),ld)
327         do loop = 1, MAXLOOP
328            call random_range(lo,hi,lop,hip,ndim)
329c           if(me.eq.0 .and. Mod(loop,10).eq.0)then
330c              call print_range(loop,lop,hip,ndim)
331c           endif
332            call nga_put(g_a,lop,hip,a(lop(1),lop(2),lop(3),lop(4)),ld)
333         enddo
334
335         call nga_get(g_a,lo,hi,b(lo(1),lo(2),lo(3),lo(4)),ld)
336
337         if(compare_patches(me,0d0,ndim,a,lo,hi,dims,b,lo,hi,dims))
338     $             call ga_error('bye',0)
339
340      endif
341c
342      call ga_sync()
343      if(me.eq.0)then
344        write(6,'(A)') ' nga_put .......................... OK'
345c       print *, 'OK'
346c       print *, ' '
347c       print *, 'Testing random GET'
348c       print *,'(only process 0 prints range for its every 10-th get)'
349        call ffflush(6)
350      endif
351c------------------------------- NGA_GET ----------------------------
352      call ga_sync()
353      call ifill_array(lop,ndim,1)
354      call ifill_array(hip,ndim,n)
355      do loop = 1, MAXLOOP
356         call random_range(lop,hip,lo,hi,ndim)
357c        if(me.eq.0 .and. Mod(loop,10).eq.0)then
358c           call print_range(loop,lo,hi,ndim)
359c        endif
360         call nga_get(g_a,lo,hi,b(lo(1),lo(2),lo(3),lo(4)),ld)
361         if(compare_patches(me,0d0,ndim,a,lo,hi,dims,b,lo,hi,dims))
362     $             call ga_error('bye',0)
363      enddo
364c------------------------------- NGA_ACC ----------------------------
365      call ga_sync()
366      if(me.eq.0)then
367        write(6,'(A)') ' nga_get .......................... OK'
368c       print *, 'OK'
369c       print *, ' '
370c       print *, 'Testing Accumulate'
371        call ffflush(6)
372      endif
373c
374      call ga_sync()
375      call ifill_array(lop,ndim,1)
376      call ifill_array(hip,ndim,n)
377      call random_range(lop,hip,lo,hi,ndim)
378      crap = util_drand(1)
379      maxloop = 10
380      alpha = .1d0 ! alpha must be 1/maxloop
381      call ga_sync()
382c
383      do loop=1, maxloop
384       call nga_acc(g_a,lop,hip,a(lop(1),lop(2),lop(3),lop(4)),ld,alpha)
385      enddo
386      call ga_sync()
387      if(me.eq.0)then
388c       print *, 'multiple accumulate target same array section'
389c       call print_range(maxloop,lo,hi,ndim)
390        call nga_get(g_a,lo,hi,b(lo(1),lo(2),lo(3),lo(4)),ld)
391        call scale_patch(dble(nproc+1),ndim, a(lo(1),lo(2),lo(3),lo(4)),
392     $                    lo, hi, dims)
393        if(compare_patches(me,1d-2,ndim,a,lo,hi,dims,b,lo,hi,dims))
394     $             call ga_error('bye',0)
395        write(6,'(A)') ' nga_acc .......................... OK'
396c       print *, 'OK'
397        call ffflush(6)
398      endif
399c
400      status= ga_destroy(g_a)
401      end
402
403
404
405
406
407
408
409      subroutine random_range(lo,hi,lop,hip,ndim)
410      implicit none
411#include "testutil.fh"
412      integer lo(1),hi(1),lop(1),hip(1),ndim
413      integer i, range, swap, val
414      integer iran
415      external iran
416
417      do i = 1, ndim
418         range = hi(i)-lo(i)+1
419         val = iran(range)
420         lop(i) = lo(i) + val
421         val = iran(range)
422         hip(i) = hi(i) - val
423         if(hip(i) .lt. lop(i))then
424            swap =hip(i)
425            hip(i)=lop(i)
426            lop(i)=swap
427         endif
428         hip(i)=MIN(hip(i),hi(i))
429         lop(i)=MAX(lop(i),lo(i))
430      enddo
431      end
432
433
434      subroutine compare(a,b,n)
435      double precision a(1), b(1)
436      integer n
437      integer i
438      do i =1, n
439         if(a(i).ne.b(i))then
440           print *, 'error',a(i),b(i)
441           call ga_error("comparison failed",0)
442         endif
443      enddo
444      end
445
446
447      integer function count_elems(lo,hi,ndim)
448      implicit none
449      integer lo(1),hi(1),ndim,elems,i
450      elems=1
451      do i=1,ndim
452         elems = elems*(hi(i)-lo(i)+1)
453      enddo
454      count_elems = elems
455      end
456
457
458      subroutine testit2()
459      implicit none
460#include "mafdecls.fh"
461#include "global.fh"
462#include "testutil.fh"
463c
464      integer n
465      parameter (n = 5)
466*     double precision a(n,n), b(n,n), c(n,n)
467      integer g_a,g_b
468      integer  i, ilo,ihi,jlo,jhi
469      integer nproc, me
470c
471      nproc = ga_nnodes()
472      me    = ga_nodeid()
473c
474c***  Create global arrays
475      if (.not. ga_create(MT_DCPL, n, n, 'a', 0, 0, g_a))
476     $     call ga_error(' ga_create failed ',2)
477      if (.not. ga_create(MT_DCPL, 1, n, 'b', 1, n, g_b))
478     $     call ga_error(' ga_create failed ',2)
479c
480c
481      call ga_sync()
482      if(me.eq.0)print *,'Array A ',n,'x',n
483      do i = 0, nproc-1
484         if (me .eq. i) then
485            call ga_distribution(g_a, me, ilo,ihi,jlo,jhi)
486            print *,  ' my portion of A  ',ilo,ihi,jlo,jhi
487            call ffflush(6)
488         endif
489         call ga_sync()
490      enddo
491      call ga_sync()
492      if(me.eq.0)print *,'Array B ',n/3,'x',n
493      call ga_sync()
494      do i = 0, nproc-1
495         if (me .eq. i) then
496            call ga_distribution(g_b, me, ilo,ihi,jlo,jhi)
497            print *,  ' my portion of B  ',ilo,ihi,jlo,jhi
498            call ffflush(6)
499         endif
500         call ga_sync()
501      enddo
502
503      end
504
505      subroutine dfill_array(a,n,val)
506      implicit none
507      integer n
508      double precision a(n),val
509      integer k
510      do k= 1, n
511         a(k) = val
512      enddo
513      end
514
515      subroutine ifill_array(a,n,val)
516      implicit none
517      integer n
518      integer a(n),val
519      integer k
520      do k= 1, n
521         a(k) = val
522      enddo
523      end
524