void MPIR_MINLOC(
void *invec,
void *inoutvec,
int *Len,
MPI_Datatype *type )
{
int i, len = *Len;
struct MPIR_DATATYPE *dtype = MPIR_GET_DTYPE_PTR(*type);
if ((dtype)->dte_type == MPIR_STRUCT) {
/* Perform the operation based on the type of the first type in */
/* struct */
switch ((dtype)->old_types[0]->dte_type) {
case MPIR_INT: {
MPIR_2int_loctype *a = (MPIR_2int_loctype *)inoutvec;
MPIR_2int_loctype *b = (MPIR_2int_loctype *)invec;
for (i=0; i<len; i++) {
if (a[i].value == b[i].value)
a[i].loc = MPIR_MIN(a[i].loc,b[i].loc);
else if (a[i].value > b[i].value) {
a[i].value = b[i].value;
a[i].loc = b[i].loc;
}
}
break;
}
case MPIR_FLOAT: {
MPIR_floatint_loctype *a = (MPIR_floatint_loctype *)inoutvec;
MPIR_floatint_loctype *b = (MPIR_floatint_loctype *)invec;
for (i=0; i<len; i++) {
if (a[i].value == b[i].value)
a[i].loc = MPIR_MIN(a[i].loc,b[i].loc);
else if (a[i].value > b[i].value) {
a[i].value = b[i].value;
a[i].loc = b[i].loc;
}
}
break;
}
case MPIR_LONG: {
MPIR_longint_loctype *a = (MPIR_longint_loctype *)inoutvec;
MPIR_longint_loctype *b = (MPIR_longint_loctype *)invec;
for (i=0; i<len; i++) {
if (a[i].value == b[i].value)
a[i].loc = MPIR_MIN(a[i].loc,b[i].loc);
else if (a[i].value > b[i].value) {
a[i].value = b[i].value;
a[i].loc = b[i].loc;
}
}
break;
}
#if defined(HAVE_LONG_LONG_INT)
case MPIR_LONGLONGINT: {
MPIR_longlongint_loctype *a = (MPIR_longlongint_loctype *)inoutvec;
MPIR_longlongint_loctype *b = (MPIR_longlongint_loctype *)invec;
for (i=0; i<len; i++) {
if (a[i].value == b[i].value)
a[i].loc = MPIR_MIN(a[i].loc,b[i].loc);
else if (a[i].value > b[i].value) {
a[i].value = b[i].value;
a[i].loc = b[i].loc;
}
}
break;
}
#endif
case MPIR_SHORT: {
MPIR_shortint_loctype *a = (MPIR_shortint_loctype *)inoutvec;
MPIR_shortint_loctype *b = (MPIR_shortint_loctype *)invec;
for (i=0; i<len; i++) {
if (a[i].value == b[i].value)
a[i].loc = MPIR_MIN(a[i].loc,b[i].loc);
else if (a[i].value > b[i].value) {
a[i].value = b[i].value;
a[i].loc = b[i].loc;
}
}
break;
}
case MPIR_DOUBLE: {
MPIR_doubleint_loctype *a = (MPIR_doubleint_loctype *)inoutvec;
MPIR_doubleint_loctype *b = (MPIR_doubleint_loctype *)invec;
for (i=0; i<len; i++) {
if (a[i].value == b[i].value)
a[i].loc = MPIR_MIN(a[i].loc,b[i].loc);
else if (a[i].value > b[i].value) {
a[i].value = b[i].value;
a[i].loc = b[i].loc;
}
}
break;
}
#if defined(HAVE_LONG_DOUBLE)
case MPIR_LONGDOUBLE: {
MPIR_longdoubleint_loctype *a = (MPIR_longdoubleint_loctype *)inoutvec;
MPIR_longdoubleint_loctype *b = (MPIR_longdoubleint_loctype *)invec;
for (i=0; i<len; i++) {
if (a[i].value == b[i].value)
a[i].loc = MPIR_MIN(a[i].loc,b[i].loc);
else if (a[i].value > b[i].value) {
a[i].value = b[i].value;
a[i].loc = b[i].loc;
}
}
break;
}
#endif
default:
MPIR_Op_errno = MPIR_ERR_OP_NOT_DEFINED;
MPIR_ERROR(MPIR_COMM_WORLD, MPIR_ERR_OP_NOT_DEFINED, "MPI_MINLOC" );
}
}
else if ((dtype)->dte_type == MPIR_CONTIG && ((dtype)->count == 2)) {
struct MPIR_DATATYPE *oldtype = (dtype)->old_type;
/* Set the actual length */
len = len * (dtype)->count;
/* Perform the operation */
switch (oldtype->dte_type) {
case MPIR_INT: {
int *a = (int *)inoutvec; int *b = (int *)invec;
for ( i=0; i<len; i+=2 ) {
if (a[i] == b[i])
a[i+1] = MPIR_MIN(a[i+1],b[i+1]);
else if (a[i] > b[i]) {
a[i] = b[i];
a[i+1] = b[i+1];
}
}
break;
}
case MPIR_LONG: {
long *a = (long *)inoutvec; long *b = (long *)invec;
for ( i=0; i<len; i+=2 ) {
if (a[i] == b[i])
a[i+1] = MPIR_MIN(a[i+1],b[i+1]);
else if (a[i] > b[i]) {
a[i] = b[i];
a[i+1] = b[i+1];
}
}
break;
}
#if defined(HAVE_LONG_LONG_INT)
case MPIR_LONGLONGINT: {
long long *a = (long long *)inoutvec; long long *b = (long long *)invec;
for ( i=0; i<len; i+=2 ) {
if (a[i] == b[i])
a[i+1] = MPIR_MIN(a[i+1],b[i+1]);
else if (a[i] > b[i]) {
a[i] = b[i];
a[i+1] = b[i+1];
}
}
break;
}
#endif
case MPIR_SHORT: {
short *a = (short *)inoutvec; short *b = (short *)invec;
for ( i=0; i<len; i+=2 ) {
if (a[i] == b[i])
a[i+1] = MPIR_MIN(a[i+1],b[i+1]);
else if (a[i] > b[i]) {
a[i] = b[i];
a[i+1] = b[i+1];
}
}
break;
}
case MPIR_CHAR: {
char *a = (char *)inoutvec; char *b = (char *)invec;
for ( i=0; i<len; i+=2 ) {
if (a[i] == b[i])
a[i+1] = MPIR_MIN(a[i+1],b[i+1]);
else if (a[i] > b[i]) {
a[i] = b[i];
a[i+1] = b[i+1];
}
}
break;
}
case MPIR_FLOAT: {
float *a = (float *)inoutvec; float *b = (float *)invec;
for ( i=0; i<len; i+=2 ) {
if (a[i] == b[i])
a[i+1] = MPIR_MIN(a[i+1],b[i+1]);
else if (a[i] > b[i]) {
a[i] = b[i];
a[i+1] = b[i+1];
}
}
break;
}
case MPIR_DOUBLE: {
double *a = (double *)inoutvec; double *b = (double *)invec;
for ( i=0; i<len; i+=2 ) {
if (a[i] == b[i])
a[i+1] = MPIR_MIN(a[i+1],b[i+1]);
else if (a[i] > b[i]) {
a[i] = b[i];
a[i+1] = b[i+1];
}
}
break;
}
#ifdef HAVE_LONG_DOUBLE
case MPIR_LONGDOUBLE: {
long double *a = (long double *)inoutvec;
long double *b = (long double *)invec;
for ( i=0; i<len; i+=2 ) {
if (a[i] == b[i])
a[i+1] = MPIR_MIN(a[i+1],b[i+1]);
else if (a[i] > b[i]) {
a[i] = b[i];
a[i+1] = b[i+1];
}
}
break;
}
#endif
default:
MPIR_Op_errno = MPIR_ERR_OP_NOT_DEFINED;
MPIR_ERROR(MPIR_COMM_WORLD, MPIR_ERR_OP_NOT_DEFINED, "MPI_MINLOC" );
break;
}
}
else {
MPIR_Op_errno = MPIR_ERR_OP_NOT_DEFINED;
MPIR_ERROR(MPIR_COMM_WORLD, MPIR_ERR_OP_NOT_DEFINED, "MPI_MINLOC" );
}
}
void MPIR_SUM (
void *invec,
void *inoutvec,
int *Len,
MPI_Datatype *type )
{
int i, len = *Len;
struct MPIR_DATATYPE *dtype = MPIR_GET_DTYPE_PTR(*type);
switch ((dtype)->dte_type) {
case MPIR_INT: {
int *a = (int *)inoutvec; int *b = (int *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
case MPIR_UINT: {
unsigned *a = (unsigned *)inoutvec; unsigned *b = (unsigned *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
case MPIR_LONG: {
long *a = (long *)inoutvec; long *b = (long *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
#if defined(HAVE_LONG_LONG_INT)
case MPIR_LONGLONGINT: {
long long *a = (long long *)inoutvec; long long *b = (long long *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
#endif
case MPIR_ULONG: {
unsigned long *a = (unsigned long *)inoutvec;
unsigned long *b = (unsigned long *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
case MPIR_SHORT: {
short *a = (short *)inoutvec; short *b = (short *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
case MPIR_USHORT: {
unsigned short *a = (unsigned short *)inoutvec;
unsigned short *b = (unsigned short *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
case MPIR_CHAR: {
char *a = (char *)inoutvec; char *b = (char *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
case MPIR_BYTE:
case MPIR_UCHAR: {
unsigned char *a = (unsigned char *)inoutvec;
unsigned char *b = (unsigned char *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
case MPIR_FLOAT: {
float *a = (float *)inoutvec; float *b = (float *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
case MPIR_DOUBLE: {
double *a = (double *)inoutvec; double *b = (double *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
#if defined(HAVE_LONG_DOUBLE)
case MPIR_LONGDOUBLE: {
long double *a = (long double *)inoutvec;
long double *b = (long double *)invec;
for ( i=0; i<len; i++ )
a[i] = MPIR_LSUM(a[i],b[i]);
break;
}
#endif
case MPIR_COMPLEX: {
s_complex *a = (s_complex *)inoutvec; s_complex *b = (s_complex *)invec;
for ( i=0; i<len; i++ ) {
a[i].re = MPIR_LSUM(a[i].re ,b[i].re);
a[i].im = MPIR_LSUM(a[i].im ,b[i].im);
}
break;
}
case MPIR_DOUBLE_COMPLEX: {
d_complex *a = (d_complex *)inoutvec; d_complex *b = (d_complex *)invec;
for ( i=0; i<len; i++ ) {
a[i].re = MPIR_LSUM(a[i].re ,b[i].re);
a[i].im = MPIR_LSUM(a[i].im ,b[i].im);
}
break;
}
default:
MPIR_Op_errno = MPIR_ERR_OP_NOT_DEFINED;
MPIR_ERROR(MPIR_COMM_WORLD,MPIR_ERR_OP_NOT_DEFINED, "MPI_SUM" );
break;
}
}
/*@
MPI_Get_elements - Returns the number of basic elements
in a datatype
Input Parameters:
+ status - return status of receive operation (Status)
- datatype - datatype used by receive operation (handle)
Output Parameter:
. count - number of received basic elements (integer)
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
@*/
EXPORT_MPI_API int MPI_Get_elements ( MPI_Status *status, MPI_Datatype datatype,
int *elements )
{
int count;
int mpi_errno = MPI_SUCCESS;
struct MPIR_DATATYPE *dtype_ptr;
static char myname[] = "MPI_GET_ELEMENTS";
dtype_ptr = MPIR_GET_DTYPE_PTR(datatype);
MPIR_TEST_DTYPE(datatype,dtype_ptr,MPIR_COMM_WORLD,myname);
/*********** Check to see if datatype is committed ********
*********** Debbie Swider - 11/17/97 *********************/
if (!dtype_ptr->committed) {
return MPIR_ERROR( MPIR_COMM_WORLD,
MPIR_ERRCLASS_TO_CODE(MPI_ERR_TYPE,MPIR_ERR_UNCOMMITTED), myname );
}
#ifdef MPID_HAS_GET_ELEMENTS
mpi_errno = MPID_Get_elements( status, datatype, elements );
#else
/* Find the number of elements */
MPI_Get_count (status, datatype, &count);
if (count == MPI_UNDEFINED) {
/* To do this correctly, we need to run through the datatype,
processing basic types until we run out of data.
We can do this in part by computing how many full versions
of datatype will fit, and make use of the datatype->elements
field. If there isn't an EXACT fit, we need to look into
the datatype for more details about the exact mapping to
elements. We do this with MPIR_Unpack2.
*/
#ifdef FOO
*elements = count;
/* HACK ALERT -- the code in this if is not correct */
/* but for now ... */
double cnt =
(double) status->count / (double) dtype_ptr->size;
(*elements) = (int) ( cnt * (double) dtype_ptr->elements );
#endif
{
int srclen, destlen, used_len;
int i_dummy;
srclen = status->count;
/* Need to set count so that we'll exit when we run out of
items. It could be ceil(status->count/dtype_ptr->size) .
Alternately, we could check that used_len >= srclen - epsilon
(in case there isn't enough for the last item).
Why isn't this correct?
*/
if (dtype_ptr->size > 0)
count = 1 + (srclen / dtype_ptr->size);
else {
*elements = srclen ? MPI_UNDEFINED : 0;
return MPI_SUCCESS;
}
*elements = 0;
used_len = 0;
MPIR_Unpack2( (char *)&i_dummy, count, dtype_ptr,
MPIR_Elementcnt, (void *)elements, (char *)&i_dummy,
srclen, &destlen, &used_len );
/* If anything is left, return undefined */
if (used_len != srclen)
*elements = MPI_UNDEFINED;
}
}
else
(*elements) = count * dtype_ptr->elements;
#endif
MPIR_RETURN( MPIR_COMM_WORLD, mpi_errno, myname );
}
/*@
MPI_Group_union - Produces a group by combining two groups
Input Parameters:
+ group1 - first group (handle)
- group2 - second group (handle)
Output Parameter:
. newgroup - union group (handle)
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_GROUP
.N MPI_ERR_EXHAUSTED
.seealso: MPI_Group_free
@*/
EXPORT_MPI_API int MPI_Group_union ( MPI_Group group1, MPI_Group group2,
MPI_Group *group_out )
{
int i, j, global_rank;
struct MPIR_GROUP *group1_ptr, *group2_ptr, *new_group_ptr;
int n;
int mpi_errno = MPI_SUCCESS;
static char myname[] = "MPI_GROUP_UNION";
TR_PUSH(myname);
group1_ptr = MPIR_GET_GROUP_PTR(group1);
group2_ptr = MPIR_GET_GROUP_PTR(group2);
/* MPIR_TEST_MPI_GROUP(group1,group1_ptr,MPIR_COMM_WORLD,myname);
MPIR_TEST_MPI_GROUP(grou2p,group2_ptr,MPIR_COMM_WORLD,myname); */
#ifndef MPIR_NO_ERROR_CHECKING
MPIR_TEST_GROUP(group1_ptr);
MPIR_TEST_GROUP(group2_ptr);
if (mpi_errno)
return MPIR_ERROR(MPIR_COMM_WORLD, mpi_errno, myname );
#endif
/* Check for EMPTY groups */
if ( (group1 == MPI_GROUP_EMPTY) && (group2 == MPI_GROUP_EMPTY) ) {
MPIR_Group_dup ( MPIR_GROUP_EMPTY, &new_group_ptr );
TR_POP;
*group_out = new_group_ptr->self;
return (mpi_errno);
}
if ( group1 == MPI_GROUP_EMPTY ) {
MPIR_Group_dup ( group2_ptr, &new_group_ptr );
*group_out = new_group_ptr->self;
TR_POP;
return (mpi_errno);
}
if ( group2 == MPI_GROUP_EMPTY ) {
MPIR_Group_dup ( group1_ptr, &new_group_ptr );
*group_out = new_group_ptr->self;
TR_POP;
return (mpi_errno);
}
/* Create the new group */
MPIR_ALLOC(new_group_ptr,NEW(struct MPIR_GROUP),MPIR_COMM_WORLD,
MPI_ERR_EXHAUSTED, "MPI_GROUP_UNION" );
*group_out = (MPI_Group) MPIR_FromPointer( new_group_ptr );
new_group_ptr->self = *group_out;
MPIR_SET_COOKIE(new_group_ptr,MPIR_GROUP_COOKIE)
new_group_ptr->ref_count = 1;
new_group_ptr->permanent = 0;
new_group_ptr->local_rank = group1_ptr->local_rank;
new_group_ptr->set_mark = (int *)0;
/* Set the number in the union */
n = group1_ptr->np + group2_ptr->np;
/* Allocate set marking space for group2 if necessary */
if (group2_ptr->set_mark == NULL) {
MPIR_ALLOC(group2_ptr->set_mark,(int *) MALLOC( group2_ptr->np * sizeof(int) ),
MPIR_COMM_WORLD,MPI_ERR_EXHAUSTED,"MPI_GROUP_UNION");
}
/* Mark the union */
for ( j=0; j<group2_ptr->np; j++ ) {
group2_ptr->set_mark[j] = MPIR_MARKED;
for ( i=0; i<group1_ptr->np; i++ )
if ( group1_ptr->lrank_to_grank[i] == group2_ptr->lrank_to_grank[j] ) {
group2_ptr->set_mark[j] = MPIR_UNMARKED;
n--;
break;
}
}
/* Alloc the memory */
new_group_ptr->np = n;
MPIR_ALLOC(new_group_ptr->lrank_to_grank,(int *) MALLOC( n * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_GROUP_UNION" );
/* Fill in the space */
n = group1_ptr->np;
memcpy(new_group_ptr->lrank_to_grank,group1_ptr->lrank_to_grank,n*sizeof(int));
for ( j=0; j<group2_ptr->np; j++ )
if ( (group2_ptr->set_mark[j]==MPIR_MARKED) && (n < new_group_ptr->np) )
new_group_ptr->lrank_to_grank[n++] = group2_ptr->lrank_to_grank[j];
/* Find the local rank only if local rank not defined in group 1 */
if ( new_group_ptr->local_rank == MPI_UNDEFINED ) {
global_rank = MPID_MyWorldRank;
for( i=group1_ptr->np; i<new_group_ptr->np; i++ )
if ( global_rank == new_group_ptr->lrank_to_grank[i] ) {
new_group_ptr->local_rank = i;
break;
}
}
/* Determine the previous and next powers of 2 */
MPIR_Powers_of_2 ( new_group_ptr->np, &(new_group_ptr->N2_next), &(new_group_ptr->N2_prev) );
TR_POP;
return (mpi_errno);
}
/*@
MPI_Waitsome - Waits for some given communications to complete
Input Parameters:
+ incount - length of array_of_requests (integer)
- array_of_requests - array of requests (array of handles)
Output Parameters:
+ outcount - number of completed requests (integer)
. array_of_indices - array of indices of operations that
completed (array of integers)
- array_of_statuses - array of status objects for
operations that completed (array of Status). May be 'MPI_STATUSES_IGNORE'.
Notes:
The array of indicies are in the range '0' to 'incount - 1' for C and
in the range '1' to 'incount' for Fortran.
Null requests are ignored; if all requests are null, then the routine
returns with 'outcount' set to 'MPI_UNDEFINED'.
.N waitstatus
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_REQUEST
.N MPI_ERR_ARG
.N MPI_ERR_IN_STATUS
@*/
int MPI_Waitsome(
int incount,
MPI_Request array_of_requests[],
int *outcount,
int array_of_indices[],
MPI_Status array_of_statuses[] )
{
int i, j, mpi_errno = MPI_SUCCESS;
MPI_Request request;
int nnull, mpi_lerr;
int nfound = 0;
static char myname[] = "MPI_WAITSOME";
disableSignal();
TR_PUSH(myname);
/* NOTE:
This implementation will not work correctly if the device requires
messages to be received in some particular order. In that case,
this routine needs to try and complete the messages in ANY order.
The same is true for waitall.c .
*/
nnull = 0;
while (nfound == 0 && nnull < incount ) {
MPID_DeviceCheck( MPID_NOTBLOCKING );
nnull = 0;
for (i = 0; i < incount; i++) {
/* Skip over null handles. We need this for handles generated
when MPI_PROC_NULL is the source or destination of an
operation */
request = array_of_requests[i];
if (!request) {/* || !request->chandle.active) { */
nnull ++;
continue;
}
mpi_lerr = 0;
switch (request->handle_type) {
case MPIR_SEND:
if (MPID_SendRequestCancelled(request)) {
if (array_of_statuses) {
array_of_statuses[i].MPI_TAG = MPIR_MSG_CANCELLED;
array_of_statuses[i].MPI_ERROR = MPI_SUCCESS;
}
nfound++;
}
else {
if (request->shandle.is_complete ||
MPID_SendIcomplete( request, &mpi_lerr )) {
array_of_indices[nfound] = i;
if (mpi_lerr) {
if (mpi_errno == MPI_SUCCESS) {
if (array_of_statuses) {
for (j=0; j<incount; j++)
array_of_statuses[j].MPI_ERROR = MPI_SUCCESS;
}
mpi_errno = MPI_ERR_IN_STATUS;
}
if (array_of_statuses)
array_of_statuses[nfound].MPI_ERROR = mpi_lerr;
}
MPIR_FORGET_SEND( &request->shandle );
MPID_SendFree( request );
array_of_requests[i] = 0;
nfound++;
}
}
break;
case MPIR_RECV:
if (request->rhandle.s.MPI_TAG == MPIR_MSG_CANCELLED) {
if (array_of_statuses)
array_of_statuses[i].MPI_TAG = MPIR_MSG_CANCELLED;
MPID_RecvFree( array_of_requests[i] );
array_of_requests[i] = 0;
nfound++;
}
else {
if (request->rhandle.is_complete ||
MPID_RecvIcomplete( request, (MPI_Status *)0,
&mpi_lerr )) {
array_of_indices[nfound] = i;
if (request->rhandle.s.MPI_ERROR) {
if (mpi_errno == MPI_SUCCESS) {
if (array_of_statuses) {
for (j=0; j<incount; j++)
array_of_statuses[j].MPI_ERROR = MPI_SUCCESS;
}
mpi_errno = MPI_ERR_IN_STATUS;
}
}
if (array_of_statuses)
array_of_statuses[nfound] = request->rhandle.s;
MPID_RecvFree( request );
array_of_requests[i] = 0;
nfound++;
}
}
break;
case MPIR_PERSISTENT_SEND:
if (!request->persistent_shandle.active) {
if (MPID_SendRequestCancelled(&request->persistent_shandle)) {
if (array_of_statuses)
array_of_statuses[i].MPI_TAG = MPIR_MSG_CANCELLED;
nfound++;
}
else
nnull++;
}
else if (request->persistent_shandle.shandle.is_complete ||
MPID_SendIcomplete( request, &mpi_lerr )) {
array_of_indices[nfound] = i;
if (mpi_lerr) {
if (mpi_errno == MPI_SUCCESS) {
if (array_of_statuses) {
for (j=0; j<incount; j++)
array_of_statuses[j].MPI_ERROR = MPI_SUCCESS;
}
mpi_errno = MPI_ERR_IN_STATUS;
}
if (array_of_statuses)
array_of_statuses[nfound].MPI_ERROR = mpi_lerr;
}
request->persistent_shandle.active = 0;
nfound++;
}
break;
case MPIR_PERSISTENT_RECV:
if (!request->persistent_rhandle.active) {
if (request->persistent_rhandle.rhandle.s.MPI_TAG ==
MPIR_MSG_CANCELLED) {
if (array_of_statuses)
array_of_statuses[i].MPI_TAG = MPIR_MSG_CANCELLED;
nfound++;
}
else
nnull++;
}
else if (request->persistent_rhandle.rhandle.is_complete ||
MPID_RecvIcomplete( request, (MPI_Status *)0,
&mpi_lerr )) {
array_of_indices[nfound] = i;
if (mpi_lerr) {
if (mpi_errno == MPI_SUCCESS) {
if (array_of_statuses) {
for (j=0; j<incount; j++)
array_of_statuses[j].MPI_ERROR = MPI_SUCCESS;
}
mpi_errno = MPI_ERR_IN_STATUS;
}
}
if (array_of_statuses)
array_of_statuses[nfound] =
request->persistent_rhandle.rhandle.s;
request->persistent_rhandle.active = 0;
nfound++;
}
break;
}
}
}
if (nnull == incount)
*outcount = MPI_UNDEFINED;
else
*outcount = nfound;
if (mpi_errno) {
revertSignal();
return MPIR_ERROR(MPIR_COMM_WORLD, mpi_errno, myname);
}
TR_POP;
revertSignal();
return mpi_errno;
}
/*@
MPI_Type_indexed - Creates an indexed datatype
Input Parameters:
+ count - number of blocks -- also number of entries in indices and blocklens
. blocklens - number of elements in each block (array of nonnegative integers)
. indices - displacement of each block in multiples of old_type (array of
integers)
- old_type - old datatype (handle)
Output Parameter:
. newtype - new datatype (handle)
.N fortran
The indices are displacements, and are based on a zero origin. A common error
is to do something like to following
.vb
integer a(100)
integer blens(10), indices(10)
do i=1,10
blens(i) = 1
10 indices(i) = 1 + (i-1)*10
call MPI_TYPE_INDEXED(10,blens,indices,MPI_INTEGER,newtype,ierr)
call MPI_TYPE_COMMIT(newtype,ierr)
call MPI_SEND(a,1,newtype,...)
.ve
expecting this to send 'a(1),a(11),...' because the indices have values
'1,11,...'. Because these are `displacements` from the beginning of 'a',
it actually sends 'a(1+1),a(1+11),...'.
If you wish to consider the displacements as indices into a Fortran array,
consider declaring the Fortran array with a zero origin
.vb
integer a(0:99)
.ve
.N Errors
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_ARG
.N MPI_ERR_EXHAUSTED
@*/
int MPI_Type_indexed(
int count,
int blocklens[],
int indices[],
MPI_Datatype old_type,
MPI_Datatype *newtype )
{
MPI_Aint *hindices;
int i, mpi_errno = MPI_SUCCESS;
int total_count;
struct MPIR_DATATYPE *old_dtype_ptr;
static char myname[] = "MPI_TYPE_INDEXED";
MPIR_ERROR_DECL;
disableSignal();
TR_PUSH(myname);
/* Check for bad arguments */
old_dtype_ptr = MPIR_GET_DTYPE_PTR(old_type);
MPIR_TEST_DTYPE(old_type,old_dtype_ptr,MPIR_COMM_WORLD,myname);
if (
( (count < 0) && (mpi_errno = MPI_ERR_COUNT) ) ||
( (old_dtype_ptr->dte_type == MPIR_UB) && (mpi_errno = MPI_ERR_TYPE) ) ||
( (old_dtype_ptr->dte_type == MPIR_LB) && (mpi_errno = MPI_ERR_TYPE) ) ) {
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno,myname);
}
/* Are we making a null datatype? */
total_count = 0;
for (i=0; i<count; i++) {
total_count += blocklens[i];
if (blocklens[i] < 0) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_ARG_ARRAY_VAL,
myname, (char *)0, (char *)0,
"blocklens", i, blocklens[i] );
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno,myname);
}
}
if (total_count == 0) {
revertSignal();
return MPI_Type_contiguous( 0, MPI_INT, newtype );
}
/* Generate a call to MPI_Type_hindexed instead. This means allocating
a temporary displacement array, multiplying all displacements
by extent(old_type), and using that */
MPIR_ALLOC(hindices,(MPI_Aint *)MALLOC(count*sizeof(MPI_Aint)),
MPIR_COMM_WORLD,MPI_ERR_EXHAUSTED,myname);
for (i=0; i<count; i++) {
hindices[i] = (MPI_Aint)indices[i] * old_dtype_ptr->extent;
}
MPIR_ERROR_PUSH(MPIR_COMM_WORLD);
mpi_errno = MPI_Type_hindexed( count, blocklens, hindices, old_type,
newtype );
MPIR_ERROR_POP(MPIR_COMM_WORLD);
FREE(hindices);
TR_POP;
revertSignal();
MPIR_RETURN(MPIR_COMM_WORLD,mpi_errno, myname);
}
/*@
MPI_Attr_put - Stores attribute value associated with a key
Input Parameters:
+ comm - communicator to which attribute will be attached (handle)
. keyval - key value, as returned by 'MPI_KEYVAL_CREATE' (integer)
- attribute_val - attribute value
Notes:
Values of the permanent attributes 'MPI_TAG_UB', 'MPI_HOST', 'MPI_IO', and
'MPI_WTIME_IS_GLOBAL' may not be changed.
The type of the attribute value depends on whether C or Fortran is being used.
In C, an attribute value is a pointer ('void *'); in Fortran, it is a single
integer (`not` a pointer, since Fortran has no pointers and there are systems
for which a pointer does not fit in an integer (e.g., any > 32 bit address
system that uses 64 bits for Fortran 'DOUBLE PRECISION').
If an attribute is already present, the delete function (specified when the
corresponding keyval was created) will be called.
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_KEYVAL
.N MPI_ERR_PERM_KEY
.seealso MPI_Attr_get, MPI_Keyval_create, MPI_Attr_delete
@*/
EXPORT_MPI_API int MPI_Attr_put ( MPI_Comm comm, int keyval, void *attr_value )
{
MPIR_HBT_node *attr;
MPIR_Attr_key *attr_key;
int mpi_errno = MPI_SUCCESS;
struct MPIR_COMMUNICATOR *comm_ptr;
static char myname[] = "MPI_ATTR_PUT";
TR_PUSH(myname);
comm_ptr = MPIR_GET_COMM_PTR(comm);
MPIR_TEST_MPI_COMM(comm,comm_ptr,comm_ptr,myname);
attr_key = MPIR_GET_KEYVAL_PTR( keyval );
MPIR_TEST_MPI_KEYVAL(keyval,attr_key,comm_ptr,myname);
/* Check for valid arguments */
if ( ( (keyval == MPI_KEYVAL_INVALID) && (mpi_errno = MPI_ERR_OTHER) ) )
return MPIR_ERROR( comm_ptr, mpi_errno, myname);
if (comm == MPI_COMM_WORLD && attr_key->permanent)
return MPIR_ERROR( comm_ptr,
MPIR_ERRCLASS_TO_CODE(MPI_ERR_ARG,MPIR_ERR_PERM_KEY),myname );
MPIR_HBT_lookup(comm_ptr->attr_cache, keyval, &attr);
if (attr == (MPIR_HBT_node *)0) {
(void) MPIR_HBT_new_node ( attr_key, attr_value, &attr );
(void) MPIR_HBT_insert ( comm_ptr->attr_cache, attr );
/* Every update to the attr_key must be counted! */
MPIR_REF_INCR(attr_key);
}
else {
/*
This is an unclear part of the standard. Under MPI_KEYVAL_CREATE,
it is claimed that ONLY MPI_COMM_FREE and MPI_ATTR_DELETE
can cause the delete routine to be called. Under
MPI_ATTR_PUT, however, the delete routine IS called.
*/
if ( attr_key->delete_fn.c_delete_fn ) {
if (attr_key->FortranCalling) {
MPI_Aint invall = (MPI_Aint)attr->value;
int inval = (int)invall;
(void) (*attr_key->delete_fn.f77_delete_fn)(comm,
&keyval, &inval,
attr_key->extra_state, &mpi_errno );
attr->value = (void *)(MPI_Aint)inval;
}
else
mpi_errno = (*attr_key->delete_fn.c_delete_fn)(comm, keyval,
attr->value,
attr_key->extra_state );
if (mpi_errno)
return MPIR_ERROR( comm_ptr, mpi_errno, myname);
}
attr->value = attr_value;
}
/* The device may want to know about attributes */
MPID_ATTR_SET(comm_ptr,keyval,attr_value);
TR_POP;
return (mpi_errno);
}
/*@
MPI_Type_struct - Creates a struct datatype
Input Parameters:
+ count - number of blocks (integer) -- also number of
entries in arrays array_of_types ,
array_of_displacements and array_of_blocklengths
. blocklens - number of elements in each block (array)
. indices - byte displacement of each block (array)
- old_types - type of elements in each block (array
of handles to datatype objects)
Output Parameter:
. newtype - new datatype (handle)
Notes:
If an upperbound is set explicitly by using the MPI datatype 'MPI_UB', the
corresponding index must be positive.
The MPI standard originally made vague statements about padding and alignment;
this was intended to allow the simple definition of structures that could
be sent with a count greater than one. For example,
.vb
struct { int a; char b; } foo;
.ve
may have 'sizeof(foo) > sizeof(int) + sizeof(char)'; for example,
'sizeof(foo) == 2*sizeof(int)'. The initial version of the MPI standard
defined the extent of a datatype as including an `epsilon` that would have
allowed an implementation to make the extent an MPI datatype
for this structure equal to '2*sizeof(int)'.
However, since different systems might define different paddings, there was
much discussion by the MPI Forum about what was the correct value of
epsilon, and one suggestion was to define epsilon as zero.
This would have been the best thing to do in MPI 1.0, particularly since
the 'MPI_UB' type allows the user to easily set the end of the structure.
Unfortunately, this change did not make it into the final document.
Currently, this routine does not add any padding, since the amount of
padding needed is determined by the compiler that the user is using to
build their code, not the compiler used to construct the MPI library.
A later version of MPICH may provide for some natural choices of padding
(e.g., multiple of the size of the largest basic member), but users are
advised to never depend on this, even with vendor MPI implementations.
Instead, if you define a structure datatype and wish to send or receive
multiple items, you should explicitly include an 'MPI_UB' entry as the
last member of the structure. For example, the following code can be used
for the structure foo
.vb
blen[0] = 1; indices[0] = 0; oldtypes[0] = MPI_INT;
blen[1] = 1; indices[1] = &foo.b - &foo; oldtypes[1] = MPI_CHAR;
blen[2] = 1; indices[2] = sizeof(foo); oldtypes[2] = MPI_UB;
MPI_Type_struct( 3, blen, indices, oldtypes, &newtype );
.ve
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
.N MPI_ERR_COUNT
.N MPI_ERR_EXHAUSTED
@*/
int MPI_Type_struct(
int count,
int blocklens[],
MPI_Aint indices[],
MPI_Datatype old_types[],
MPI_Datatype *newtype )
{
struct MPIR_DATATYPE* dteptr;
MPI_Aint ub, lb, high, low, real_ub, real_lb, real_init;
int high_init = 0, low_init = 0;
int i, mpi_errno = MPI_SUCCESS;
MPI_Aint ub_marker = 0, lb_marker = 0; /* to suppress warnings */
MPI_Aint ub_found = 0, lb_found = 0;
int size, total_count;
static char myname[] = "MPI_TYPE_STRUCT";
disableSignal();
/* Check for bad arguments */
if ( count < 0 ) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_COUNT, MPIR_ERR_DEFAULT, myname,
(char *)0, (char *)0, count );
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
if (count == 0) {
revertSignal();
return MPI_Type_contiguous( 0, MPI_INT, newtype );
}
/* Check blocklens and old_types arrays and find number of bound */
/* markers */
total_count = 0;
for (i=0; i<count; i++) {
total_count += blocklens[i];
if ( blocklens[i] < 0) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_ARG_ARRAY_VAL,
myname, (char *)0, (char *)0,
"blocklens", i, blocklens[i] );
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno,myname);
}
if ( old_types[i] == MPI_DATATYPE_NULL ) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_TYPE, MPIR_ERR_TYPE_ARRAY_NULL,
myname, (char *)0, (char *)0,
"old_types", i );
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
}
if (total_count == 0) {
revertSignal();
return MPI_Type_contiguous( 0, MPI_INT, newtype );
}
/* Create and fill in the datatype */
MPIR_ALLOC(dteptr,(struct MPIR_DATATYPE *) MPIR_SBalloc( MPIR_dtes ),MPIR_COMM_WORLD,
MPI_ERR_EXHAUSTED, myname );
*newtype = (MPI_Datatype) MPIR_FromPointer( dteptr );
dteptr->self = *newtype;
MPIR_SET_COOKIE(dteptr,MPIR_DATATYPE_COOKIE)
dteptr->dte_type = MPIR_STRUCT;
dteptr->committed = 0;
dteptr->basic = 0;
dteptr->permanent = 0;
dteptr->is_contig = 0;
dteptr->ref_count = 1;
dteptr->count = count;
dteptr->elements = 0;
dteptr->size = 0;
dteptr->align = 1;
dteptr->has_ub = 0;
dteptr->has_lb = 0;
dteptr->self = *newtype;
/* Create indices and blocklens arrays and fill them */
dteptr->indices = ( MPI_Aint * ) MALLOC( count * sizeof( MPI_Aint ) );
dteptr->blocklens = ( int * ) MALLOC( count * sizeof( int ) );
dteptr->old_types =
( struct MPIR_DATATYPE ** )MALLOC(count*sizeof(struct MPIR_DATATYPE *));
if (!dteptr->indices || !dteptr->blocklens || !dteptr->old_types) {
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_TYPE_STRUCT" );
}
high = low = ub = lb = 0;
real_ub = real_lb = 0;
real_init = 0;
/* If data alignment is 2, 4, or 8, then assign dteptr->align to that
value. If 0, then assign dteptr->align to the maximal alignment
requirement. (done below) */
if (ALIGNMENT_VALUE > 0)
dteptr->align = ALIGNMENT_VALUE;
for (i = 0; i < count; i++) {
struct MPIR_DATATYPE *old_dtype_ptr;
old_dtype_ptr = MPIR_GET_DTYPE_PTR(old_types[i]);
MPIR_TEST_DTYPE(old_types[i],old_dtype_ptr,MPIR_COMM_WORLD,
"MPI_TYPE_STRUCT");
dteptr->old_types[i] = MPIR_Type_dup (old_dtype_ptr);
dteptr->indices[i] = indices[i];
dteptr->blocklens[i] = blocklens[i];
/* Keep track of maximal alignment requirement */
if (ALIGNMENT_VALUE == 0) {
if (dteptr->align < old_dtype_ptr->align)
dteptr->align = old_dtype_ptr->align;
}
if ( old_dtype_ptr->dte_type == MPIR_UB ) {
if (ub_found) {
if (indices[i] > ub_marker)
ub_marker = indices[i];
}
else {
ub_marker = indices[i];
ub_found = 1;
}
}
else if ( old_dtype_ptr->dte_type == MPIR_LB ) {
if (lb_found) {
if ( indices[i] < lb_marker ) {
lb_marker = indices[i];
}
}
else {
lb_marker = indices[i];
lb_found = 1;
}
}
else {
/* Since the datatype is NOT a UB or LB, save the real limits */
if (!real_init) {
real_init = 1;
real_lb = old_dtype_ptr->real_lb;
real_ub = old_dtype_ptr->real_ub;
}
else {
if (old_dtype_ptr->real_lb < real_lb)
real_lb = old_dtype_ptr->real_lb;
if (old_dtype_ptr->real_ub > real_ub)
real_ub = old_dtype_ptr->real_ub;
}
/* Next, check to see if datatype has an MPI_LB or MPI_UB
within it...
Make sure to adjust the ub by the selected displacement
and blocklens (blocklens is like Type_contiguous)
*/
if (old_dtype_ptr->has_ub) {
MPI_Aint ub_test;
ub_test = old_dtype_ptr->ub + indices[i] +
(blocklens[i] - 1) * old_dtype_ptr->extent;
if (ub_marker < ub_test || !ub_found) ub_marker = ub_test;
ub_found = 1;
}
if (old_dtype_ptr->has_lb) {
if (!lb_found || lb_marker > (old_dtype_ptr->lb) + indices[i] )
lb_marker = old_dtype_ptr->lb + indices[i];
lb_found = 1;
}
/* Get the ub/lb from the datatype (if a MPI_UB or MPI_LB was
found, then these values will be ignored).
We use the lb of the old type and add the indices
value to it */
lb = indices[i] + old_dtype_ptr->lb;
ub = lb + (blocklens[i] * old_dtype_ptr->extent) ;
if (!high_init) { high = ub; high_init = 1; }
else if (ub > high) high = ub;
if (!low_init ) { low = lb; low_init = 1; }
else if (lb < low) low = lb;
if (ub > lb) {
if ( high < ub ) high = ub;
if ( low > lb ) low = lb;
}
else {
if ( high < lb ) high = lb;
if ( low > ub ) low = ub;
}
dteptr->elements += (blocklens[i] * old_dtype_ptr->elements);
} /* end else */
if (i < count - 1) {
size = old_dtype_ptr->size * blocklens[i];
dteptr->size += size;
}
else {
dteptr->size += (blocklens[i] * old_dtype_ptr->size);
}
} /* end for loop */
/* Set the upper/lower bounds and the extent and size */
if (lb_found) {
dteptr->lb = lb_marker;
dteptr->has_lb = 1;
}
else
dteptr->lb = (low_init ? low : 0);
if (ub_found) {
dteptr->ub = ub_marker;
dteptr->has_ub = 1;
}
else
dteptr->ub = (high_init ? high: 0);
dteptr->extent = dteptr->ub - dteptr->lb ;
dteptr->real_ub = real_ub;
dteptr->real_lb = real_lb;
/* If there is no explicit ub/lb marker, make the extent/ub fit the
alignment of the largest basic item, if that structure alignment is
chosen */
if (!lb_found && !ub_found) {
MPI_Aint eps_offset;
/* Since data is always offset by the extent, is the extent that
we must adjust. */
eps_offset = dteptr->extent % dteptr->align;
if (eps_offset > 0) {
dteptr->ub += (dteptr->align - eps_offset);
dteptr->extent = dteptr->ub - dteptr->lb;
}
}
# if defined(MPID_HAS_TYPE_STRUCT)
{
mpi_errno = MPID_Type_struct(count,
blocklens,
indices,
old_types,
*newtype);
}
# endif
revertSignal();
return (mpi_errno);
}
/*@
MPI_Cart_create - Makes a new communicator to which topology information
has been attached
Input Parameters:
+ comm_old - input communicator (handle)
. ndims - number of dimensions of cartesian grid (integer)
. dims - integer array of size ndims specifying the number of processes in
each dimension
. periods - logical array of size ndims specifying whether the grid is
periodic (true) or not (false) in each dimension
- reorder - ranking may be reordered (true) or not (false) (logical)
Output Parameter:
. comm_cart - communicator with new cartesian topology (handle)
Algorithm:
We ignore 'reorder' info currently.
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TOPOLOGY
.N MPI_ERR_DIMS
.N MPI_ERR_ARG
@*/
int MPI_Cart_create ( MPI_Comm comm_old, int ndims, int *dims, int *periods,
int reorder, MPI_Comm *comm_cart )
{
int range[1][3];
MPI_Group group_old, group;
int i, rank, num_ranks = 1;
int mpi_errno = MPI_SUCCESS;
int flag, size;
MPIR_TOPOLOGY *topo;
struct MPIR_COMMUNICATOR *comm_old_ptr;
static char myname[] = "MPI_CART_CREATE";
TR_PUSH(myname);
comm_old_ptr = MPIR_GET_COMM_PTR(comm_old);
/* Check validity of arguments */
#ifndef MPIR_NO_ERROR_CHECKING
MPIR_TEST_MPI_COMM(comm_old,comm_old_ptr,comm_old_ptr,myname);
MPIR_TEST_ARG(comm_cart);
MPIR_TEST_ARG(periods);
if (ndims < 1 || dims == (int *)0) mpi_errno = MPI_ERR_DIMS;
if (mpi_errno)
return MPIR_ERROR(comm_old_ptr, mpi_errno, myname );
/* Check for Intra-communicator */
MPI_Comm_test_inter ( comm_old, &flag );
if (flag)
return MPIR_ERROR(comm_old_ptr,
MPIR_ERRCLASS_TO_CODE(MPI_ERR_COMM,MPIR_ERR_COMM_INTER), myname );
#endif
/* Determine number of ranks in topology */
for ( i=0; i<ndims; i++ )
num_ranks *= (dims[i]>0)?dims[i]:-dims[i];
if ( num_ranks < 1 ) {
(*comm_cart) = MPI_COMM_NULL;
return MPIR_ERROR( comm_old_ptr, MPI_ERR_TOPOLOGY, myname );
}
/* Is the old communicator big enough? */
MPIR_Comm_size (comm_old_ptr, &size);
if (num_ranks > size) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_TOPOLOGY, MPIR_ERR_TOPO_TOO_LARGE,
myname,
"Topology size is larger than size of communicator",
"Topology size %d is greater than communicator size %d",
num_ranks, size );
return MPIR_ERROR(comm_old_ptr, mpi_errno, myname );
}
/* Make new comm */
range[0][0] = 0; range[0][1] = num_ranks - 1; range[0][2] = 1;
MPI_Comm_group ( comm_old, &group_old );
MPI_Group_range_incl ( group_old, 1, range, &group );
MPI_Comm_create ( comm_old, group, comm_cart );
MPI_Group_free( &group );
MPI_Group_free( &group_old );
/* Store topology information in new communicator */
if ( (*comm_cart) != MPI_COMM_NULL ) {
MPIR_ALLOC(topo,(MPIR_TOPOLOGY *) MPIR_SBalloc ( MPIR_topo_els ),
comm_old_ptr,MPI_ERR_EXHAUSTED,myname);
MPIR_SET_COOKIE(&topo->cart,MPIR_CART_TOPOL_COOKIE)
topo->cart.type = MPI_CART;
topo->cart.nnodes = num_ranks;
topo->cart.ndims = ndims;
MPIR_ALLOC(topo->cart.dims,(int *)MALLOC( sizeof(int) * 3 * ndims ),
comm_old_ptr,MPI_ERR_EXHAUSTED,myname);
topo->cart.periods = topo->cart.dims + ndims;
topo->cart.position = topo->cart.periods + ndims;
for ( i=0; i<ndims; i++ ) {
topo->cart.dims[i] = dims[i];
topo->cart.periods[i] = periods[i];
}
/* Compute my position */
MPI_Comm_rank ( (*comm_cart), &rank );
for ( i=0; i < ndims; i++ ) {
num_ranks = num_ranks / dims[i];
topo->cart.position[i] = rank / num_ranks;
rank = rank % num_ranks;
}
/* cache topology information */
MPI_Attr_put ( (*comm_cart), MPIR_TOPOLOGY_KEYVAL, (void *)topo );
}
TR_POP;
return (mpi_errno);
}
/*@
MPI_Type_create_subarray - Creates a datatype describing a subarray of a multidimensional array
Input Parameters:
+ ndims - number of array dimensions (positive integer)
. array_of_sizes - number of elements of type oldtype in each dimension of the full array (array of positive integers)
. array_of_subsizes - number of elements of type oldtype in each dimension of the subarray (array of positive integers)
. array_of_starts - starting coordinates of the subarray in each dimension (array of nonnegative integers)
. order - array storage order flag (state)
- oldtype - old datatype (handle)
Output Parameters:
. newtype - new datatype (handle)
.N fortran
@*/
int MPI_Type_create_subarray(
int ndims,
int *array_of_sizes,
int *array_of_subsizes,
int *array_of_starts,
int order,
MPI_Datatype oldtype,
MPI_Datatype *newtype)
{
MPI_Aint extent, disps[3], size;
int i, blklens[3];
MPI_Datatype tmp1, tmp2, types[3];
int mpi_errno=0;
static char myname[] = "MPI_TYPE_CREATE_SUBARRAY";
disableSignal();
if (ndims <= 0) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_ARG_NAMED, myname,
(char *)0,
"Invalid %s argument = %d", "ndims", ndims );
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
MPIR_TEST_ARG(array_of_sizes);
MPIR_TEST_ARG(array_of_subsizes);
MPIR_TEST_ARG(array_of_starts);
if (mpi_errno) {
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
for (i=0; i<ndims; i++) {
if (array_of_sizes[i] <= 0) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_ARG_ARRAY_VAL,
myname, (char *)0, (char *)0,
"array_of_sizes", i,
array_of_sizes[i] );
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
if (array_of_subsizes[i] <= 0) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_ARG_ARRAY_VAL,
myname, (char *)0, (char *)0,
"array_of_subsizes", i,
array_of_subsizes[i] );
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
if (array_of_starts[i] < 0) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_ARG_ARRAY_VAL,
myname, (char *)0, (char *)0,
"array_of_starts", i,
array_of_starts[i] );
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
}
/* order argument checked below */
if (oldtype == MPI_DATATYPE_NULL) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_TYPE, MPIR_ERR_TYPE_NULL,
myname, (char *)0, (char *)0 );
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
MPI_Type_extent(oldtype, &extent);
if (order == MPI_ORDER_FORTRAN) {
/* dimension 0 changes fastest */
if (ndims == 1)
MPI_Type_contiguous(array_of_subsizes[0], oldtype, &tmp1);
else {
MPI_Type_vector(array_of_subsizes[1], array_of_subsizes[0],
array_of_sizes[0], oldtype, &tmp1);
size = array_of_sizes[0]*extent;
for (i=2; i<ndims; i++) {
size *= array_of_sizes[i-1];
MPI_Type_hvector(array_of_subsizes[i], 1, size, tmp1, &tmp2);
MPI_Type_free(&tmp1);
tmp1 = tmp2;
}
}
/* add displacement and UB */
disps[1] = array_of_starts[0];
size = 1;
for (i=1; i<ndims; i++) {
size *= array_of_sizes[i-1];
disps[1] += size*array_of_starts[i];
}
/* rest done below for both Fortran and C order */
}
else if (order == MPI_ORDER_C) {
/* dimension ndims-1 changes fastest */
if (ndims == 1)
MPI_Type_contiguous(array_of_subsizes[0], oldtype, &tmp1);
else {
MPI_Type_vector(array_of_subsizes[ndims-2],
array_of_subsizes[ndims-1],
array_of_sizes[ndims-1], oldtype, &tmp1);
size = array_of_sizes[ndims-1]*extent;
for (i=ndims-3; i>=0; i--) {
size *= array_of_sizes[i+1];
MPI_Type_hvector(array_of_subsizes[i], 1, size, tmp1, &tmp2);
MPI_Type_free(&tmp1);
tmp1 = tmp2;
}
}
/* add displacement and UB */
disps[1] = array_of_starts[ndims-1];
size = 1;
for (i=ndims-2; i>=0; i--) {
size *= array_of_sizes[i+1];
disps[1] += size*array_of_starts[i];
}
}
else {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_ORDER, myname,
(char *)0, (char *)0, order );
revertSignal();
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
disps[1] *= extent;
disps[2] = extent;
for (i=0; i<ndims; i++) disps[2] *= array_of_sizes[i];
disps[0] = 0;
blklens[0] = blklens[1] = blklens[2] = 1;
types[0] = MPI_LB;
types[1] = tmp1;
types[2] = MPI_UB;
MPI_Type_struct(3, blklens, disps, types, newtype);
MPI_Type_free(&tmp1);
revertSignal();
return MPI_SUCCESS;
}
/*@
MPI_Info_set - Adds a (key,value) pair to info
Input Parameters:
+ info - info object (handle)
. key - key (string)
- value - value (string)
.N fortran
@*/
EXPORT_MPI_API int MPI_Info_set(MPI_Info info, char *key, char *value)
{
MPI_Info prev, curr;
int mpi_errno;
static char myname[] = "MPI_INFO_SET";
if ((info <= (MPI_Info) 0) || (info->cookie != MPIR_INFO_COOKIE)) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO, MPIR_ERR_DEFAULT, myname,
(char *)0, (char *)0 );
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
if (!key) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO_KEY, MPIR_ERR_DEFAULT,
myname, (char *)0, (char *)0);
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
if (!value) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO_VALUE, MPIR_ERR_DEFAULT,
myname, (char *)0, (char *)0 );
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
if (strlen(key) > MPI_MAX_INFO_KEY) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO_KEY, MPIR_ERR_KEY_TOOLONG,
myname, (char *)0, (char *)0,strlen(key),
MPI_MAX_INFO_KEY );
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
if (strlen(value) > MPI_MAX_INFO_VAL) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO_VALUE,MPIR_ERR_INFO_VALUE_TOOLONG,
myname,(char*)0,(char*)0,
strlen(value), MPI_MAX_INFO_VAL );
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
if (!strlen(key)) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO_KEY, MPIR_ERR_KEY_EMPTY,
myname, (char *)0, (char *)0 );
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
if (!strlen(value)) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO_VALUE,
MPIR_ERR_INFO_VALUE_EMPTY,
myname, (char *)0, (char *)0 );
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
prev = info;
curr = info->next;
while (curr) {
if (!strcmp(curr->key, key)) {
#ifdef free
/* By default, we define free as an illegal expression when doing memory
checking; we need to undefine it to handle the fact that strdup does
a naked malloc.
*/
#undef free
#endif
free(curr->value); /* not ADIOI_Free, because it was strdup'ed */
curr->value = strdup(value);
break;
}
prev = curr;
curr = curr->next;
}
if (!curr) {
prev->next = (MPI_Info) MALLOC(sizeof(struct MPIR_Info));
curr = prev->next;
curr->cookie = 0; /* cookie not set on purpose */
curr->key = strdup(key);
curr->value = strdup(value);
curr->next = 0;
}
return MPI_SUCCESS;
}
/*@
MPI_Group_range_excl - Produces a group by excluding ranges of processes from
an existing group
Input Parameters:
+ group - group (handle)
. n - number of elements in array 'ranks' (integer)
- ranges - a one-dimensional
array of integer triplets of the
form (first rank, last rank, stride), indicating the ranks in
'group' of processes to be excluded
from the output group 'newgroup' .
Output Parameter:
. newgroup - new group derived from above, preserving the
order in 'group' (handle)
Note:
Currently, each of the ranks to exclude must be
a valid rank in the group and all elements must be distinct or the
function is erroneous. This restriction is per the draft.
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_GROUP
.N MPI_ERR_EXHAUSTED
.N MPI_ERR_RANK
.N MPI_ERR_ARG
.seealso: MPI_Group_free
@*/
EXPORT_MPI_API int MPI_Group_range_excl ( MPI_Group group, int n, int ranges[][3],
MPI_Group *newgroup )
{
int i, j, first, last, stride;
int np;
struct MPIR_GROUP *group_ptr, *new_group_ptr;
int mpi_errno = MPI_SUCCESS;
static char myname[] = "MPI_GROUP_RANGE_EXCL";
TR_PUSH(myname);
/* Check for bad arguments */
group_ptr = MPIR_GET_GROUP_PTR(group);
#ifndef MPIR_NO_ERROR_CHECKING
/* MPIR_TEST_MPI_GROUP(group,group_ptr,MPIR_COMM_WORLD,myname); */
MPIR_TEST_GROUP(group_ptr);
if (mpi_errno)
return MPIR_ERROR(MPIR_COMM_WORLD, mpi_errno, myname );
#endif
/* Check for a EMPTY input group */
if ( (group == MPI_GROUP_EMPTY) ) {
MPIR_Group_dup ( MPIR_GROUP_EMPTY, &new_group_ptr );
*newgroup = new_group_ptr->self;
TR_POP;
return (mpi_errno);
}
/* Check for no range ranks to exclude */
if ( n == 0 ) {
MPIR_Group_dup ( group_ptr, &new_group_ptr );
*newgroup = new_group_ptr->self;
return (mpi_errno);
}
if (n < 0)
return MPIR_ERROR( MPIR_COMM_WORLD, MPI_ERR_ARG, myname );
/* Allocate set marking space for group if necessary */
if (group_ptr->set_mark == NULL) {
MPIR_ALLOC(group_ptr->set_mark,(int *) MALLOC( group_ptr->np * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
}
(void) memset( group_ptr->set_mark, (char)0, group_ptr->np * sizeof(int) );
/* Mark the ranks to be excluded */
np = group_ptr->np;
for (i=0; i<n; i++) {
first = ranges[i][0]; last = ranges[i][1]; stride = ranges[i][2];
if (stride != 0) {
if ( (stride > 0 && first > last) ||
(stride < 0 && first < last) ) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_ARG_STRIDE,
myname,
"Range does not terminate",
"Range (%d,%d,%d) does not terminate", first, last, stride );
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
for ( j=first; j*stride <= last*stride; j += stride )
if ( (j < group_ptr->np) && (j >= 0) ) {
if (group_ptr->set_mark[j] == MPIR_UNMARKED) {
group_ptr->set_mark[j] = MPIR_MARKED;
np--;
}
}
else{
mpi_errno = MPIR_Err_setmsg( MPI_ERR_RANK, MPIR_ERR_DEFAULT,
myname, (char *)0,(char *)0, j );
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
}
else {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_ARG_ZERO_STRIDE,
myname, "Zero stride is incorrect",
(char *)0 );
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
}
}
/* Check np to see if we have original group or if we have null group */
if (np == 0) {
MPIR_Group_dup ( MPIR_GROUP_EMPTY, &new_group_ptr );
*newgroup = new_group_ptr->self;
return (mpi_errno);
}
if (np == group_ptr->np) {
MPIR_Group_dup ( group_ptr, &new_group_ptr );
*newgroup = new_group_ptr->self;
return (mpi_errno);
}
/* Create the new group */
MPIR_ALLOC(new_group_ptr,NEW(struct MPIR_GROUP),MPIR_COMM_WORLD,
MPI_ERR_EXHAUSTED, myname );
*newgroup = (MPI_Group) MPIR_FromPointer( new_group_ptr );
new_group_ptr->self = *newgroup;
MPIR_SET_COOKIE(new_group_ptr,MPIR_GROUP_COOKIE)
new_group_ptr->ref_count = 1;
new_group_ptr->permanent = 0;
new_group_ptr->local_rank = MPI_UNDEFINED;
new_group_ptr->set_mark = (int *)0;
new_group_ptr->np = np;
new_group_ptr->lrank_to_grank = (int *) MALLOC( np * sizeof(int) );
if (!new_group_ptr->lrank_to_grank) {
return MPIR_ERROR( MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
}
/* Fill in new group */
for (i=j=0; i < group_ptr->np ; i++)
if ( (group_ptr->set_mark[i] == MPIR_UNMARKED) && (j < new_group_ptr->np ) ) {
if (group_ptr->local_rank == i)
new_group_ptr->local_rank = j;
new_group_ptr->lrank_to_grank[j++] = group_ptr->lrank_to_grank[i];
}
/* Determine the previous and next powers of 2 */
MPIR_Powers_of_2 ( new_group_ptr->np, &(new_group_ptr->N2_next),
&(new_group_ptr->N2_prev) );
TR_POP;
return (mpi_errno);
}
/*@
MPI_Intercomm_create - Creates an intercommuncator from two intracommunicators
Input Paramters:
+ local_comm - Local (intra)communicator
. local_leader - Rank in local_comm of leader (often 0)
. peer_comm - Remote communicator
. remote_leader - Rank in peer_comm of remote leader (often 0)
- tag - Message tag to use in constructing intercommunicator; if multiple
'MPI_Intercomm_creates' are being made, they should use different tags (more
precisely, ensure that the local and remote leaders are using different
tags for each 'MPI_intercomm_create').
Output Parameter:
. comm_out - Created intercommunicator
Notes:
The MPI 1.1 Standard contains two mutually exclusive comments on the
input intracommunicators. One says that their repective groups must be
disjoint; the other that the leaders can be the same process. After
some discussion by the MPI Forum, it has been decided that the groups must
be disjoint. Note that the `reason` given for this in the standard is
`not` the reason for this choice; rather, the `other` operations on
intercommunicators (like 'MPI_Intercomm_merge') do not make sense if the
groups are not disjoint.
.N fortran
Algorithm:
+ 1) Allocate a send context, an inter-coll context, and an intra-coll context
. 2) Send "send_context" and lrank_to_grank list from local comm group
if I''m the local_leader.
. 3) If I''m the local leader, then wait on the posted sends and receives
to complete. Post the receive for the remote group information and
wait for it to complete.
. 4) Broadcast information received from the remote leader.
. 5) Create the inter_communicator from the information we now have.
- An inter-communicator ends up with three levels of communicators.
The inter-communicator returned to the user, a "collective"
inter-communicator that can be used for safe communications between
local & remote groups, and a collective intra-communicator that can
be used to allocate new contexts during the merge and dup operations.
For the resulting inter-communicator, 'comm_out'
.vb
comm_out = inter-communicator
comm_out->comm_coll = "collective" inter-communicator
comm_out->comm_coll->comm_coll = safe collective intra-communicator
.ve
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_TAG
.N MPI_ERR_EXHAUSTED
.N MPI_ERR_RANK
.seealso: MPI_Intercomm_merge, MPI_Comm_free, MPI_Comm_remote_group,
MPI_Comm_remote_size
@*/
EXPORT_MPI_API int MPI_Intercomm_create ( MPI_Comm local_comm, int local_leader,
MPI_Comm peer_comm, int remote_leader, int tag,
MPI_Comm *comm_out )
{
int local_size, local_rank, peer_size, peer_rank;
int remote_size;
int mpi_errno = MPI_SUCCESS;
MPIR_CONTEXT context, send_context;
struct MPIR_GROUP *remote_group_ptr;
struct MPIR_COMMUNICATOR *new_comm, *local_comm_ptr, *peer_comm_ptr;
MPI_Request req[6];
MPI_Status status[6];
MPIR_ERROR_DECL;
static char myname[]="MPI_INTERCOMM_CREATE";
TR_PUSH(myname);
local_comm_ptr = MPIR_GET_COMM_PTR(local_comm);
#ifndef MPIR_NO_ERROR_CHECKING
/* Check for valid arguments to function */
MPIR_TEST_MPI_COMM(local_comm,local_comm_ptr,local_comm_ptr,myname);
MPIR_TEST_SEND_TAG(tag);
if (mpi_errno)
return MPIR_ERROR(local_comm_ptr, mpi_errno, myname );
#endif
if (local_comm == MPI_COMM_NULL) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_COMM, MPIR_ERR_LOCAL_COMM, myname,
"Local communicator must not be MPI_COMM_NULL", (char *)0 );
return MPIR_ERROR( local_comm_ptr, mpi_errno, myname );
}
(void) MPIR_Comm_size ( local_comm_ptr, &local_size );
(void) MPIR_Comm_rank ( local_comm_ptr, &local_rank );
if ( local_leader == local_rank ) {
/* Peer_comm need be valid only at local_leader */
peer_comm_ptr = MPIR_GET_COMM_PTR(peer_comm);
if ((MPIR_TEST_COMM_NOTOK(peer_comm,peer_comm_ptr) ||
(peer_comm == MPI_COMM_NULL))) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_COMM, MPIR_ERR_PEER_COMM,
myname, "Peer communicator is not valid",
(char *)0 );
return MPIR_ERROR( local_comm_ptr, mpi_errno, myname );
}
(void) MPIR_Comm_size ( peer_comm_ptr, &peer_size );
(void) MPIR_Comm_rank ( peer_comm_ptr, &peer_rank );
if (((peer_rank == MPI_UNDEFINED) && (mpi_errno = MPI_ERR_RANK)))
return MPIR_ERROR( local_comm_ptr, mpi_errno, myname );
if (((remote_leader >= peer_size) && (mpi_errno = MPI_ERR_RANK)) ||
((remote_leader < 0) && (mpi_errno = MPI_ERR_RANK))) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_RANK, MPIR_ERR_REMOTE_RANK,
myname,
"Error specifying remote_leader",
"Error specifying remote_leader; value %d not between 0 and %d", remote_leader, peer_size );
return MPIR_ERROR( local_comm_ptr, mpi_errno, myname );
}
}
if (((local_leader >= local_size) && (mpi_errno = MPI_ERR_RANK)) ||
((local_leader < 0) && (mpi_errno = MPI_ERR_RANK))) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_RANK, MPIR_ERR_LOCAL_RANK,
myname,
"Error specifying local_leader",
"Error specifying local_leader; value %d not in between 0 and %d", local_leader, local_size );
return MPIR_ERROR( local_comm_ptr, mpi_errno, myname );
}
/* Allocate send context, inter-coll context and intra-coll context */
MPIR_Context_alloc ( local_comm_ptr, 3, &context );
/* If I'm the local leader, then exchange information */
if (local_rank == local_leader) {
MPIR_ERROR_PUSH(peer_comm_ptr);
/* Post the receives for the information from the remote_leader */
/* We don't post a receive for the remote group yet, because we */
/* don't know how big it is yet. */
MPIR_CALL_POP(MPI_Irecv (&remote_size, 1, MPI_INT, remote_leader, tag,
peer_comm, &(req[2])),peer_comm_ptr,myname);
MPIR_CALL_POP(MPI_Irecv (&send_context, 1, MPIR_CONTEXT_TYPE,
remote_leader,tag, peer_comm, &(req[3])),
peer_comm_ptr,myname);
/* Send the lrank_to_grank table of the local_comm and an allocated */
/* context. Currently I use multiple messages to send this info. */
/* Eventually, this will change(?) */
MPIR_CALL_POP(MPI_Isend (&local_size, 1, MPI_INT, remote_leader, tag,
peer_comm, &(req[0])),peer_comm_ptr,myname);
MPIR_CALL_POP(MPI_Isend (&context, 1, MPIR_CONTEXT_TYPE, remote_leader,
tag, peer_comm, &(req[1])),peer_comm_ptr,myname);
/* Wait on the communication requests to finish */
MPIR_CALL_POP(MPI_Waitall ( 4, req, status ),peer_comm_ptr,myname);
/* We now know how big the remote group is, so create it */
remote_group_ptr = MPIR_CreateGroup ( remote_size );
remote_group_ptr->self =
(MPI_Group) MPIR_FromPointer( remote_group_ptr );
/* Post the receive for the group information */
MPIR_CALL_POP(MPI_Irecv (remote_group_ptr->lrank_to_grank, remote_size,
MPI_INT, remote_leader, tag, peer_comm,
&(req[5])),peer_comm_ptr,myname);
/* Send the local group info to the remote group */
MPIR_CALL_POP(MPI_Isend (local_comm_ptr->group->lrank_to_grank, local_size,
MPI_INT, remote_leader, tag, peer_comm,
&(req[4])),peer_comm_ptr,myname);
/* wait on the send and the receive for the group information */
MPIR_CALL_POP(MPI_Waitall ( 2, &(req[4]), &(status[4]) ),peer_comm_ptr,
myname);
MPIR_ERROR_POP(peer_comm_ptr);
/* Now we can broadcast the group information to the other local comm */
/* members. */
MPIR_ERROR_PUSH(local_comm_ptr);
MPIR_CALL_POP(MPI_Bcast(&remote_size,1,MPI_INT,local_rank,local_comm),
local_comm_ptr,myname);
MPIR_CALL_POP(MPI_Bcast(remote_group_ptr->lrank_to_grank, remote_size,
MPI_INT, local_rank, local_comm),local_comm_ptr,
myname);
MPIR_ERROR_POP(local_comm_ptr);
}
/* Else I'm just an ordinary comm member, so receive the bcast'd */
/* info about the remote group */
else {
MPIR_ERROR_PUSH(local_comm_ptr);
MPIR_CALL_POP(MPI_Bcast(&remote_size, 1, MPI_INT, local_leader,
local_comm),local_comm_ptr,myname);
/* We now know how big the remote group is, so create it */
remote_group_ptr = MPIR_CreateGroup ( remote_size );
remote_group_ptr->self =
(MPI_Group) MPIR_FromPointer( remote_group_ptr );
/* Receive the group info */
MPIR_CALL_POP(MPI_Bcast(remote_group_ptr->lrank_to_grank, remote_size,
MPI_INT, local_leader, local_comm),
local_comm_ptr,myname );
MPIR_ERROR_POP(local_comm_ptr);
}
MPIR_ERROR_PUSH(local_comm_ptr);
/* Broadcast the send context */
MPIR_CALL_POP(MPI_Bcast(&send_context, 1, MPIR_CONTEXT_TYPE,
local_leader, local_comm),local_comm_ptr,myname);
MPIR_ERROR_POP(local_comm_ptr);
/* We all now have all the information necessary, start building the */
/* inter-communicator */
MPIR_ALLOC(new_comm,NEW(struct MPIR_COMMUNICATOR),local_comm_ptr,
MPI_ERR_EXHAUSTED,myname );
MPIR_Comm_init( new_comm, local_comm_ptr, MPIR_INTER );
*comm_out = new_comm->self;
new_comm->group = remote_group_ptr;
MPIR_Group_dup( local_comm_ptr->group, &(new_comm->local_group) );
new_comm->local_rank = new_comm->local_group->local_rank;
new_comm->lrank_to_grank = new_comm->group->lrank_to_grank;
new_comm->np = new_comm->group->np;
new_comm->send_context = send_context;
new_comm->recv_context = context;
new_comm->comm_name = 0;
if ((mpi_errno = MPID_CommInit( local_comm_ptr, new_comm )) )
return mpi_errno;
(void) MPIR_Attr_create_tree ( new_comm );
/* Build the collective inter-communicator */
MPIR_Comm_make_coll( new_comm, MPIR_INTER );
MPIR_Comm_make_onesided( new_comm, MPIR_INTER );
/* Build the collective intra-communicator. Note that we require
an intra-communicator for the "coll_comm" so that MPI_COMM_DUP
can use it for some collective operations (do we need this
for MPI-2 with intercommunicator collective?)
Note that this really isn't the right thing to do; we need to replace
*all* of the Mississippi state collective code.
*/
MPIR_Comm_make_coll( new_comm->comm_coll, MPIR_INTRA );
#if 0
MPIR_Comm_make_coll( new_comm->comm_onesided, MPIR_INTRA );
#endif
/* Remember it for the debugger */
MPIR_Comm_remember ( new_comm );
TR_POP;
return (mpi_errno);
}
/*@
MPI_Waitany - Waits for any specified send or receive to complete
Input Parameters:
+ count - list length (integer)
- array_of_requests - array of requests (array of handles)
Output Parameters:
+ index - index of handle for operation that completed (integer). In the
range '0' to 'count-1'. In Fortran, the range is '1' to 'count'.
- status - status object (Status)
Notes:
If all of the requests are 'MPI_REQUEST_NULL', then 'index' is returned as
'MPI_UNDEFINED', and 'status' is returned as an empty status.
.N waitstatus
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_REQUEST
.N MPI_ERR_ARG
@*/
EXPORT_MPI_API int MPI_Waitany(
int count,
MPI_Request array_of_requests[],
int *index,
MPI_Status *status )
{
int i, mpi_errno = MPI_SUCCESS;
int done;
MPI_Request request;
static char myname[] = "MPI_WAITANY";
TR_PUSH(myname);
*index = MPI_UNDEFINED;
/* Check for all requests either null or inactive persistent */
for (i=0; i < count; i++) {
request = array_of_requests[i];
if (!request) continue;
if (request->handle_type == MPIR_PERSISTENT_SEND) {
if (request->persistent_shandle.active) break;
if (MPID_SendRequestCancelled(&request->persistent_shandle))
break;
}
else if (request->handle_type == MPIR_PERSISTENT_RECV) {
if (request->persistent_rhandle.active) break;
if (request->persistent_rhandle.rhandle.s.MPI_TAG ==
MPIR_MSG_CANCELLED) break;
}
else
break;
}
if (i == count) {
/* MPI Standard 1.1 requires an empty status in this case */
status->MPI_TAG = MPI_ANY_TAG;
status->MPI_SOURCE = MPI_ANY_SOURCE;
status->MPI_ERROR = MPI_SUCCESS;
MPID_ZERO_STATUS_COUNT(status);
*index = MPI_UNDEFINED;
TR_POP;
return mpi_errno;
}
done = 0;
while (!done) {
for (i=0; !done && i<count; i++) {
request = array_of_requests[i];
if (!request) continue;
switch (request->handle_type) {
case MPIR_SEND:
if (MPID_SendRequestCancelled(request)) {
status->MPI_TAG = MPIR_MSG_CANCELLED;
*index = i;
done = 1;
}
else {
if (MPID_SendIcomplete( request, &mpi_errno )) {
if (mpi_errno)
MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
MPIR_FORGET_SEND( &request->shandle );
MPID_Send_free( array_of_requests[i] );
*index = i;
array_of_requests[i] = 0;
done = 1;
}
}
break;
case MPIR_RECV:
if (request->rhandle.s.MPI_TAG == MPIR_MSG_CANCELLED) {
status->MPI_TAG = MPIR_MSG_CANCELLED;
MPID_Recv_free( array_of_requests[i] );
*index = i;
array_of_requests[i] = 0;
done = 1;
}
else {
if (MPID_RecvIcomplete( request, status, &mpi_errno )) {
if (mpi_errno)
MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
MPID_Recv_free( array_of_requests[i] );
*index = i;
array_of_requests[i] = 0;
done = 1;
}
}
break;
case MPIR_PERSISTENT_SEND:
if (request->persistent_shandle.active) {
if (MPID_SendIcomplete( request, &mpi_errno )) {
if (mpi_errno)
MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
request->persistent_shandle.active = 0;
*index = i;
done = 1;
}
}
else {
if (MPID_SendRequestCancelled(&request->persistent_shandle)) {
status->MPI_TAG = MPIR_MSG_CANCELLED;
*index = i;
done = 1;
}
}
break;
case MPIR_PERSISTENT_RECV:
if (request->persistent_rhandle.active) {
if (MPID_RecvIcomplete( request, status, &mpi_errno )) {
if (mpi_errno)
MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
request->persistent_rhandle.active = 0;
*index = i;
done = 1;
}
}
else {
if (request->persistent_rhandle.rhandle.s.MPI_TAG ==
MPIR_MSG_CANCELLED) {
status->MPI_TAG = MPIR_MSG_CANCELLED;
*index = i;
done = 1;
}
}
break;
}
}
if (!done) {
/* Do a NON blocking check */
MPID_DeviceCheck( MPID_NOTBLOCKING );
}
else
break;
}
TR_POP;
return mpi_errno;
}
/* Definitions of Fortran Wrapper routines */
EXPORT_MPI_API void FORTRAN_API mpi_info_set_(MPI_Fint *info, char *key, char *value, MPI_Fint *__ierr,
MPI_Fint keylen, MPI_Fint vallen)
#endif
{
MPI_Info info_c;
char *newkey, *newvalue;
int new_keylen, new_vallen, lead_blanks, i;
static char myname[] = "MPI_INFO_SET";
int mpi_errno;
if (!key) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO_KEY, MPIR_ERR_DEFAULT,
myname, (char *)0, (char *)0);
*__ierr = MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
return;
}
if (!value) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO_VALUE, MPIR_ERR_DEFAULT,
myname, (char *)0, (char *)0 );
*__ierr = MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
return;
}
/* strip leading and trailing blanks in key */
lead_blanks = 0;
for (i=0; i<(int)keylen; i++)
if (key[i] == ' ') lead_blanks++;
else break;
for (i=(int)keylen-1; i>=0; i--) if (key[i] != ' ') break;
if (i < 0) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO_KEY, MPIR_ERR_KEY_EMPTY,
myname, (char *)0, (char *)0 );
*__ierr = MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
return;
}
new_keylen = i + 1 - lead_blanks;
key += lead_blanks;
newkey = (char *) MALLOC((new_keylen+1)*sizeof(char));
strncpy(newkey, key, new_keylen);
newkey[new_keylen] = '\0';
/* strip leading and trailing blanks in value */
lead_blanks = 0;
for (i=0; i<(int)vallen; i++)
if (value[i] == ' ') lead_blanks++;
else break;
for (i=(int)vallen-1; i>=0; i--) if (value[i] != ' ') break;
if (i < 0) {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_INFO_VALUE,
MPIR_ERR_DEFAULT,
myname, (char *)0, (char *)0 );
*__ierr = MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
return;
}
new_vallen = i + 1 - lead_blanks;
value += lead_blanks;
newvalue = (char *) MALLOC((new_vallen+1)*sizeof(char));
strncpy(newvalue, value, new_vallen);
newvalue[new_vallen] = '\0';
info_c = MPI_Info_f2c(*info);
*__ierr = MPI_Info_set(info_c, newkey, newvalue);
FREE(newkey);
FREE(newvalue);
}
