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
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
|
! @@LICENSE@@ see Copyright notice in the top-directory
#include "bud_utils.inc"
#include "bud_mpi.inc"
! We require the use of the communicator
use BUD_CC3(BUD_MOD,_,MP_Comm)
use BUD_CC3(BUD_MOD,_,Dist_common)
#define BUD_IO_OVERLOAD
! Before contains
#include "bud_collection.inc"
#undef BUD_IO_OVERLOAD
!> @param[inout] f `File` bud
!! @param[in] this the distributed sparse matrix @bud
subroutine write_(f, this)
use BUD_CC2(BUD_MOD,_File)
BUD_CLASS( BUD_CC2(BUD_TYPE,File) ), intent(inout) :: f
BUD_CLASS(BUD_TYPE_NAME), intent(in) :: this
type( BUD_CC2(BUD_TYPE,MP_Comm) ) :: comm
type(BUD_COLL_1) :: dist
type(BUD_COLL_2) :: sm
logical :: formatted, do_io
integer :: iu, io_rank
integer(BUD_PREC) :: nr, nc, nz
integer(BUD_PREC) :: gnr, gnc, gnl, gnz
integer(BUD_PREC) :: ir, il, ig, i, ic
integer(BUD_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: ptr(:), nrc(:), indx(:)
integer(BUD_PREC), allocatable :: data(:)
#ifdef BUD_MPI
integer :: status(MPI_STATUS_SIZE)
#endif
! If file is not opened, return immediately
if ( .not. is_initd(this) ) return
#ifndef BUD_MPI
sm = this
call write(f, sm)
call delete(sm)
return
#else
! Get contained data.
dist = this
comm = dist
if ( is_open(f) ) then
io_rank = comm_rank(comm)
else
io_rank = -1
end if
call AllReduce_Max(io_rank, iu, comm)
io_rank = iu
! Check if the file is open on one rank
if ( io_rank < 0 ) then
call delete(dist)
call delete(comm)
call delete(sm)
return
end if
! This ensures that only one rank will do the writing
! in case multiple ranks have the file open
! only @bud knows what will happen in this case!!!
do_io = io_rank == comm_rank(comm)
if ( do_io ) then
! First figure out if the file is an unformatted file
formatted = is_formatted(f)
iu = unit(f)
end if
! the size of the distribution
gnl = size_global(dist)
#ifdef BUD_SM_CSR
call attach(sm, nr=nr, nc=nc, nz=nz, &
rptr=ptr, nrow=nrc)
gnr = gnl
gnc = nc
#else
call attach(sm, nr=nr, nc=nc, nz=nz, &
cptr=ptr, ncol=nrc)
gnr = nr
gnc = gnl
#endif
! get total number of non-zero elements
call Reduce_Sum(nz, gnz, io_rank, comm)
if ( do_io ) then
! First we write the size of the array
if ( formatted ) then
write(iu, '(i16)') gnr, gnc, gnz
write(iu, '(l16)') sm%D%sorted
else
write(iu) gnr, gnc, gnz
write(iu) sm%D%sorted
end if
! Allocate space for the data
allocate(data(gnl))
end if
! Retrieve the nrc data
ig = 1
do while ( ig <= gnl )
! Get number of consecutive elements
ic = consecutive(dist, ig)
! Get hosting rank and local element
ir = global2rank(dist, ig)
il = global2local(dist, ig)
if ( ir == io_rank ) then
! Copy
do i = 1 , ic
data(ig-1+i) = nrc(il-1+i)
end do
else if ( do_io ) then
! recieve data
call Recv(data(ig:ig+ic-1), ir, ig, &
comm, status)
else
! send data
call SSend(nrc(il:il+ic-1), io_rank, ig, comm)
end if
ig = ig + ic
end do
if ( do_io ) then
! First we write the size of the array
if ( formatted ) then
write(iu, '(i16)') data
else
write(iu) data
end if
ig = maxval(data)
if ( ig > gnl ) then
deallocate(data)
allocate(data(ig))
end if
end if
! Write the column/row indices
do ig = 1 , gnl
! Get hosting rank and local element
ir = global2rank(dist, ig)
il = global2local(dist, ig)
if ( ir == io_rank ) then
#ifdef BUD_SM_CSR
indx => column_p(sm, il)
#endif
#ifdef BUD_SM_CSC
indx => row_p(sm, il)
#endif
! Simply write it
if ( formatted ) then
write(iu, '(i16)') indx(:)
else
write(iu) indx(:)
end if
else if ( do_io ) then
! recieve data
call Recv(data, ir, ig, comm, status)
call Get_Count(status, BUD_MPI_PREC, ic, comm)
if ( formatted ) then
write(iu, '(i16)') data(1:ic)
else
write(iu) data(1:ic)
end if
else
! send data
#ifdef BUD_SM_CSR
indx => column_p(sm, il)
#endif
#ifdef BUD_SM_CSC
indx => row_p(sm, il)
#endif
call SSend(indx, io_rank, ig, comm)
end if
end do
if ( allocated(data) ) deallocate(data)
call delete(dist)
call delete(comm)
call delete(sm)
#endif
end subroutine write_
!> @param[inout] f `File` bud
!! @param[in] this the distributed sparse matrix @bud
subroutine read_(f, dist, this)
use BUD_CC2(BUD_MOD,_File)
BUD_CLASS( BUD_CC2(BUD_TYPE,File) ), intent(inout) :: f
BUD_CLASS(BUD_COLL_1) :: dist
BUD_CLASS(BUD_TYPE_NAME), intent(inout) :: this
type( BUD_CC2(BUD_TYPE,MP_Comm) ) :: comm
type(BUD_COLL_2) :: sm
logical :: formatted, do_io, sorted
integer :: iu, io_rank, my_rank
integer(BUD_PREC) :: nr, nc, nz, nl
integer(BUD_PREC) :: gnr, gnc, gnz, gnl
integer(BUD_PREC) :: ir, il, ig
integer(BUD_PREC), pointer BUD_FORTRAN_CONTIGUOUS :: ptr(:), nrc(:), indx(:)
integer(BUD_PREC), allocatable :: data(:), idx(:)
#ifdef BUD_MPI
integer :: status(MPI_STATUS_SIZE)
#endif
! If file is not opened, return immediately
if ( .not. is_open(f) ) return
! How should we deal with the distribution when reading?
! Should we just create a random one and let the external use re-distribute
! the data? Yeah, probably
! Also, we need a communicator...
! So this one needs an additional argument.
comm = dist
#ifndef BUD_MPI
call read(f, sm)
call new(this, dist, sm)
call delete(sm)
return
#else
if ( is_open(f) ) then
io_rank = comm_rank(comm)
else
io_rank = -1
end if
call AllReduce_Max(io_rank, iu, comm)
io_rank = iu
! Check if the file is open on one rank
if ( io_rank < 0 ) then
call delete(dist)
call delete(comm)
call delete(sm)
return
end if
! This ensures that only one rank will do the writing
! in case multiple ranks have the file open
! only @bud knows what will happen in this case!!!
do_io = io_rank == comm_rank(comm)
if ( do_io ) then
! First figure out if the file is an unformatted file
formatted = is_formatted(f)
iu = unit(f)
end if
! First we need to read the array dimensions...
if ( do_io ) then
if ( formatted ) then
read(iu, '(i16)') gnr, gnc, gnz
read(iu, '(l16)') sorted
else
read(iu) gnr, gnc, gnz
read(iu) sorted
end if
end if
#ifdef SM_CSR
if ( size_global(dist) /= gnr ) then
call delete(this)
return
end if
nr = size_local(dist)
nc = gnc
nl = nr
gnl = gnr
#endif
#ifdef SM_CSC
if ( size_global(dist) /= gnc ) then
call delete(this)
return
end if
nr = gnr
nc = size_local(dist)
nl = nc
gnl = gnc
#endif
! Allocate the container for the local data
allocate(data(gnl))
if ( do_io ) then
if ( formatted ) then
read(iu, '(i16)') data
else
read(iu) data
end if
end if
! Now distribute data so every processor knows the size
call Bcast(data, io_rank, comm)
! Retrieve my rank ID
my_rank = comm_rank(comm)
! All ranks should now figure out how many elements
nz = 0
do ig = 1 , gnl
ir = global2rank(dist, ig)
if ( ir == my_rank ) then
nz = nz + data(ig)
end if
end do
! Create the SM
call new(sm, nr, nc, nz)
! Create the new object
call new(this, dist, sm)
! Retrieve pointers and populate
#ifdef BUD_SM_CSR
call attach(sm, rptr=ptr, nrow=nrc)
#else
call attach(sm, cptr=ptr, ncol=nrc)
#endif
! distribute number of elements per row/column
do ig = 1 , gnl
ir = global2rank(dist, ig)
if ( ir == my_rank ) then
il = global2local(dist, ig)
nrc(il) = data(ig)
end if
end do
! Update pointer
do il = 2 , nl
ptr(il) = ptr(il-1) + nrc(il-1)
end do
ptr(nl+1) = ptr(nl) + nrc(nl)
! Read the sparse data
ig = maxval(data)
allocate(idx(ig))
! Read the sparse matrix
do ig = 1 , gnl
! get global rank
ir = global2rank(dist, ig)
if ( ir == my_rank ) then
il = global2local(dist, ig)
#ifdef BUD_SM_CSR
indx => column_p(sm, il)
#endif
#ifdef BUD_SM_CSC
indx => row_p(sm, il)
#endif
end if
if ( do_io ) then
if ( ir == my_rank ) then
if ( formatted ) then
read(iu, '(i16)') indx
else
read(iu) indx
end if
else
if ( formatted ) then
read(iu, '(i16)') idx(1:data(ig))
else
read(iu) idx(1:data(ig))
end if
! Send the data
call SSend(idx(:data(ig)), ir, ig, comm)
end if
else if ( ir == my_rank ) then
! Recieve data from io-node
call Recv(indx(:data(ig)), io_rank, ig, comm, status)
end if
end do
if ( sorted ) then
call sort(sm)
end if
! done, clean-up
call delete(sm)
deallocate(data, idx)
#endif
end subroutine read_
! after contains
#include "bud_cleanup.inc"
! project-buds -- local file settings
! Anything below this line may be overwritten by scripts
! Below are non-editable settings
! Local Variables:
! mode: f90
! f90-if-indent: 2
! f90-type-indent: 2
! f90-associate-indent: 2
! f90-continuation-indent: 2
! f90-structure-indent: 2
! f90-critical-indent: 2
! f90-program-indent: 2
! f90-do-indent: 2
! End:
|