1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
subroutine m4_func_NGA_SCALE_PATCH(m4_test_type, m4_ndim)
implicit none
#include "mafdecls.fh"
#include "global.fh"
c
integer n,m
integer ndim
parameter (n = m4_n)
parameter (m = (m4_n**m4_ndim)/100)
parameter (ndim = m4_ndim)
m4_data_type a(substr(m4_array, 1, eval(m4_ndim*2-1)))
m4_data_type b(substr(m4_array, 1, eval(m4_ndim*2-1)))
integer dims(ndim)
integer g_a
integer chunk(ndim)
integer i, total
integer elems, count_elems
integer loop
integer lop(ndim), hip(ndim)
integer lo(ndim), hi(ndim)
double precision drand
m4_data_type val
integer nproc, me
logical status
c
nproc = ga_nnodes()
me = ga_nodeid()
c
c---------------------- initialize the GA -----------------------
c initialize the chunk, dims, ld, and calculate the number
c of elements
total=1
do i = 1,ndim
chunk(i) = 0
dims(i) = n
total = total * dims(i)
enddo
c
c*** Create global arrays
if (.not. nga_create(m4_MT, ndim, dims, 'a', chunk, g_a))
$ call ga_error(' ga_create failed ',1)
c
call ga_sync()
c
c--------------------------- NGA_SCALE_PATCH -------------------------
m4_print_info(nga_scale_patch)
c
c initialize GA
call m4_util_init_array(m4_test_type)(a,total)
call nga_distribution(g_a, me, lop, hip)
elems = count_elems(lop, hip, ndim)
if(elems.gt.0) call nga_put(g_a,lop,hip,
$ a(substr(m4_lop_all, 1, eval(m4_ndim*7-1))),dims)
c
call ga_sync()
do i = 1,ndim
lop(i) = 1
hip(i) = n
enddo
c
do loop=1, 10
call random_range(lop,hip,lo,hi,ndim)
if(me.eq.0)
$ call print_range(loop,lo,hi,ndim)
c$$$ $ print *, loop,': scale [',(lo(i),':',hi(i), i=1,ndim),']'
c the random number to scale
val = m4_rand(1)
c
c keep a copy of the origian array
call nga_get(g_a,lo,hi,
$ a(substr(m4_lo_all, 1, eval(m4_ndim*6-1))),dims)
c
call nga_scale_patch(g_a,lo,hi,val)
c
call nga_get(g_a,lo,hi,
$ b(substr(m4_lo_all, 1, eval(m4_ndim*6-1))),dims)
c
c check the result
call m4_util_scale_patch(m4_test_type)(total,
$ val,a,lo,hi,ndim,dims,
$ m4_conv(0),b,lo,hi,ndim,dims)
call m4_util_compare_patches(m4_test_type)(1d-10,total,
$ a,lo,hi,ndim,dims,total,b,lo,hi,ndim,dims)
c
enddo
c
call ga_sync()
if(me.eq.0)then
print *, 'OK'
print *, ' '
call ffflush(6)
endif
c---------------------------
c
status= ga_destroy(g_a)
end
|
