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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
|
#if HAVE_CONFIG_H
# include "config.fh"
#endif
c
c FNAME - filename for test program
c
#define BASE_NAME 'dra.file'
#ifdef HPIODIR
# define FNAME HPIODIR//BASE_NAME
#else
# define FNAME BASE_NAME
#endif
program io
#include "mafdecls.fh"
#include "global.fh"
#include "dra.fh"
integer status, me
integer max_arrays
integer stack, heap
double precision max_sz, max_disk, max_mem
data max_arrays, max_sz, max_disk, max_mem /10,1d8,1d10, 1d6/
data stack, heap /80000, 80000/
c
#include "mp3.fh"
if(ma_init(MT_F_DBL, stack, heap) ) then
call ga_initialize()
me = ga_nodeid()
if(dra_init(max_arrays, max_sz, max_disk, max_mem).ne.0)then
call ga_error('dra_init failed: ',0)
endif
if (me.eq.0) print*,' '
if(me.eq.0)print *, 'TESTING INTEGERS'
if (me.eq.0) print*,' '
call test_io_int()
if (me.eq.0) print*,' '
if(me.eq.0)print *, 'TESTING DOUBLES'
if (me.eq.0) print*,' '
call test_io_dbl()
status = dra_terminate()
call ga_terminate()
else
print *,'ma_init failed'
endif
c if(me.eq.0)print *, 'all done ...'
call MP_FINALIZE()
end
subroutine test_io_int
implicit none
#include "mafdecls.fh"
#include "global.fh"
#include "dra.fh"
integer n,m
parameter (n = 100)
parameter (m = 2*n)
integer a(n,n)
integer g_a, g_b, d_a
integer i,j, req, err, dim1, dim2, type
integer me, nproc
logical status
character*1 filename(200)
character*80 name
c
nproc = ga_nnodes()
me = ga_nodeid()
call init_char(name,100, ' ')
call init_char(filename,200, ' ')
c
c a() is a local copy of what the l array should start as
c
do j = 1, n
do i = 1, n
a(i,j) = i-1 + (j-1)*n
enddo
enddo
c
if (me.eq.0) print *, 'Creating global arrays'
call ga_sync()
if(.not. ga_create(MT_INT, n, n, 'a', 1, 1, g_a))
& call ga_error('ga_create failed: a', 0)
if(.not. ga_create(MT_INT, n, n, 'b', 1, 1, g_b))
& call ga_error('ga_create failed: b', 0)
c
* call ga_zero(g_a)
* call ga_zero(g_b)
c
do j = 1+me, n, nproc
call ga_put(g_a, 1, n, j, j, a(1, j), n)
enddo
c
if(me.eq.0) print *, 'Creating Disk Array ',n,' x',n
if(dra_create(MT_INT, n, n, 'array A',
& FNAME,
& DRA_RW, n, 1, d_a).ne.0)
$ CALL ga_error('dra_create failed: ',0)
if (me.eq.0) print *,'OK'
if (me.eq.0) print*,' '
c
if(me.eq.0) print *, 'Writing Global Array to Disk Array'
if(dra_write(g_a, d_a,req).ne.0)
$ CALL ga_error('dra_write failed:',0)
if(dra_wait(req).ne.0)call ga_error('dra_wait failed: ' ,req)
if (me.eq.0) print *,'OK'
if (me.eq.0) print*,' '
if(me.eq.0) print *, 'Closing Disk Array'
if(dra_close(d_a).ne.0)call ga_error('dra_close failed: ',d_a)
if (me.eq.0) print *,'OK'
if (me.eq.0) print*,' '
c
if(me.eq.0) print *, 'Opening Existing Disk Array'
if(dra_open(FNAME ,DRA_R, d_a).ne.0)
& call ga_error('dra_open failed',0)
c
if(dra_inquire(d_a, type, dim1, dim2, name, filename).ne.0)
& call ga_error('dra_inquire failed',0)
if(dim1.ne.n) call ga_error('dim1 error',dim1)
if(dim2.ne.n) call ga_error('dim2 error',dim2)
if(type.ne.MT_INT) call ga_error('type error',type)
if(me.eq.0) print *, 'array name read from disk is:',name
call ga_sync()
if (me.eq.0) print *,'OK'
if (me.eq.0) print*,' '
c
if(me.eq.0) print *, 'Checking dra_read'
c call dra_set_mode(1)
if(dra_read(g_b, d_a, req).ne.0)
$ CALL ga_error('dra_read failed:',0)
if(dra_wait(req).ne.0) call ga_error('dra_wait failed: ' ,req)
c
c error checking: (g_a - g_b)^2
c
c call ga_print(g_a)
c call ga_print(g_b)
call ga_add(1, g_a, -1, g_b, g_b)
err = ga_idot(g_b, g_b)
c
if(err.ne.0 )then
if( me.eq.0) call ga_error('failed', err)
else
if (me.eq.0) print *,'OK'
endif
if (me.eq.0) print*,' '
c
if(me.eq.0) print *, 'Checking dra_delete'
if(dra_delete(d_a).ne.0)
& call ga_error('dra_delete failed',0)
if (me.eq.0) print *,'OK'
if (me.eq.0) print*,' '
status = ga_destroy(g_a)
status = ga_destroy(g_b)
end
subroutine test_io_dbl
implicit none
#include "mafdecls.fh"
#include "global.fh"
#include "dra.fh"
integer n,m
parameter (n = 100)
parameter (m = 2*n)
double precision a(n,n), err
integer g_a, g_b, d_a
double precision drand
integer i,j, req, loop
integer dilo,dihi,djlo,djhi
integer gilo,gihi,gjlo,gjhi
integer ielem, jelem
integer me, nproc
integer iran
logical status
external drand
intrinsic int, dble
iran(i) = int(drand(0)*dble(i-1)) + 1
c
loop = 30
nproc = ga_nnodes()
me = ga_nodeid()
c
c a() is a local copy of what the l array should start as
c
do j = 1, n
do i = 1, n
a(i,j) = dble(i-1 + (j-1)*n)
enddo
enddo
c
call ga_sync()
if(.not. ga_create(MT_DBL, n, n, 'a', 1, 1, g_a))
& call ga_error('ga_create failed: a', 0)
if(.not. ga_create(MT_DBL, n, n, 'b', 1, 1, g_b))
& call ga_error('ga_create failed: b', 0)
c
call ga_zero(g_a)
call ga_zero(g_b)
c
do j = 1+me, n, nproc
call ga_put(g_a, 1, n, j, j, a(1, j), n)
enddo
c
if (me.eq.0) print*, 'Creating Disk Array ',n,' x',n
if(dra_create(MT_DBL, n, n, 'A',
& FNAME,
& DRA_RW, n, 3, d_a).ne.0)
$ CALL ga_error('dra_create failed: ',0)
c
if(me.eq.0) print *, 'Writing Global Array to Disk Array'
if(dra_write(g_a, d_a,req).ne.0)
$ CALL ga_error('dra_write failed:',0)
if (me.eq.0) print*,' '
if(dra_wait(req).ne.0) call ga_error('dra_wait failed: ' ,req)
c
if(dra_close(d_a).ne.0)call ga_error('dra_close failed: ',d_a)
c
if(me.eq.0) print *, 'Checking dra_read'
if(dra_open(FNAME,DRA_R, d_a).ne.0)
& call ga_error('dra_open failed',0)
if(dra_read(g_b, d_a, req).ne.0)
$ CALL ga_error('dra_read failed:',0)
if(dra_wait(req).ne.0) call ga_error('dra_wait failed: ' ,req)
c
c error checking: (g_a - g_b)^2
c
c call ga_print(g_a)
c call ga_print(g_b)
call ga_add(1d0, g_a, -1d0, g_b, g_b)
err = ga_ddot(g_b, g_b)
if(err.ne.0) then
if (me.eq.0) print *,'error =', err
else
if (me.eq.0) print *,'OK'
endif
if (me.eq.0) print*,' '
c
if(me.eq.0) print *, 'Checking dra_read_section'
c
call ga_zero(g_b)
do j = 1, loop
dilo = iran(n)
dihi = iran(n)
djlo = iran(n)
djhi = iran(n)
c
if(dilo.gt.dihi) call swap(dilo,dihi)
if(djlo.gt.djhi) call swap(djlo,djhi)
ielem = dihi - dilo +1
jelem = djhi - djlo +1
c
gilo = iran(n-ielem)+1
gjlo = iran(n-jelem)+1
gihi = gilo+ielem-1
gjhi = gjlo+jelem-1
c
if(me.eq.0) then
write(6,100) gilo,gihi,gjlo,gjhi,dilo,dihi,djlo,djhi
100 format(1x,'reading global[',2(i4,':',i4),
& '] from disk[',2(i4,':',i4),']')
call ffflush(6)
endif
c
* call ga_print(g_b,1)
if(dra_read_section(.false., g_b, gilo, gihi, gjlo, gjhi,
& d_a, dilo, dihi, djlo, djhi, req).ne.0)
& call ga_error('dra_read failed:',0)
if(dra_wait(req).ne.0) call ga_error('dra_wait failed:',req)
* call ga_print(g_b,1)
* call ga_print_patch(g_a, dilo, dihi, djlo, djhi,1)
* call ga_print_patch(g_b, gilo, gihi, gjlo, gjhi,1)
c
call ga_add_patch(1d0, g_a, dilo, dihi, djlo, djhi,
& -1d0, g_b, gilo, gihi, gjlo, gjhi,
& g_b, gilo, gihi, gjlo, gjhi)
err = ga_ddot_patch(g_b,'n', gilo, gihi, gjlo, gjhi,
& g_b,'n', gilo, gihi, gjlo, gjhi)
if(err.ne.0 .and. me.eq.0)then
print *,'error =', err
call ga_error('failed',0)
endif
enddo
if (me.eq.0) print*,' OK'
if (me.eq.0) print*,' '
if(dra_delete(d_a).ne.0)
& call ga_error('dra_delete failed',0)
c
c*** now d_a is 4 times larger than g_a
c
if (me.eq.0) print*, 'Creating New Disk Array ',m,' x',m
if(dra_create(MT_DBL, m, m, 'A',
& FNAME,
& DRA_RW, n, 2, d_a).ne.0)
$ CALL ga_error('dra_create failed: ',0)
if (me.eq.0) print*,' OK'
if (me.eq.0) print*,' '
c
c
c call ga_print(g_a)
c call ga_zero(g_b)
if (me.eq.0) print*,'Testing dra_write_section'
do j = 1, loop
gilo = iran(n)
gihi = iran(n)
gjlo = iran(n)
gjhi = iran(n)
c
if(gilo.gt.gihi) call swap(gilo,gihi)
if(gjlo.gt.gjhi) call swap(gjlo,gjhi)
ielem = gihi - gilo +1
jelem = gjhi - gjlo +1
c
dilo = iran(m-ielem)+1
djlo = iran(m-jelem)+1
dihi = dilo+ielem-1
djhi = djlo+jelem-1
c
if(me.eq.0) then
write(6,200) gilo,gihi,gjlo,gjhi,dilo,dihi,djlo,djhi
200 format(1x,'writing global[',2(i4,':',i4),
& '] to disk[',2(i4,':',i4),']')
call ffflush(6)
endif
c
c call dra_set_mode(0)
if(dra_write_section(.false., g_a, gilo, gihi, gjlo, gjhi,
& d_a, dilo, dihi, djlo, djhi, req).ne.0)
& call ga_error('dra_write failed:',0)
if(dra_wait(req).ne.0) call ga_error('dra_wait failed:',req)
c
c*** dra_read was tested already and we use it for testing dra_write_section
c
c call dra_set_mode(1)
if(dra_read_section(.false., g_b, gilo, gihi, gjlo, gjhi,
& d_a, dilo, dihi, djlo, djhi, req).ne.0)
& call ga_error('dra_read failed:',0)
if(dra_wait(req).ne.0) call ga_error('dra_wait failed:',req)
c
call ga_add_patch(1d0, g_a, gilo, gihi, gjlo, gjhi,
& -1d0, g_b, gilo, gihi, gjlo, gjhi,
& g_b, gilo, gihi, gjlo, gjhi)
err = ga_ddot_patch(g_b,'n', gilo, gihi, gjlo, gjhi,
& g_b,'n', gilo, gihi, gjlo, gjhi)
if(err.ne.0d0 )then
call ga_print_patch(g_a, gilo, gihi,gjlo,gjhi,1)
call ga_print_patch(g_b, gilo, gihi,gjlo,gjhi,1)
endif
if(err.ne.0d0 .and. me.eq.0)then
print *,'error =', err
call ga_error('error in dra_write_section',0)
endif
enddo
if (me.eq.0) print*,' OK'
c
if(dra_delete(d_a).ne.0)
& call ga_error('dra_delete failed',0)
status = ga_destroy(g_a)
status = ga_destroy(g_b)
end
subroutine swap(a,b)
integer a, b, temp
temp = a
a = b
b = temp
end
subroutine init_char(str, len, char)
integer len, i
character*(*) str
character*1 char
do i = 1, len -1
str(i:i+1) = char
enddo
end
|
