/*@
MPI_Op_free - Frees a user-defined combination function handle
Input Parameter:
. op - operation (handle)
Notes:
'op' is set to 'MPI_OP_NULL' on exit.
.N NULL
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_PERM_OP
.seealso: MPI_Op_create
@*/
EXPORT_MPI_API int MPI_Op_free( MPI_Op *op )
{
int mpi_errno = MPI_SUCCESS;
struct MPIR_OP *old;
static char myname[] = "MPI_OP_FREE";
#ifndef MPIR_NO_ERROR_CHECKING
/* Freeing a NULL op should not return successfully */
MPIR_TEST_ARG(op);
if ( (*op) == MPI_OP_NULL ) {
mpi_errno = MPIR_ERRCLASS_TO_CODE(MPI_ERR_OP,MPIR_ERR_OP_NULL);
}
if (mpi_errno)
return MPIR_ERROR(MPIR_COMM_WORLD, mpi_errno, myname );
#endif
old = MPIR_GET_OP_PTR( *op );
MPIR_TEST_MPI_OP(*op,old,MPIR_COMM_WORLD,myname);
/* We can't free permanent objects unless finalize has been called */
if ( ( old->permanent == 1 ) && (MPIR_Has_been_initialized == 1) )
return MPIR_ERROR( MPIR_COMM_WORLD,
MPIR_ERRCLASS_TO_CODE(MPI_ERR_ARG,MPIR_ERR_PERM_OP),myname );
MPIR_CLR_COOKIE(old);
FREE( old );
MPIR_RmPointer( *op );
(*op) = MPI_OP_NULL;
TR_POP;
return (MPI_SUCCESS);
}
int main( int argc, char **argv )
{
int i, j, ecode, rlen, rc;
int errclass, errkind;
char msg1[MPI_MAX_ERROR_STRING+1];
char msg2[MPI_MAX_ERROR_STRING+1];
char *newmsg;
for (errclass=0; errclass<MPIR_MAX_ERRCLASS; errclass++) {
for (errkind=0; errkind<60; errkind++) {
ecode = MPIR_ERRCLASS_TO_CODE(errclass,errkind);
#ifdef FOO
/* Turn off use of message catalog */
usecat = 0;
rc = MPI_Error_string( ecode, msg2, &rlen );
/* Re-enable message catalog */
usecat = 1;
if (rc) continue;
PRINTF( "%d(%x) %s\n", ecode, ecode, msg2 );
#endif
MPIR_GetErrorMessage( ecode, (char *)0, &newmsg );
if (newmsg)
PRINTF( "%d:%d-%d(%x) %s\n", errclass, errkind, ecode, ecode, newmsg );
#ifdef FOO
else
PRINTF( "%d:%d-%d(%x) <NULL>\n", errclass, errkind, ecode, ecode );
#endif
}
}
return 0;
}
/*@
MPI_Attr_delete - Deletes attribute value associated with a key
Input Parameters:
+ comm - communicator to which attribute is attached (handle)
- keyval - The key value of the deleted attribute (integer)
.N fortran
.N Errors
.N MPI_ERR_COMM
.N MPI_ERR_PERM_KEY
@*/
EXPORT_MPI_API int MPI_Attr_delete ( MPI_Comm comm, int keyval )
{
MPIR_HBT_node *attr;
MPIR_Attr_key *attr_key;
int mpi_errno = MPI_SUCCESS;
struct MPIR_COMMUNICATOR *comm_ptr;
static char myname[] = "MPI_ATTR_DELETE";
TR_PUSH(myname);
comm_ptr = MPIR_GET_COMM_PTR(comm);
MPIR_TEST_MPI_COMM(comm,comm_ptr,comm_ptr,myname);
if ( ( (keyval == MPI_KEYVAL_INVALID) && (mpi_errno = MPI_ERR_OTHER) ) )
return MPIR_ERROR(comm_ptr, mpi_errno, myname);
attr_key = MPIR_GET_KEYVAL_PTR( keyval );
MPIR_TEST_MPI_KEYVAL(keyval,attr_key,comm_ptr,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) {
if ( attr_key->delete_fn.c_delete_fn ) {
if (attr_key->FortranCalling) {
MPI_Aint invall = (MPI_Aint)attr->value;
int inval = (int)invall;
(*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 );
}
MPIR_HBT_delete(comm_ptr->attr_cache, keyval, &attr);
/* We will now have one less reference to keyval */
MPIR_REF_DECR(attr_key);
if ( attr != (MPIR_HBT_node *)0 )
(void) MPIR_HBT_free_node ( attr );
}
else {
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_NOKEY, myname,
"Key not in communicator",
"Key %d not in communicator", keyval );
return MPIR_ERROR( comm_ptr, mpi_errno, myname );
/* "Error in MPI_ATTR_DELETE: key not in communicator" ); */
}
TR_POP;
return(mpi_errno);
}
/*@
MPI_Keyval_free - Frees attribute key for communicator cache attribute
Input Parameter:
. keyval - Frees the integer key value (integer)
Note:
Key values are global (they can be used with any and all communicators)
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_PERM_KEY
.seealso: MPI_Keyval_create
@*/
EXPORT_MPI_API int MPI_Keyval_free ( int *keyval )
{
int mpi_errno = MPI_SUCCESS;
MPIR_Attr_key *attr_key;
static char myname[] = "MPI_KEYVAL_FREE";
#ifndef MPIR_NO_ERROR_CHECKING
MPIR_TEST_ARG(keyval);
if (*keyval == MPI_KEYVAL_INVALID) {
/* Can't free an invalid keyval */
mpi_errno = MPIR_Err_setmsg( MPI_ERR_ARG, MPIR_ERR_KEYVAL, myname,
(char *)0, (char *)0 );
}
if (mpi_errno)
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
#endif
attr_key = MPIR_GET_KEYVAL_PTR( *keyval );
#ifndef MPIR_NO_ERROR_CHECKING
MPIR_TEST_MPI_KEYVAL(*keyval,attr_key,MPIR_COMM_WORLD,myname);
if ( (attr_key->permanent == 1) && (MPIR_Has_been_initialized == 1) ){
mpi_errno = MPIR_ERRCLASS_TO_CODE(MPI_ERR_ARG,MPIR_ERR_PERM_KEY);
}
if (mpi_errno)
return MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
#endif
if (attr_key->ref_count <= 1) {
MPIR_CLR_COOKIE(attr_key);
FREE ( attr_key );
MPIR_RmPointer( *keyval );
}
else {
MPIR_REF_DECR(attr_key);
#ifdef FOO
/* Debugging only */
if (MPIR_Has_been_initialized != 1)
PRINTF( "attr_key count is %d\n", attr_key->ref_count );
#endif
}
(*keyval) = MPI_KEYVAL_INVALID;
return (MPI_SUCCESS);
}
/*@
MPI_Status_c2f - Convert a C status to a Fortran status
Input Parameters:
. c_status - Status value in C (Status)
Output Parameter:
. f_status - Status value in Fortran (Integer)
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
@*/
int MPI_Status_c2f( MPI_Status *c_status, MPI_Fint *f_status )
{
int i;
int *c_status_arr = (int *)c_status;
if (c_status == MPI_STATUS_IGNORE ||
c_status == MPI_STATUSES_IGNORE) {
return MPIR_ERROR( MPIR_COMM_WORLD,
MPIR_ERRCLASS_TO_CODE(MPI_ERR_ARG,MPIR_ERR_STATUS_IGNORE),
"MPI_STATUS_C2F" );
}
/* Copy C to Fortran */
for (i=0; i<MPI_STATUS_SIZE; i++)
f_status[i] = (MPI_Fint)c_status_arr[i];
return MPI_SUCCESS;
}
/*@
MPI_Comm_remote_group - Accesses the remote group associated with
the given inter-communicator
Input Parameter:
. comm - Communicator (must be intercommunicator)
Output Parameter:
. group - remote group of communicator
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
@*/
int MPI_Comm_remote_group ( MPI_Comm comm, MPI_Group *group )
{
struct MPIR_COMMUNICATOR *comm_ptr;
struct MPIR_GROUP *group_ptr;
int flag;
int mpi_errno = MPI_SUCCESS;
static char myname[] = "MPI_COMM_REMOTE_GROUP";
TR_PUSH(myname);
comm_ptr = MPIR_GET_COMM_PTR(comm);
MPIR_TEST_MPI_COMM(comm,comm_ptr,comm_ptr,myname );
/* Check for intra-communicator */
MPI_Comm_test_inter ( comm, &flag );
if (!flag) return MPIR_ERROR(comm_ptr,
MPIR_ERRCLASS_TO_CODE(MPI_ERR_COMM,MPIR_ERR_COMM_INTRA),myname);
MPIR_Group_dup( comm_ptr->group, &group_ptr );
*group = group_ptr->self;
TR_POP;
return (MPI_SUCCESS);
}
/*@
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 );
}
int MPIR_Err_setmsg( int errclass, int errkind,
const char *routine_name,
const char *generic_string,
const char *default_string, ... )
{
int error_ring_pos, error_ring_id;
const char *format; /* Even kind */
const char *def_format = ""; /* Odd kind */
va_list Argp;
va_start( Argp, default_string );
#else
/* This assumes old-style varargs support */
int MPIR_Err_setmsg( errclass, errkind, routine_name,
generic_string, default_string, va_alist )
int errclass, errkind;
const char *routine_name, *generic_string, *default_string;
va_dcl
{
int error_ring_pos, error_ring_id;
const char *format; /* Even kind */
const char *def_format = ""; /* Odd kind */
va_list Argp;
va_start( Argp );
#endif
_CheckForDebug();
/* thread lock */
error_ring_id = error_big_ring_pos++;
if (error_big_ring_pos > MAX_ERROR_BIGRING) error_big_ring_pos = 1;
/* thread unlock */
error_ring_pos = (error_ring_id % MAX_ERROR_RING);
/* thread unlock */
/* If errkind is ODD, and the number of arguments is > 0, then
we want to try for the EVEN errkind (1+ the cvalue from the code).
Otherwise, we want to use the default message (the input errkind)
*/
#ifdef FOO
/* To find the number of arguments, we need to look for a void*0? */
/* We actually need to know only if there ARE any arguments */
/* _numargs() is a Crayism that would be useful here */
if (_numargs() > 5) {
if (errkind & 0x1) errkind++;
}
#endif
/* In the odd kind case, get the two messages */
if (errkind & 0x1) {
#if defined(USE_NLS_CAT)
def_format = MPIR_GetNLSMsg( errclass, errkind, default_string );
format = MPIR_GetNLSMsg( errclass, errkind+1, default_string );
#else
def_format = (default_string) ? (default_string) :
MPIR_Get_error_string( MPIR_ERRCLASS_TO_CODE(errclass,errkind) );
format = MPIR_Get_error_string( MPIR_ERRCLASS_TO_CODE(errclass,errkind+1) );
#endif
}
else {
#if defined(USE_NLS_CAT)
format = MPIR_GetNLSMsg( errclass, errkind, default_string );
#else
if (!default_string)
format = MPIR_Get_error_string( MPIR_ERRCLASS_TO_CODE(errclass,errkind) );
else
format = default_string;
#endif
/* Here is a fallback for no message string */
if (!format)
format = generic_string;
}
/* Use format if there are args, else use def_format */
/* We need to replace this with code that is careful about the buffer
lengths. There is code like this in errmsg.c */
/* Grrr. There is no easy way to see if there *ARE* any args.
We need to place a boolean in the stdargs list that tells us
whether there are more values. */
if (0) {
strcpy( error_ring[error_ring_pos], def_format );
}
else {
if (format) {
vsprintf( error_ring[error_ring_pos], format, Argp );
}
else {
if (def_format) strcpy( error_ring[error_ring_pos], def_format );
else strcpy (error_ring[error_ring_pos], "No error message" );
}
}
error_ring_idx[error_ring_pos] = error_ring_id;
va_end( Argp );
if (DebugFlag) {
PRINTF( "Placed message (%d,%d) %s in %d\n",
errclass, errkind, error_ring[error_ring_pos],
error_ring_id );
}
return errclass | (errkind << MPIR_ERR_CLASS_BITS) |
(error_ring_id << (MPIR_ERR_CODE_BITS));
}
/*
* This routine maps a code that contains a reference to the error ring
* to the error ring text. If the code does not refer to the ring,
* it return null. If it does refer to the ring, but the value is lost
* (we've circled the ring at least once), it also returns null.
*/
char * MPIR_Err_map_code_to_string( int errcode )
{
int ring_pos, big_ring_pos;
_CheckForDebug();
big_ring_pos = errcode >> MPIR_ERR_CODE_BITS;
if (big_ring_pos > 0) {
ring_pos = (big_ring_pos % MAX_ERROR_RING);
/* Check that the indices match */
if (DebugFlag) {
PRINTF( "Looking for ring[%d] with big ring %d\n",
ring_pos, big_ring_pos );
}
if (error_ring_idx[ring_pos] == big_ring_pos) {
if (DebugFlag) {
PRINTF( "Found error message in ring %d: %s\n",
ring_pos, error_ring[ring_pos] );
}
return error_ring[ring_pos];
}
else if (DebugFlag) {
PRINTF( "error_ring_idx[%d] = %d != big_ring_pos = %d\n",
ring_pos, error_ring_idx[ring_pos], big_ring_pos );
}
}
else if (DebugFlag) {
PRINTF( "Errcode %x has ring position 0\n", errcode );
}
return 0;
}
/*@
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_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);
}