void mpi_file_get_view_(MPI_Fint * fh, MPI_Offset * disp, MPI_Fint * etype,
MPI_Fint * filetype, char *datarep, MPI_Fint * ierr, int str_len)
{
MPI_File fh_c;
MPI_Datatype etype_c, filetype_c;
int i, tmpreplen;
char *tmprep;
if (datarep <= (char *) 0) {
FPRINTF(stderr, "MPI_File_get_view: datarep is an invalid address\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
tmprep = (char *) ADIOI_Malloc((MPI_MAX_DATAREP_STRING + 1) * sizeof(char));
fh_c = MPI_File_f2c(*fh);
*ierr = MPI_File_get_view(fh_c, disp, &etype_c, &filetype_c, tmprep);
tmpreplen = strlen(tmprep);
if (tmpreplen <= str_len) {
ADIOI_Strncpy(datarep, tmprep, tmpreplen);
/* blank pad the remaining space */
for (i = tmpreplen; i < str_len; i++)
datarep[i] = ' ';
} else {
/* not enough space */
ADIOI_Strncpy(datarep, tmprep, str_len);
/* this should be flagged as an error. */
*ierr = MPI_ERR_UNKNOWN;
}
*etype = MPI_Type_c2f(etype_c);
*filetype = MPI_Type_c2f(filetype_c);
ADIOI_Free(tmprep);
}
/*@C
PetscInitializeFortran - Routine that should be called soon AFTER
the call to PetscInitialize() if one is using a C main program
that calls Fortran routines that in turn call PETSc routines.
Collective on PETSC_COMM_WORLD
Level: beginner
Notes:
PetscInitializeFortran() initializes some of the default viewers,
communicators, etc. for use in the Fortran if a user's main program is
written in C. PetscInitializeFortran() is NOT needed if a user's main
program is written in Fortran; in this case, just calling
PetscInitialize() in the main (Fortran) program is sufficient.
.seealso: PetscInitialize()
.keywords: Mixing C and Fortran, passing PETSc objects to Fortran
@*/
PetscErrorCode PetscInitializeFortran(void)
{
MPI_Fint c1=0,c2=0;
if (PETSC_COMM_WORLD) c1 = MPI_Comm_c2f(PETSC_COMM_WORLD);
c2 = MPI_Comm_c2f(PETSC_COMM_SELF);
petscsetcommonblock_(&c1,&c2);
#if defined(PETSC_USE_REAL___FLOAT128)
{
MPI_Fint freal,fscalar,fsum;
freal = MPI_Type_c2f(MPIU_REAL);
fscalar = MPI_Type_c2f(MPIU_SCALAR);
fsum = MPI_Op_c2f(MPIU_SUM);
petscsetcommonblockmpi_(&freal,&fscalar,&fsum);
}
#endif
{
PetscReal pi = PETSC_PI;
PetscReal maxreal = PETSC_MAX_REAL;
PetscReal minreal = PETSC_MIN_REAL;
PetscReal eps = PETSC_MACHINE_EPSILON;
PetscReal seps = PETSC_SQRT_MACHINE_EPSILON;
PetscReal small = PETSC_SMALL;
PetscReal pinf = PETSC_INFINITY;
PetscReal pninf = PETSC_NINFINITY;
petscsetcommonblocknumeric_(&pi,&maxreal,&minreal,&eps,&seps,&small,&pinf,&pninf);
}
return 0;
}
void mpi_file_get_view_(MPI_Fint * fh, MPI_Offset * disp, MPI_Fint * etype,
MPI_Fint * filetype, _fcd datarep_fcd, MPI_Fint * ierr)
{
char *datarep = _fcdtocp(datarep_fcd);
int str_len = _fcdlen(datarep_fcd);
#else
/* Prototype to keep compiler happy */
FORTRAN_API void FORT_CALL mpi_file_get_view_(MPI_Fint * fh, MPI_Offset * disp, MPI_Fint * etype,
MPI_Fint * filetype,
char *datarep FORT_MIXED_LEN_DECL,
MPI_Fint * ierr FORT_END_LEN_DECL);
FORTRAN_API void FORT_CALL mpi_file_get_view_(MPI_Fint * fh, MPI_Offset * disp, MPI_Fint * etype,
MPI_Fint * filetype,
char *datarep FORT_MIXED_LEN(str_len),
MPI_Fint * ierr FORT_END_LEN(str_len))
{
#endif
MPI_File fh_c;
int i, tmpreplen;
MPI_Datatype etype_c, filetype_c;
char *tmprep;
/* Initialize the string to all blanks */
if (datarep <= (char *) 0) {
FPRINTF(stderr, "MPI_File_get_view: datarep is an invalid address\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
tmprep = (char *) ADIOI_Malloc((MPI_MAX_DATAREP_STRING + 1) * sizeof(char));
fh_c = MPI_File_f2c(*fh);
etype_c = MPI_Type_f2c(*etype);
filetype_c = MPI_Type_f2c(*filetype);
*ierr = MPI_File_get_view(fh_c, disp, &etype_c, &filetype_c, tmprep);
tmpreplen = strlen(tmprep);
if (tmpreplen <= str_len) {
ADIOI_Strncpy(datarep, tmprep, tmpreplen);
/* blank pad the remaining space */
for (i = tmpreplen; i < str_len; i++)
datarep[i] = ' ';
} else {
/* not enough space */
ADIOI_Strncpy(datarep, tmprep, str_len);
/* this should be flagged as an error. */
*ierr = MPI_ERR_UNKNOWN;
}
*etype = MPI_Type_c2f(etype_c);
*filetype = MPI_Type_c2f(filetype_c);
ADIOI_Free(tmprep);
}
void ompi_type_create_subarray_f(MPI_Fint *ndims, MPI_Fint *size_array,
MPI_Fint *subsize_array,
MPI_Fint *start_array, MPI_Fint *order,
MPI_Fint *oldtype, MPI_Fint *newtype,
MPI_Fint *ierr)
{
int c_ierr;
MPI_Datatype c_old;
MPI_Datatype c_new;
OMPI_ARRAY_NAME_DECL(size_array);
OMPI_ARRAY_NAME_DECL(subsize_array);
OMPI_ARRAY_NAME_DECL(start_array);
c_old = MPI_Type_f2c(*oldtype);
OMPI_ARRAY_FINT_2_INT(size_array, *ndims);
OMPI_ARRAY_FINT_2_INT(subsize_array, *ndims);
OMPI_ARRAY_FINT_2_INT(start_array, *ndims);
c_ierr = MPI_Type_create_subarray(OMPI_FINT_2_INT(*ndims),
OMPI_ARRAY_NAME_CONVERT(size_array),
OMPI_ARRAY_NAME_CONVERT(subsize_array),
OMPI_ARRAY_NAME_CONVERT(start_array),
*order, c_old, &c_new);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
if (MPI_SUCCESS == c_ierr) {
*newtype = MPI_Type_c2f(c_new);
}
OMPI_ARRAY_FINT_2_INT_CLEANUP(size_array);
OMPI_ARRAY_FINT_2_INT_CLEANUP(subsize_array);
OMPI_ARRAY_FINT_2_INT_CLEANUP(start_array);
}
void ompi_type_indexed_f(MPI_Fint *count, MPI_Fint *array_of_blocklengths,
MPI_Fint *array_of_displacements, MPI_Fint *oldtype,
MPI_Fint *newtype, MPI_Fint *ierr)
{
int c_ierr;
MPI_Datatype c_old = MPI_Type_f2c(*oldtype);
MPI_Datatype c_new;
OMPI_ARRAY_NAME_DECL(array_of_blocklengths);
OMPI_ARRAY_NAME_DECL(array_of_displacements);
OMPI_ARRAY_FINT_2_INT(array_of_blocklengths, *count);
OMPI_ARRAY_FINT_2_INT(array_of_displacements, *count);
c_ierr = MPI_Type_indexed(OMPI_FINT_2_INT(*count),
OMPI_ARRAY_NAME_CONVERT(array_of_blocklengths),
OMPI_ARRAY_NAME_CONVERT(array_of_displacements),
c_old, &c_new);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
OMPI_ARRAY_FINT_2_INT_CLEANUP(array_of_blocklengths);
OMPI_ARRAY_FINT_2_INT_CLEANUP(array_of_displacements);
if (MPI_SUCCESS == c_ierr) {
*newtype = MPI_Type_c2f(c_new);
}
}
int f2ctype_(MPI_Fint * fhandle, MPI_Fint * typeidx)
{
int errs = 0;
MPI_Datatype ctype;
/* printf("Testing %s\n", mpi_names[*typeidx].name); */
ctype = MPI_Type_f2c(*fhandle);
if (ctype != mpi_names[*typeidx].dtype) {
char mytypename[MPI_MAX_OBJECT_NAME];
int mytypenamelen;
/* An implementation is not *required* to deliver the
* corresponding C version of the MPI Datatype bit-for-bit. But
* if *must* act like it - e.g., the datatype name must be the same */
MPI_Type_get_name(ctype, mytypename, &mytypenamelen);
if (strcmp(mytypename, mpi_names[*typeidx].name) != 0 &&
/* LONG_LONG is a synonym of LONG_LONG_INT, thus LONG_LONG_INT is also a vaild name */
(ctype != MPI_LONG_LONG || strcmp(mytypename, "MPI_LONG_LONG_INT") != 0)) {
errs++;
printf("C and Fortran types for %s (c name is %s) do not match f=%d, ctof=%d.\n",
mpi_names[*typeidx].name, mytypename, *fhandle, MPI_Type_c2f(ctype));
}
}
return errs;
}
/* Definitions of Fortran Wrapper routines */
FORTRAN_API void FORT_CALL mpi_type_create_subarray_(MPI_Fint *ndims, MPI_Fint *array_of_sizes,
MPI_Fint *array_of_subsizes,
MPI_Fint *array_of_starts, MPI_Fint *order,
MPI_Fint *oldtype, MPI_Fint *newtype,
MPI_Fint *__ierr )
{
int i;
int *l_array_of_sizes = 0;
int local_l_array_of_sizes[MPIR_USE_LOCAL_ARRAY];
int *l_array_of_subsizes = 0;
int local_l_array_of_subsizes[MPIR_USE_LOCAL_ARRAY];
int *l_array_of_starts = 0;
int local_l_array_of_starts[MPIR_USE_LOCAL_ARRAY];
MPI_Datatype oldtype_c, newtype_c;
oldtype_c = MPI_Type_f2c(*oldtype);
if ((int)*ndims > 0) {
if ((int)*ndims > MPIR_USE_LOCAL_ARRAY) {
MPIR_FALLOC(l_array_of_sizes,(int *) MALLOC( *ndims * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_TYPE_CREATE_SUBARRAY" );
MPIR_FALLOC(l_array_of_subsizes,(int *) MALLOC( *ndims * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_TYPE_CREATE_SUBARRAY" );
MPIR_FALLOC(l_array_of_starts,(int *) MALLOC( *ndims * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_TYPE_CREATE_SUBARRAY" );
}
else {
l_array_of_sizes = local_l_array_of_sizes;
l_array_of_subsizes = local_l_array_of_subsizes;
l_array_of_starts = local_l_array_of_starts;
}
for (i=0; i<(int)*ndims; i++) {
l_array_of_sizes[i] = (int)array_of_sizes[i];
l_array_of_subsizes[i] = (int)array_of_subsizes[i];
l_array_of_starts[i] = (int)array_of_starts[i];
}
}
*__ierr = MPI_Type_create_subarray((int)*ndims, l_array_of_sizes,
l_array_of_subsizes, l_array_of_starts,
(int)*order, oldtype_c, &newtype_c);
if ((int)*ndims > MPIR_USE_LOCAL_ARRAY) {
FREE( l_array_of_sizes );
FREE( l_array_of_subsizes );
FREE( l_array_of_starts );
}
if (*__ierr == MPI_SUCCESS)
*newtype = MPI_Type_c2f(newtype_c);
}
/*
* C->Fortran intercept for the extent calculation.
*/
static int extent_intercept_fn(MPI_Datatype type_c, MPI_Aint *file_extent_f77,
void *extra_state)
{
MPI_Fint ierr, type_f77 = MPI_Type_c2f(type_c);
intercept_extra_state_t *intercept_data =
(intercept_extra_state_t*) extra_state;
intercept_data->extent_fn_f77(&type_f77, file_extent_f77,
intercept_data->extra_state_f77, &ierr);
return OMPI_FINT_2_INT(ierr);
}
void mpi_type_dup_f(MPI_Fint *type, MPI_Fint *newtype, MPI_Fint *ierr)
{
MPI_Datatype c_type = MPI_Type_f2c(*type);
MPI_Datatype c_new;
*ierr = OMPI_INT_2_FINT(MPI_Type_dup(c_type, &c_new));
if (MPI_SUCCESS == OMPI_FINT_2_INT(*ierr)) {
*newtype = MPI_Type_c2f(c_new);
}
}
void mpi_type_create_subarray_(int *ndims,int *array_of_sizes,
int *array_of_subsizes,int *array_of_starts,
int *order,MPI_Fint *oldtype,
MPI_Fint *newtype, int *__ierr )
{
MPI_Datatype oldtype_c, newtype_c;
oldtype_c = MPI_Type_f2c(*oldtype);
*__ierr = MPI_Type_create_subarray(*ndims,array_of_sizes,array_of_subsizes,array_of_starts,*order,oldtype_c,&newtype_c);
*newtype = MPI_Type_c2f(newtype_c);
}
void mpi_type_contiguous_f(MPI_Fint *count, MPI_Fint *oldtype,
MPI_Fint *newtype, MPI_Fint *ierr)
{
MPI_Datatype c_old = MPI_Type_f2c(*oldtype);
MPI_Datatype c_new;
*ierr = OMPI_INT_2_FINT(MPI_Type_contiguous(OMPI_FINT_2_INT(*count),
c_old, &c_new));
if (MPI_SUCCESS == OMPI_FINT_2_INT(*ierr)) {
*newtype = MPI_Type_c2f(c_new);
}
}
void ompi_file_get_view_f(MPI_Fint *fh, MPI_Offset *disp,
MPI_Fint *etype, MPI_Fint *filetype,
char *datarep, MPI_Fint *ierr, int datarep_len)
{
int c_ierr;
MPI_File c_fh = MPI_File_f2c(*fh);
MPI_Datatype c_etype, c_filetype;
MPI_Offset c_disp;
char c_datarep[MPI_MAX_DATAREP_STRING];
c_ierr = MPI_File_get_view(c_fh, &c_disp, &c_etype,
&c_filetype, c_datarep);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
if (MPI_SUCCESS == c_ierr) {
*disp = (MPI_Offset) c_disp;
*etype = MPI_Type_c2f(c_etype);
*filetype = MPI_Type_c2f(c_filetype);
ompi_fortran_string_c2f(c_datarep, datarep, datarep_len);
}
}
/*
* C->Fortran intercept for the write conversion.
*/
static int write_intercept_fn(void *userbuf, MPI_Datatype type_c, int count_c,
void *filebuf, MPI_Offset position,
void *extra_state)
{
MPI_Fint ierr, count_f77 = OMPI_FINT_2_INT(count_c);
MPI_Fint type_f77 = MPI_Type_c2f(type_c);
intercept_extra_state_t *intercept_data =
(intercept_extra_state_t*) extra_state;
intercept_data->write_fn_f77(userbuf, &type_f77, &count_f77, filebuf,
&position, intercept_data->extra_state_f77,
&ierr);
return OMPI_FINT_2_INT(ierr);
}
void mpi_type_create_darray_(int *size,int *rank,int *ndims,
int *array_of_gsizes,int *array_of_distribs,
int *array_of_dargs,int *array_of_psizes,
int *order, MPI_Fint *oldtype,
MPI_Fint *newtype, int *__ierr )
{
MPI_Datatype oldtype_c, newtype_c;
oldtype_c = MPI_Type_f2c(*oldtype);
*__ierr = MPI_Type_create_darray(*size,*rank,*ndims,array_of_gsizes,array_of_distribs,array_of_dargs,array_of_psizes,*order,oldtype_c,&newtype_c);
*newtype = MPI_Type_c2f(newtype_c);
}
void ompi_type_create_f90_real_f(MPI_Fint *p, MPI_Fint *r,
MPI_Fint *newtype, MPI_Fint *ierr)
{
int c_ierr;
MPI_Datatype c_new = MPI_Type_f2c(*newtype);
c_ierr = MPI_Type_create_f90_real(OMPI_FINT_2_INT(*p),
OMPI_FINT_2_INT(*r),
&c_new);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
if (MPI_SUCCESS == c_ierr) {
*newtype = MPI_Type_c2f(c_new);
}
}
void mpi_type_hvector_f(MPI_Fint *count, MPI_Fint *blocklength,
MPI_Fint *stride, MPI_Fint *oldtype,
MPI_Fint *newtype, MPI_Fint *ierr)
{
MPI_Datatype c_oldtype, c_newtype;
c_oldtype = MPI_Type_f2c(*oldtype);
*ierr = OMPI_INT_2_FINT(MPI_Type_hvector(OMPI_FINT_2_INT(*count),
OMPI_FINT_2_INT(*blocklength),
(MPI_Aint)*stride,
c_oldtype, &c_newtype));
if( MPI_SUCCESS == OMPI_FINT_2_INT(*ierr) ) {
*newtype = MPI_Type_c2f(c_newtype);
}
}
void ompi_type_create_hvector_f(MPI_Fint *count, MPI_Fint *blocklength,
MPI_Aint *stride, MPI_Fint *oldtype,
MPI_Fint *newtype, MPI_Fint *ierr)
{
int c_ierr;
MPI_Datatype c_old = MPI_Type_f2c(*oldtype);
MPI_Datatype c_new;
c_ierr = MPI_Type_hvector(OMPI_FINT_2_INT(*count),
OMPI_FINT_2_INT(*blocklength),
*stride,
c_old, &c_new);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
if (MPI_SUCCESS == c_ierr) {
*newtype = MPI_Type_c2f(c_new);
}
}
void ompi_type_create_darray_f(MPI_Fint *size, MPI_Fint *rank,
MPI_Fint *ndims, MPI_Fint *gsize_array,
MPI_Fint *distrib_array, MPI_Fint *darg_array,
MPI_Fint *psize_array, MPI_Fint *order,
MPI_Fint *oldtype, MPI_Fint *newtype,
MPI_Fint *ierr)
{
int c_ierr;
MPI_Datatype c_old = MPI_Type_f2c(*oldtype);
MPI_Datatype c_new;
OMPI_ARRAY_NAME_DECL(gsize_array);
OMPI_ARRAY_NAME_DECL(distrib_array);
OMPI_ARRAY_NAME_DECL(darg_array);
OMPI_ARRAY_NAME_DECL(psize_array);
OMPI_ARRAY_FINT_2_INT(gsize_array, *ndims);
OMPI_ARRAY_FINT_2_INT(distrib_array, *ndims);
OMPI_ARRAY_FINT_2_INT(darg_array, *ndims);
OMPI_ARRAY_FINT_2_INT(psize_array, *ndims);
c_ierr = MPI_Type_create_darray(OMPI_FINT_2_INT(*size),
OMPI_FINT_2_INT(*rank),
OMPI_FINT_2_INT(*ndims),
OMPI_ARRAY_NAME_CONVERT(gsize_array),
OMPI_ARRAY_NAME_CONVERT(distrib_array),
OMPI_ARRAY_NAME_CONVERT(darg_array),
OMPI_ARRAY_NAME_CONVERT(psize_array),
OMPI_FINT_2_INT(*order), c_old, &c_new);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
OMPI_ARRAY_FINT_2_INT_CLEANUP(gsize_array);
OMPI_ARRAY_FINT_2_INT_CLEANUP(distrib_array);
OMPI_ARRAY_FINT_2_INT_CLEANUP(darg_array);
OMPI_ARRAY_FINT_2_INT_CLEANUP(psize_array);
if (MPI_SUCCESS == c_ierr) {
*newtype = MPI_Type_c2f(c_new);
}
}
/* Definitions of Fortran Wrapper routines */
EXPORT_MPI_API void FORTRAN_API mpi_type_get_contents_(MPI_Fint *datatype, MPI_Fint *max_integers, MPI_Fint *max_addresses, MPI_Fint *max_datatypes,
MPI_Fint *array_of_integers, MPI_Fint *array_of_addresses, MPI_Fint *array_of_datatypes, MPI_Fint *__ierr )
{
int i;
int *l_array_of_integers;
MPI_Aint *l_array_of_addresses;
MPI_Datatype *l_array_of_datatypes;
MPIR_FALLOC(l_array_of_integers, (int*)MALLOC(sizeof(int)* (int)*
max_integers), MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_TYPE_GET_CONTENTS");
MPIR_FALLOC(l_array_of_addresses, (MPI_Aint *)MALLOC(sizeof(MPI_Aint) *
(int)*max_addresses), MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_TYPE_GET_CONTENTS");
MPIR_FALLOC(l_array_of_datatypes, (MPI_Datatype *)MALLOC(sizeof
(MPI_Datatype) * (int)*max_datatypes), MPIR_COMM_WORLD,
MPI_ERR_EXHAUSTED, "MPI_TYPE_GET_CONTENTS");
*__ierr = MPI_Type_get_contents( MPI_Type_f2c(*datatype),
(int)*max_integers,
(int)*max_addresses,
(int)*max_datatypes,
l_array_of_integers,
l_array_of_addresses,
l_array_of_datatypes );
for (i=0; i<(int)*max_integers; i++)
array_of_integers[i] = (MPI_Fint)l_array_of_integers[i];
for (i=0; i<(int)*max_addresses; i++)
array_of_addresses[i] = (MPI_Aint)l_array_of_addresses[i];
for (i=0; i<(int)*max_datatypes; i++)
array_of_datatypes[i] = MPI_Type_c2f(l_array_of_datatypes[i]);
FREE( l_array_of_integers );
FREE( l_array_of_addresses );
FREE( l_array_of_datatypes );
}
EXPORT_MPI_API void FORTRAN_API mpi_type_indexed_( MPI_Fint *count, MPI_Fint blocklens[], MPI_Fint indices[], MPI_Fint *old_type, MPI_Fint *newtype, MPI_Fint *__ierr )
{
int i;
int *l_blocklens = 0;
int local_l_blocklens[MPIR_USE_LOCAL_ARRAY];
int *l_indices = 0;
int local_l_indices[MPIR_USE_LOCAL_ARRAY];
MPI_Datatype ldatatype;
static char myname[] = "MPI_TYPE_INDEXED";
if ((int)*count > 0) {
if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
MPIR_FALLOC(l_blocklens,(int *) MALLOC( *count * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
MPIR_FALLOC(l_indices,(int *) MALLOC( *count * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
}
else {
l_blocklens = local_l_blocklens;
l_indices = local_l_indices;
}
for (i=0; i<(int)*count; i++) {
l_indices[i] = (int)indices[i];
l_blocklens[i] = (int)blocklens[i];
}
}
*__ierr = MPI_Type_indexed((int)*count, l_blocklens, l_indices,
MPI_Type_f2c(*old_type),
&ldatatype);
if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
FREE( l_indices );
FREE( l_blocklens );
}
*newtype = MPI_Type_c2f(ldatatype);
}
void mpi_type_create_hindexed_f(MPI_Fint *count,
MPI_Fint *array_of_blocklengths,
MPI_Aint *array_of_displacements,
MPI_Fint *oldtype, MPI_Fint *newtype,
MPI_Fint *ierr)
{
MPI_Datatype c_old = MPI_Type_f2c(*oldtype);
MPI_Datatype c_new = MPI_Type_f2c(*newtype);
OMPI_ARRAY_NAME_DECL(array_of_blocklengths);
OMPI_ARRAY_FINT_2_INT(array_of_blocklengths, *count);
*ierr = OMPI_INT_2_FINT(MPI_Type_create_hindexed(OMPI_FINT_2_INT(*count),
OMPI_ARRAY_NAME_CONVERT(array_of_blocklengths),
array_of_displacements, c_old,
&c_new));
if (MPI_SUCCESS == OMPI_FINT_2_INT(*ierr)) {
*newtype = MPI_Type_c2f(c_new);
}
OMPI_ARRAY_FINT_2_INT_CLEANUP(array_of_blocklengths);
}
void f2ctype_( MPI_Fint * type )
{
*type = MPI_Type_c2f( MPI_INTEGER );
}
/* Definitions of Fortran Wrapper routines */
EXPORT_MPI_API void FORTRAN_API mpi_type_create_darray_(MPI_Fint *size, MPI_Fint *rank, MPI_Fint *ndims,
MPI_Fint *array_of_gsizes,
MPI_Fint *array_of_distribs,
MPI_Fint *array_of_dargs,
MPI_Fint *array_of_psizes, MPI_Fint *order,
MPI_Fint *oldtype, MPI_Fint *newtype,
MPI_Fint *__ierr )
{
int i;
int *l_array_of_gsizes;
int local_l_array_of_gsizes[MPIR_USE_LOCAL_ARRAY];
int *l_array_of_distribs;
int local_l_array_of_distribs[MPIR_USE_LOCAL_ARRAY];
int *l_array_of_dargs;
int local_l_array_of_dargs[MPIR_USE_LOCAL_ARRAY];
int *l_array_of_psizes;
int local_l_array_of_psizes[MPIR_USE_LOCAL_ARRAY];
MPI_Datatype oldtype_c, newtype_c;
oldtype_c = MPI_Type_f2c(*oldtype);
if ((int)*ndims > 0) {
if ((int)*ndims > MPIR_USE_LOCAL_ARRAY) {
MPIR_FALLOC(l_array_of_gsizes,(int *) MALLOC( *ndims * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_TYPE_CREATE_DARRAY" );
MPIR_FALLOC(l_array_of_distribs,(int *) MALLOC( *ndims * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_TYPE_CREATE_DARRAY" );
MPIR_FALLOC(l_array_of_dargs,(int *) MALLOC( *ndims * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_TYPE_CREATE_DARRAY" );
MPIR_FALLOC(l_array_of_psizes,(int *) MALLOC( *ndims * sizeof(int) ),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_TYPE_CREATE_DARRAY" );
}
else {
l_array_of_gsizes = local_l_array_of_gsizes;
l_array_of_distribs = local_l_array_of_distribs;
l_array_of_dargs = local_l_array_of_dargs;
l_array_of_psizes = local_l_array_of_psizes;
}
for (i=0; i<(int)*ndims; i++) {
l_array_of_gsizes[i] = (int)array_of_gsizes[i];
l_array_of_distribs[i] = (int)array_of_distribs[i];
l_array_of_dargs[i] = (int)array_of_dargs[i];
l_array_of_psizes[i] = (int)array_of_psizes[i];
}
}
*__ierr = MPI_Type_create_darray((int)*size, (int)*rank, (int)*ndims,
l_array_of_gsizes, l_array_of_distribs,
l_array_of_dargs, l_array_of_psizes,
(int)*order, oldtype_c, &newtype_c);
if ((int)*ndims > MPIR_USE_LOCAL_ARRAY) {
FREE( l_array_of_gsizes );
FREE( l_array_of_distribs );
FREE( l_array_of_dargs );
FREE( l_array_of_psizes );
}
*newtype = MPI_Type_c2f(newtype_c);
}
