1#if HAVE_CONFIG_H
2#   include "config.fh"
3#endif
4C
5C     Test the minval, minloc, maxval, maxloc, and enum functions in GA.
6C
7      program main
8      implicit none
9#include "mafdecls.fh"
10#include "global.fh"
11      integer heap, stack, fudge, ma_heap, me, nproc
12      logical status
13      parameter (heap=100*100*4, fudge=100, stack=100*100)
14c
15c***  Intitialize a message passing library
16c
17#include "mp3.fh"
18c
19c***  Initialize GA
20c
21c     There are 2 choices: ga_initialize or ga_initialize_ltd.
22c     In the first case, there is no explicit limit on memory usage.
23c     In the second, user can set limit (per processor) in bytes.
24c
25      call ga_initialize()
26      nproc = ga_nnodes()
27      me = ga_nodeid()
28c     we can also use GA_set_memory_limit BEFORE first ga_create call
29c
30      if(ga_nodeid().eq.0)then
31         print *,' GA initialized ', nproc, stack, heap
32         call ffflush(6)
33      endif
34c
35c***  Initialize the MA package
36c     MA must be initialized before any global array is allocated
37c
38      status = ma_init(MT_DCPL, stack, heap)
39      if (.not. status) call ga_error('ma_init failed',-1)
40c
41      if(me.eq.0)then
42        print *, 'using ', nproc, ' process(es)'
43        call ffflush(6)
44      endif
45c
46      call test_nga_select_elem()                         ! Test global max/min
47      call test_ga_patch_enum()                           ! Test enumerate
48
49c     if(me.eq.0) call ga_print_stats()
50c
51c***  Tidy up the GA package
52c
53      call ga_terminate()
54c
55c***  Tidy up after message-passing library
56c
57      call MP_FINALIZE()
58c
59      end
60
61      subroutine test_nga_select_elem()
62      implicit none
63#include "mafdecls.fh"
64#include "global.fh"
65#include "testutil.fh"
66      integer m                               ! grid size
67      parameter (m = 10)
68      integer g_a                             ! handles to global arrays
69      integer ilo, ihi
70      integer i
71      integer me, nproc                       ! my processor & number of procs
72      integer ndim,dims(1),chunck(1)
73      integer num                             ! number of values per proc
74      integer iv(m)                           ! scatter index array
75      double precision v(m)                   ! scatter value array
76      integer iran
77c
78      integer ilocmax, ilocmin
79      integer ilocmax_ga, ilocmin_ga
80      double precision xmax1, xmin1
81      double precision xmax_ga, xmin_ga
82c
83      iran(i) = int(drand(1)*real(i)) + 1
84c
85c***  check parallel environment
86      me = ga_nodeid()
87      nproc = ga_nnodes()
88c
89c***  create a global 1-D array
90      ndim=1
91      dims(1)=100
92      chunck(1)=20
93      if (.not. nga_create(MT_DBL, ndim, dims, 'array', chunck, g_a))
94     $     call ga_error(' ga_create failed ',0)
95c
96c***  compute local ilo, ihi, num for each processor
97      call nga_distribution(g_a,me,ilo,ihi)
98      num=ihi-ilo+1
99      if(ihi.le.0)num=0
100*     print *, 'me=',me, num,ilo
101c
102c***  scatter some values into the global array
103      call ga_fill(g_a,0.0d+00)
104      do i=1,Min(num,m)
105         v(i)=real(ilo+i-1)
106         iv(i)=ilo+i-1
107*        print *,'me=',me,'val=',iv(i)
108      enddo
109      if(num.gt.0)call NGA_scatter(g_a,v,iv,Min(num,m))
110      call ga_sync()
111      if(me.eq.0)then
112        ilocmax = Mod(iran(50000000),dims(1))
113        ilocmin = Mod(iran(1000000),dims(1))
114C        if(ilocmin.eq.ilocmax) ilocmin=Mod(ilocmin+1,dims(1)-1)
115        xmax1 = drand(0)*real(ilo) + dims(1)
116        xmin1= -1
117        call nga_put(g_a,ilocmin,ilocmin,xmin1,1)
118        call nga_put(g_a,ilocmax,ilocmax,xmax1,1)
119      endif
120c     call ga_print(g_a)
121c
122c***  Find the maximum value and the index of the maximum value
123      call nga_select_elem(g_a,'max',xmax_ga,ilocmax_ga)
124c***  Find the minimum value and the index of the minimum value
125      call nga_select_elem(g_a,'min',xmin_ga,ilocmin_ga)
126c
127c
128      if(me.eq.0)then
129        print *," "
130        print *,"Correct Max: value=",xmax1  ," location=",ilocmax
131        print *,"     GA Max: value=",xmax_ga," location=",ilocmax_ga
132        print *," "
133        print *,"Correct Min: value=",xmin1  ," location=",ilocmin
134        print *,"     GA Min: value=",xmin_ga," location=",ilocmin_ga
135      endif
136c
137      if(.not. ga_destroy(g_a)) call ga_error('invalid handle: g_a',0)
138c
139      return
140      end
141
142      subroutine test_ga_patch_enum()
143      implicit none
144#include "mafdecls.fh"
145#include "global.fh"
146      integer m                               ! grid size
147      parameter (m = 10)
148      integer g_a, g_b, g_c                   ! handles to INT global arrays
149      integer ilo, ihi
150      integer i,j,cmin,cmax,nelem
151      integer me, nproc                       ! my processor & number of procs
152      integer ndim,dims,chunk(1)
153      integer num                             ! number of values per proc
154      integer iv(m)                           ! scatter index and value array
155c
156c***  check parallel environment
157      me = ga_nodeid()
158      nproc = ga_nnodes()
159c
160c***  compute local ilo, ihi, num for each processor
161c     ilo=1+me*m
162c     ihi=(me+1)*m
163c     num=ihi-ilo+1
164c
165c***  create the global 1-D arrays
166      ndim=1
167      dims=100
168      chunk(1)=40
169      if (.not. nga_create(MT_INT, ndim, dims, 'array a', chunk, g_a))
170     $     call ga_error(' ga_create failed ',0)
171      if (.not. nga_create(MT_INT, ndim, dims, 'array b', chunk, g_b))
172     $     call ga_error(' ga_create failed ',0)
173      if (.not. nga_create(MT_INT, ndim, dims, 'array c', chunk, g_c))
174     $     call ga_error(' ga_create failed ',0)
175c
176c***  Enumerate a each patch to get a sequential vector.
177      call ga_patch_enum(g_b,1,dims,1,1)
178c     call ga_print(g_b)
179c
180c***  enumerate manually g_a
181      call nga_distribution(g_a,me,ilo,ihi)
182      if(ilo.gt.0) then
183        do i = ilo,ihi,m
184           nelem = MIN(m, ihi-i+1)
185           do j = 1, nelem
186              iv(j)=i + j-1
187           enddo
188           call nga_put(g_a,i,i+nelem -1,iv,1)
189        enddo
190      endif
191c     call ga_print(g_a)
192c
193c***  g_c = -1 * g_a + 1 * g_b (hopefully all results will be zero)
194      call ga_add(-1,g_a,1,g_b,g_c)
195c     call ga_print(g_c)
196c
197c     find min and max values
198      call nga_select_elem(g_c,'min',cmin,ilo)
199      call nga_select_elem(g_c,'max',cmax,ihi)
200      if(me.eq.0)then
201         if(cmin.ne.cmax .or. cmin.ne.0)then
202            print *,'Failed',cmin,cmax
203         else
204            print *,"GA_PATCH_ENUM successful"
205         endif
206      endif
207c
208      if(.not. ga_destroy(g_a)) call ga_error('invalid handle: g_a',0)
209      if(.not. ga_destroy(g_b)) call ga_error('invalid handle: g_b',0)
210      if(.not. ga_destroy(g_c)) call ga_error('invalid handle: g_c',0)
211c
212      return
213      end
214