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
|
!
! Copyright (C) by Argonne National Laboratory
! See COPYRIGHT in top-level directory
!
program main
implicit none
include 'mpif.h'
! Fortran equivalent of coll_test.c
integer FILESIZE
parameter (FILESIZE=32*32*32*4)
! A 32^3 array. For other array sizes, change FILESIZE above and
! array_of_gsizes below.
! Uses collective I/O. Writes a 3D block-distributed array to a file
! corresponding to the global array in row-major (C) order, reads it
! back, and checks that the data read is correct.
! Note that the file access pattern is noncontiguous.
integer newtype, i, ndims, array_of_gsizes(3)
integer order, intsize, nprocs, j, array_of_distribs(3)
integer array_of_dargs(3), array_of_psizes(3)
integer readbuf(FILESIZE), writebuf(FILESIZE), bufcount
integer mynod, tmpbuf(FILESIZE), array_size, argc, iargc
integer fh, status(MPI_STATUS_SIZE), request, ierr
character*1024 str ! used to store the filename
integer errs, toterrs
integer*8 disp
errs = 0
call MPI_INIT(ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD, mynod, ierr)
! process 0 takes the file name as a command-line argument and
! broadcasts it to other processes
if (mynod .eq. 0) then
argc = iargc()
i = 0
call getarg(i,str)
do while ((i .lt. argc) .and. (str .ne. '-fname'))
i = i + 1
call getarg(i,str)
end do
if (i .ge. argc) then
print *
print *, '*# Usage: fcoll_test -fname filename'
print *
call MPI_ABORT(MPI_COMM_WORLD, 1, ierr)
end if
i = i + 1
call getarg(i,str)
call MPI_BCAST(str, 1024, MPI_CHARACTER, 0, &
& MPI_COMM_WORLD, ierr)
else
call MPI_BCAST(str, 1024, MPI_CHARACTER, 0, &
& MPI_COMM_WORLD, ierr)
end if
! create the distributed array filetype
ndims = 3
order = MPI_ORDER_FORTRAN
array_of_gsizes(1) = 32
array_of_gsizes(2) = 32
array_of_gsizes(3) = 32
array_of_distribs(1) = MPI_DISTRIBUTE_BLOCK
array_of_distribs(2) = MPI_DISTRIBUTE_BLOCK
array_of_distribs(3) = MPI_DISTRIBUTE_BLOCK
array_of_dargs(1) = MPI_DISTRIBUTE_DFLT_DARG
array_of_dargs(2) = MPI_DISTRIBUTE_DFLT_DARG
array_of_dargs(3) = MPI_DISTRIBUTE_DFLT_DARG
do i=1, ndims
array_of_psizes(i) = 0
end do
call MPI_DIMS_CREATE(nprocs, ndims, array_of_psizes, ierr)
call MPI_TYPE_CREATE_DARRAY(nprocs, mynod, ndims, &
& array_of_gsizes, array_of_distribs, array_of_dargs, &
& array_of_psizes, order, MPI_INTEGER, newtype, ierr)
call MPI_TYPE_COMMIT(newtype, ierr)
! initialize writebuf
call MPI_TYPE_SIZE(newtype, bufcount, ierr)
call MPI_TYPE_SIZE(MPI_INTEGER, intsize, ierr)
bufcount = bufcount/intsize
do i=1, bufcount
writebuf(i) = 1
end do
do i=1, FILESIZE
tmpbuf(i) = 0
end do
call MPI_IRECV(tmpbuf, 1, newtype, mynod, 10, MPI_COMM_WORLD, &
& request, ierr)
call MPI_SEND(writebuf, bufcount, MPI_INTEGER, mynod, 10, &
& MPI_COMM_WORLD, ierr)
call MPI_WAIT(request, status, ierr)
j = 1
array_size = array_of_gsizes(1) * array_of_gsizes(2) * &
& array_of_gsizes(3)
do i=1, array_size
if (tmpbuf(i) .ne. 0) then
writebuf(j) = i
j = j + 1
end if
end do
! end of initialization
! write the array to the file
call MPI_FILE_OPEN(MPI_COMM_WORLD, str, &
& MPI_MODE_CREATE+MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr)
disp = 0
call MPI_FILE_SET_VIEW(fh, disp, MPI_INTEGER, newtype, "native", &
& MPI_INFO_NULL, ierr)
call MPI_FILE_WRITE_ALL(fh, writebuf, bufcount, MPI_INTEGER, &
& status, ierr)
call MPI_FILE_CLOSE(fh, ierr)
! now read it back
call MPI_FILE_OPEN(MPI_COMM_WORLD, str, &
& MPI_MODE_CREATE+MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr)
call MPI_FILE_SET_VIEW(fh, disp, MPI_INTEGER, newtype, "native", &
& MPI_INFO_NULL, ierr)
call MPI_FILE_READ_ALL(fh, readbuf, bufcount, MPI_INTEGER, &
& status, ierr)
call MPI_FILE_CLOSE(fh, ierr)
! check the data read
do i=1, bufcount
if (readbuf(i) .ne. writebuf(i)) then
errs = errs + 1
print *, 'Node ', mynod, ' readbuf ', readbuf(i), &
& ' writebuf ', writebuf(i), ' i', i
end if
end do
call MPI_TYPE_FREE(newtype, ierr)
call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, &
$ MPI_COMM_WORLD, ierr )
if (mynod .eq. 0) then
if( toterrs .gt. 0 ) then
print *, 'Found ', toterrs, ' errors'
else
print *, ' No Errors'
endif
endif
call MPI_FINALIZE(ierr)
end
|
