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