1#if HAVE_CONFIG_H
2#   include "config.fh"
3#endif
4      program main
5      implicit none
6#include "mafdecls.fh"
7#include "global.fh"
8      integer dim, minutes
9      integer heap, stack
10      logical status
11      integer proc, me
12c
13c**** You can change dimension of the array and duration of the test here
14      parameter (dim=500, minutes =90)
15c
16#include "mp3.fh"
17c
18c***  Initialize GA
19      call ga_initialize()
20c
21      proc = ga_nnodes()
22      heap = dim*dim/proc
23      stack= heap
24c
25      status = ma_init(MT_DBL, stack, heap)
26      if (.not. status) call ga_error( 'ma_init failed',stack+heap)
27c
28      me = ga_nodeid()
29      if(me.eq.0)then
30        print *, 'Testing random gets and puts'
31        print *, ' array: ',dim,' x ',dim
32        print *, ' using ',proc, ' process(es)'
33        print *, ' test should run for ',minutes,' minutes'
34        call ffflush(6)
35      endif
36c
37      call check_dbl(dim, minutes)
38c
39      if(me.eq.0)then
40        print *, 'Test completed succesfuly'
41      endif
42c
43      if(ga_nodeid().eq.0)call ga_print_stats()
44      call ga_terminate()
45      call MP_FINALIZE()
46      end
47
48
49      subroutine check_dbl(dim, minutes)
50      implicit none
51#include "mafdecls.fh"
52#include "global.fh"
53#include "testutil.fh"
54c
55      integer n
56      parameter (n = 10)
57      integer dim, minutes
58      double precision a(n,n)
59      double precision t0, elapsed
60      integer g_a
61      integer index, ld
62      integer iran, i,j, loop, maxloop, ilo, ihi, jlo, jhi, range
63      integer nproc, me
64      logical status
65c
66c**** maxloop determines number of puts/gest done before checking the clock
67c
68      parameter (maxloop = 100000)
69      double precision crap
70      iran(i) = int(drand(0)*real(i-1)) + 1
71c
72      nproc = ga_nnodes()
73      me    = ga_nodeid()
74      crap  = drand(real(me)) !different seed for each process
75      if(n .gt. dim) call ga_error('insufficient dimension',dim)
76c
77      status = ga_create(MT_DBL, dim, dim, 'a', 0, 0, g_a)
78      if (.not. status) then
79         write(6,*) ' ga_create failed'
80         call ffflush(6)
81         call ga_error('... exiting ',0)
82      endif
83c
84c     initialize array in place
85      call ga_distribution(g_a,me,ilo, ihi, jlo, jhi)
86      call ga_access(g_a, ilo,ihi,jlo,jhi, index, ld)
87*     print *, 'DBL_MB=', DBL_MB(1), index
88      call fill_local(DBL_MB(index), ihi-ilo+1, jhi-jlo+1, ilo, jlo, ld)
89c
90      call ga_sync()
91      t0 = util_timer()
92c
93      if (me .eq. 0) then
94         write(6,21)
95 21      format(/'> Start ... ')
96         call ffflush(6)
97      endif
98c
99c
100      range = dim - n -1
101100   continue
102         do loop = 1, maxloop
103c
104c           always get 100x100 patches
105            ilo = iran(range)
106            jlo = iran(range)
107            ihi = ilo+n-1
108            jhi = jlo+n-1
109c
110            call ga_get(g_a, ilo, ihi, jlo, jhi, a, n)
111c
112c           check if data OK
113            call check_data(a,n,n, ilo, jlo, n)
114c
115c           copy the data back
116            call ga_put(g_a, ilo, ihi, jlo, jhi, a, n)
117#ifdef DEBUG
118            print *, me, 'OK', ilo, ihi, jlo, jhi
119            call ffflush(6)
120#endif
121         enddo
122         elapsed = util_timer() -t0
123
124      if (me.eq.0)then
125         print *, int(100* elapsed/(minutes*60)),'% done'
126         call ffflush(6)
127      endif
128
129      if(elapsed .lt. real(minutes * 60)) goto 100
130c
131      call ga_sync()
132c
133      if (me.eq.0) then
134         write(6,*)
135         write(6,*) ' everything looks OK'
136         write(6,*)
137         call ffflush(6)
138      endif
139      call ga_sync()
140      status = ga_destroy(g_a)
141      end
142
143
144      subroutine fill_local(a, n,m, x, y , ld)
145      implicit none
146      integer ld, n,m, x,y
147      double precision a(ld,*)
148      integer i,j
149c
150      do j=1,m
151         do i=1,n
152            a(i,j)= real(x+y+i+j-2)
153         enddo
154      enddo
155      end
156
157      subroutine check_data(a,n,m, x,y, ld)
158      implicit none
159#include "global.fh"
160      integer ld, n,m, x,y
161      double precision a(ld,*)
162      integer i,j
163c
164      do j=1,m
165         do i=1,n
166            if(a(i,j) .ne. real(x+y+i+j-2))then
167                print *, 'error:',i+x-1, j+y-1, a(i,j)
168                call ga_error("failed",1)
169            endif
170         enddo
171      enddo
172      end
173
174