1 /*
2 * Copyright (C) by Argonne National Laboratory
3 * See COPYRIGHT in top-level directory
4 */
5
6 /* Note: This code originally appeared in ROMIO. */
7
8 #include "mpiimpl.h"
9 #include "typerep_internal.h"
10
11 static int type_block(const int *array_of_gsizes, int dim, int ndims,
12 int nprocs, int rank, int darg, int order, MPI_Aint orig_extent,
13 MPI_Datatype type_old, MPI_Datatype * type_new, MPI_Aint * st_offset);
14 static int type_cyclic(const int *array_of_gsizes, int dim, int ndims, int nprocs,
15 int rank, int darg, int order, MPI_Aint orig_extent,
16 MPI_Datatype type_old, MPI_Datatype * type_new, MPI_Aint * st_offset);
17
MPII_Typerep_convert_darray(int size,int rank,int ndims,const int * array_of_gsizes,const int * array_of_distribs,const int * array_of_dargs,const int * array_of_psizes,int order,MPI_Datatype oldtype,MPI_Datatype * newtype)18 int MPII_Typerep_convert_darray(int size, int rank, int ndims, const int *array_of_gsizes,
19 const int *array_of_distribs, const int *array_of_dargs,
20 const int *array_of_psizes, int order, MPI_Datatype oldtype,
21 MPI_Datatype * newtype)
22 {
23 int mpi_errno = MPI_SUCCESS;
24 MPI_Datatype type_old, type_new = MPI_DATATYPE_NULL, types[3];
25 int procs, tmp_rank, i, tmp_size, blklens[3], *coords;
26 MPI_Aint *st_offsets, orig_extent, disps[3];
27
28 MPIR_Datatype_get_extent_macro(oldtype, orig_extent);
29
30 /* calculate position in Cartesian grid as MPI would (row-major
31 ordering) */
32 coords = (int *) MPL_malloc(ndims * sizeof(int), MPL_MEM_DATATYPE);
33 MPIR_ERR_CHKANDJUMP(!coords, mpi_errno, MPI_ERR_OTHER, "**nomem");
34
35 procs = size;
36 tmp_rank = rank;
37 for (i = 0; i < ndims; i++) {
38 procs = procs / array_of_psizes[i];
39 coords[i] = tmp_rank / procs;
40 tmp_rank = tmp_rank % procs;
41 }
42
43 st_offsets = (MPI_Aint *) MPL_malloc(ndims * sizeof(MPI_Aint), MPL_MEM_DATATYPE);
44 MPIR_ERR_CHKANDJUMP(!st_offsets, mpi_errno, MPI_ERR_OTHER, "**nomem");
45 type_old = oldtype;
46
47 if (order == MPI_ORDER_FORTRAN) {
48 /* dimension 0 changes fastest */
49 for (i = 0; i < ndims; i++) {
50 switch (array_of_distribs[i]) {
51 case MPI_DISTRIBUTE_BLOCK:
52 mpi_errno = type_block(array_of_gsizes, i, ndims,
53 array_of_psizes[i],
54 coords[i], array_of_dargs[i],
55 order, orig_extent, type_old, &type_new, st_offsets + i);
56 MPIR_ERR_CHECK(mpi_errno);
57 break;
58 case MPI_DISTRIBUTE_CYCLIC:
59 mpi_errno = type_cyclic(array_of_gsizes, i, ndims,
60 array_of_psizes[i], coords[i],
61 array_of_dargs[i], order,
62 orig_extent, type_old, &type_new, st_offsets + i);
63 MPIR_ERR_CHECK(mpi_errno);
64 break;
65 case MPI_DISTRIBUTE_NONE:
66 /* treat it as a block distribution on 1 process */
67 mpi_errno = type_block(array_of_gsizes, i, ndims, 1, 0,
68 MPI_DISTRIBUTE_DFLT_DARG, order,
69 orig_extent, type_old, &type_new, st_offsets + i);
70 MPIR_ERR_CHECK(mpi_errno);
71 break;
72 }
73 if (i)
74 MPIR_Type_free_impl(&type_old);
75 type_old = type_new;
76 }
77
78 /* add displacement and UB */
79 disps[1] = st_offsets[0];
80 tmp_size = 1;
81 for (i = 1; i < ndims; i++) {
82 tmp_size *= array_of_gsizes[i - 1];
83 disps[1] += ((MPI_Aint) tmp_size) * st_offsets[i];
84 }
85 /* rest done below for both Fortran and C order */
86 } else { /* order == MPI_ORDER_C */
87 /* dimension ndims-1 changes fastest */
88 for (i = ndims - 1; i >= 0; i--) {
89 switch (array_of_distribs[i]) {
90 case MPI_DISTRIBUTE_BLOCK:
91 mpi_errno = type_block(array_of_gsizes, i, ndims, array_of_psizes[i],
92 coords[i], array_of_dargs[i], order,
93 orig_extent, type_old, &type_new, st_offsets + i);
94 MPIR_ERR_CHECK(mpi_errno);
95 break;
96 case MPI_DISTRIBUTE_CYCLIC:
97 mpi_errno = type_cyclic(array_of_gsizes, i, ndims,
98 array_of_psizes[i], coords[i],
99 array_of_dargs[i], order,
100 orig_extent, type_old, &type_new, st_offsets + i);
101 MPIR_ERR_CHECK(mpi_errno);
102 break;
103 case MPI_DISTRIBUTE_NONE:
104 /* treat it as a block distribution on 1 process */
105 mpi_errno = type_block(array_of_gsizes, i, ndims, array_of_psizes[i],
106 coords[i], MPI_DISTRIBUTE_DFLT_DARG, order,
107 orig_extent, type_old, &type_new, st_offsets + i);
108 MPIR_ERR_CHECK(mpi_errno);
109 break;
110 }
111 if (i != ndims - 1)
112 MPIR_Type_free_impl(&type_old);
113 type_old = type_new;
114 }
115
116 /* add displacement and UB */
117 disps[1] = st_offsets[ndims - 1];
118 tmp_size = 1;
119 for (i = ndims - 2; i >= 0; i--) {
120 tmp_size *= array_of_gsizes[i + 1];
121 disps[1] += ((MPI_Aint) tmp_size) * st_offsets[i];
122 }
123 }
124
125 disps[1] *= orig_extent;
126
127 disps[2] = orig_extent;
128 for (i = 0; i < ndims; i++)
129 disps[2] *= (MPI_Aint) (array_of_gsizes[i]);
130
131 disps[0] = 0;
132 blklens[0] = blklens[1] = blklens[2] = 1;
133 types[0] = MPI_LB;
134 types[1] = type_new;
135 types[2] = MPI_UB;
136
137 MPL_free(st_offsets);
138 MPL_free(coords);
139
140 mpi_errno = MPIR_Type_struct_impl(3, blklens, disps, types, newtype);
141 MPIR_ERR_CHECK(mpi_errno);
142
143 MPIR_Type_free_impl(&type_new);
144
145
146 fn_exit:
147 return mpi_errno;
148 fn_fail:
149 goto fn_exit;
150 }
151
152
153 /* Returns MPI_SUCCESS on success, an MPI error code on failure. Code above
154 * needs to call MPIO_Err_return_xxx.
155 */
type_block(const int * array_of_gsizes,int dim,int ndims,int nprocs,int rank,int darg,int order,MPI_Aint orig_extent,MPI_Datatype type_old,MPI_Datatype * type_new,MPI_Aint * st_offset)156 static int type_block(const int *array_of_gsizes, int dim, int ndims, int nprocs,
157 int rank, int darg, int order, MPI_Aint orig_extent,
158 MPI_Datatype type_old, MPI_Datatype * type_new, MPI_Aint * st_offset)
159 {
160 /* nprocs = no. of processes in dimension dim of grid
161 rank = coordinate of this process in dimension dim */
162 int mpi_errno = MPI_SUCCESS;
163 int blksize, global_size, mysize, i, j;
164 MPI_Aint stride;
165
166 global_size = array_of_gsizes[dim];
167
168 if (darg == MPI_DISTRIBUTE_DFLT_DARG)
169 blksize = (global_size + nprocs - 1) / nprocs;
170 else {
171 blksize = darg;
172
173 MPIR_ERR_CHKINTERNAL(blksize <= 0, mpi_errno, "blksize must be > 0");
174 MPIR_ERR_CHKINTERNAL(blksize * nprocs < global_size, mpi_errno,
175 "blksize * nprocs must be >= global size");
176 }
177
178 j = global_size - blksize * rank;
179 mysize = (blksize < j) ? blksize : j;
180 if (mysize < 0)
181 mysize = 0;
182
183 stride = orig_extent;
184 if (order == MPI_ORDER_FORTRAN) {
185 if (dim == 0) {
186 mpi_errno = MPIR_Type_contiguous_impl(mysize, type_old, type_new);
187 MPIR_ERR_CHECK(mpi_errno);
188 } else {
189 for (i = 0; i < dim; i++)
190 stride *= (MPI_Aint) (array_of_gsizes[i]);
191 mpi_errno = MPIR_Type_hvector_impl(mysize, 1, stride, type_old, type_new);
192 MPIR_ERR_CHECK(mpi_errno);
193 }
194 } else {
195 if (dim == ndims - 1) {
196 mpi_errno = MPIR_Type_contiguous_impl(mysize, type_old, type_new);
197 MPIR_ERR_CHECK(mpi_errno);
198 } else {
199 for (i = ndims - 1; i > dim; i--)
200 stride *= (MPI_Aint) (array_of_gsizes[i]);
201 mpi_errno = MPIR_Type_hvector_impl(mysize, 1, stride, type_old, type_new);
202 MPIR_ERR_CHECK(mpi_errno);
203 }
204 }
205
206 *st_offset = blksize * rank;
207 /* in terms of no. of elements of type oldtype in this dimension */
208 if (mysize == 0)
209 *st_offset = 0;
210
211 fn_exit:
212 return mpi_errno;
213 fn_fail:
214 goto fn_exit;
215 }
216
217
218 /* Returns MPI_SUCCESS on success, an MPI error code on failure. Code above
219 * needs to call MPIO_Err_return_xxx.
220 */
type_cyclic(const int * array_of_gsizes,int dim,int ndims,int nprocs,int rank,int darg,int order,MPI_Aint orig_extent,MPI_Datatype type_old,MPI_Datatype * type_new,MPI_Aint * st_offset)221 static int type_cyclic(const int *array_of_gsizes, int dim, int ndims, int nprocs,
222 int rank, int darg, int order, MPI_Aint orig_extent,
223 MPI_Datatype type_old, MPI_Datatype * type_new, MPI_Aint * st_offset)
224 {
225 /* nprocs = no. of processes in dimension dim of grid
226 rank = coordinate of this process in dimension dim */
227 int mpi_errno = MPI_SUCCESS;
228 int blksize, i, blklens[3], st_index, end_index, local_size, rem, count;
229 MPI_Aint stride, disps[3];
230 MPI_Datatype type_tmp, types[3];
231
232 if (darg == MPI_DISTRIBUTE_DFLT_DARG)
233 blksize = 1;
234 else
235 blksize = darg;
236
237 MPIR_ERR_CHKINTERNAL(blksize <= 0, mpi_errno, "blksize must be > 0");
238
239 st_index = rank * blksize;
240 end_index = array_of_gsizes[dim] - 1;
241
242 if (end_index < st_index)
243 local_size = 0;
244 else {
245 local_size = ((end_index - st_index + 1) / (nprocs * blksize)) * blksize;
246 rem = (end_index - st_index + 1) % (nprocs * blksize);
247 local_size += (rem < blksize) ? rem : blksize;
248 }
249
250 count = local_size / blksize;
251 rem = local_size % blksize;
252
253 stride = ((MPI_Aint) nprocs) * ((MPI_Aint) blksize) * orig_extent;
254 if (order == MPI_ORDER_FORTRAN)
255 for (i = 0; i < dim; i++)
256 stride *= (MPI_Aint) (array_of_gsizes[i]);
257 else
258 for (i = ndims - 1; i > dim; i--)
259 stride *= (MPI_Aint) (array_of_gsizes[i]);
260
261 mpi_errno = MPIR_Type_hvector_impl(count, blksize, stride, type_old, type_new);
262 MPIR_ERR_CHECK(mpi_errno);
263
264 if (rem) {
265 /* if the last block is of size less than blksize, include
266 * it separately using MPI_Type_struct */
267
268 types[0] = *type_new;
269 types[1] = type_old;
270 disps[0] = 0;
271 disps[1] = ((MPI_Aint) count) * stride;
272 blklens[0] = 1;
273 blklens[1] = rem;
274
275 mpi_errno = MPIR_Type_struct_impl(2, blklens, disps, types, &type_tmp);
276 MPIR_ERR_CHECK(mpi_errno);
277
278 MPIR_Type_free_impl(type_new);
279 *type_new = type_tmp;
280 }
281
282 /* In the first iteration, we need to set the displacement in that
283 * dimension correctly. */
284 if (((order == MPI_ORDER_FORTRAN) && (dim == 0)) ||
285 ((order == MPI_ORDER_C) && (dim == ndims - 1))) {
286 types[0] = MPI_LB;
287 disps[0] = 0;
288 types[1] = *type_new;
289 disps[1] = ((MPI_Aint) rank) * ((MPI_Aint) blksize) * orig_extent;
290 types[2] = MPI_UB;
291 disps[2] = orig_extent * ((MPI_Aint) (array_of_gsizes[dim]));
292 blklens[0] = blklens[1] = blklens[2] = 1;
293
294 mpi_errno = MPIR_Type_struct_impl(3, blklens, disps, types, &type_tmp);
295 MPIR_ERR_CHECK(mpi_errno);
296
297 MPIR_Type_free_impl(type_new);
298 *type_new = type_tmp;
299
300 *st_offset = 0; /* set it to 0 because it is taken care of in
301 * the struct above */
302 } else {
303 *st_offset = ((MPI_Aint) rank) * ((MPI_Aint) blksize);
304 /* st_offset is in terms of no. of elements of type oldtype in
305 * this dimension */
306 }
307
308 if (local_size == 0)
309 *st_offset = 0;
310
311 fn_exit:
312 return mpi_errno;
313 fn_fail:
314 goto fn_exit;
315 }
316