int MPIR_Create_unnamed_predefined(MPI_Datatype old, int combiner,
int r, int p, MPI_Datatype * new_ptr)
{
int i;
int mpi_errno = MPI_SUCCESS;
F90Predefined *type;
*new_ptr = MPI_DATATYPE_NULL;
/* Has this type been defined already? */
for (i = 0; i < nAlloc; i++) {
type = &f90Types[i];
if (type->combiner == combiner && type->r == r && type->p == p) {
*new_ptr = type->d;
return mpi_errno;
}
}
/* Create a new type and remember it */
if (nAlloc >= MAX_F90_TYPES) {
return MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE,
"MPIF_Create_unnamed_predefined", __LINE__,
MPI_ERR_INTERN, "**f90typetoomany", 0);
}
if (nAlloc == 0) {
/* Install the finalize callback that frees these datatyeps.
* Set the priority high enough that this will be executed
* before the handle allocation check */
MPIR_Add_finalize(MPIR_FreeF90Datatypes, 0, 2);
}
type = &f90Types[nAlloc++];
type->combiner = combiner;
type->r = r;
type->p = p;
/* Create a contiguous type from one instance of the named type */
mpi_errno = MPIR_Type_contiguous(1, old, &type->d);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* Initialize the contents data */
{
MPIR_Datatype *new_dtp = NULL;
int vals[2];
int nvals = 0;
switch (combiner) {
case MPI_COMBINER_F90_INTEGER:
nvals = 1;
vals[0] = r;
break;
case MPI_COMBINER_F90_REAL:
case MPI_COMBINER_F90_COMPLEX:
nvals = 2;
vals[0] = p;
vals[1] = r;
break;
}
MPIR_Datatype_get_ptr(type->d, new_dtp);
mpi_errno = MPIR_Datatype_set_contents(new_dtp, combiner, nvals, 0, 0, vals, NULL, NULL);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* FIXME should we be setting type->is_permanent=TRUE here too? If so,
* will the cleanup code handle it correctly and not freak out? */
#ifndef NDEBUG
{
MPI_Datatype old_basic = MPI_DATATYPE_NULL;
MPI_Datatype new_basic = MPI_DATATYPE_NULL;
/* we used MPIR_Type_contiguous and then stomped it's contents
* information, so make sure that the basic_type is usable by
* MPIR_Type_commit */
MPIR_Datatype_get_basic_type(old, old_basic);
MPIR_Datatype_get_basic_type(new_dtp->handle, new_basic);
MPIR_Assert(new_basic == old_basic);
}
#endif
/* the MPI Standard requires that these types are pre-committed
* (MPI-2.2, sec 16.2.5, pg 492) */
mpi_errno = MPIR_Type_commit(&type->d);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
*new_ptr = type->d;
fn_fail:
return mpi_errno;
}
/*@
MPI_Type_dup - Duplicate a datatype
Input Parameters:
. oldtype - datatype (handle)
Output Parameters:
. newtype - copy of type (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
@*/
int MPI_Type_dup(MPI_Datatype oldtype, MPI_Datatype * newtype)
{
int mpi_errno = MPI_SUCCESS;
MPI_Datatype new_handle;
MPIR_Datatype *datatype_ptr = NULL;
MPIR_Datatype *new_dtp;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_DUP);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_DUP);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif
/* Convert MPI object handles to object pointers */
MPIR_Datatype_get_ptr(oldtype, datatype_ptr);
/* Convert MPI object handles to object pointers */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate datatype_ptr */
MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno);
/* If comm_ptr is not valid, it will be reset to null */
MPIR_ERRTEST_ARGNULL(newtype, "newtype", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
MPIR_Assert(datatype_ptr != NULL);
/* ... body of routine ... */
mpi_errno = MPIR_Type_dup(oldtype, &new_handle);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
MPIR_Datatype_get_ptr(new_handle, new_dtp);
mpi_errno = MPIR_Datatype_set_contents(new_dtp, MPI_COMBINER_DUP, 0, /* ints */
0, /* aints */
1, /* types */
NULL, NULL, &oldtype);
mpi_errno = MPIR_Type_commit(&new_handle);
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
/* Copy attributes, executing the attribute copy functions */
/* This accesses the attribute dup function through the perprocess
* structure to prevent type_dup from forcing the linking of the
* attribute functions. The actual function is (by default)
* MPIR_Attr_dup_list
*/
if (mpi_errno == MPI_SUCCESS && MPIR_Process.attr_dup) {
new_dtp->attributes = 0;
mpi_errno = MPIR_Process.attr_dup(oldtype, datatype_ptr->attributes, &new_dtp->attributes);
if (mpi_errno) {
MPIR_Datatype_ptr_release(new_dtp);
goto fn_fail;
}
}
MPIR_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_DUP);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
*newtype = MPI_DATATYPE_NULL;
#ifdef HAVE_ERROR_CHECKING
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER,
"**mpi_type_dup", "**mpi_type_dup %D %p", oldtype, newtype);
}
#endif
mpi_errno = MPIR_Err_return_comm(NULL, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
