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