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