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-- */ }