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
|
!
! Copyright (C) by Argonne National Laboratory
! See COPYRIGHT in top-level directory
!
program main
implicit none
include 'mpif.h'
! This is the same as fcoll_test.f, but uses the PMPI versions
! of all functions in order to test the profiling interface.
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 PMPI_INIT(ierr)
call PMPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)
call PMPI_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 PMPI_ABORT(MPI_COMM_WORLD, 1, ierr)
end if
i = i + 1
call getarg(i,str)
call PMPI_BCAST(str, 1024, MPI_CHARACTER, 0, &
& MPI_COMM_WORLD, ierr)
else
call PMPI_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 PMPI_DIMS_CREATE(nprocs, ndims, array_of_psizes, ierr)
call PMPI_TYPE_CREATE_DARRAY(nprocs, mynod, ndims, &
& array_of_gsizes, array_of_distribs, array_of_dargs, &
& array_of_psizes, order, MPI_INTEGER, newtype, ierr)
call PMPI_TYPE_COMMIT(newtype, ierr)
! initialize writebuf
call PMPI_TYPE_SIZE(newtype, bufcount, ierr)
call PMPI_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 PMPI_IRECV(tmpbuf, 1, newtype, mynod, 10, MPI_COMM_WORLD, &
& request, ierr)
call PMPI_SEND(writebuf, bufcount, MPI_INTEGER, mynod, 10, &
& MPI_COMM_WORLD, ierr)
call PMPI_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 PMPI_FILE_OPEN(MPI_COMM_WORLD, str, &
& MPI_MODE_CREATE+MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr)
disp = 0
call PMPI_FILE_SET_VIEW(fh, disp, MPI_INTEGER, newtype, "native", &
& MPI_INFO_NULL, ierr)
call PMPI_FILE_WRITE_ALL(fh, writebuf, bufcount, MPI_INTEGER, &
& status, ierr)
call PMPI_FILE_CLOSE(fh, ierr)
! now read it back
call PMPI_FILE_OPEN(MPI_COMM_WORLD, str, &
& MPI_MODE_CREATE+MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr)
call PMPI_FILE_SET_VIEW(fh, disp, MPI_INTEGER, newtype, "native", &
& MPI_INFO_NULL, ierr)
call PMPI_FILE_READ_ALL(fh, readbuf, bufcount, MPI_INTEGER, &
& status, ierr)
call PMPI_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 PMPI_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 PMPI_FINALIZE(ierr)
end
|
