/* 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);
}
EXPORT_MPI_API void FORTRAN_API mpi_dims_create_(MPI_Fint *nnodes, MPI_Fint *ndims, MPI_Fint *dims, MPI_Fint *__ierr )
{
if (sizeof(MPI_Fint) == sizeof(int))
*__ierr = MPI_Dims_create(*nnodes,*ndims,dims);
else {
int *ldims;
int i;
MPIR_FALLOC(ldims,(int*)MALLOC(sizeof(int)* (int)*ndims),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_Dims_create");
for (i=0; i<(int)*ndims; i++)
ldims[i] = (int)dims[i];
*__ierr = MPI_Dims_create((int)*nnodes, (int)*ndims, ldims);
for (i=0; i<(int)*ndims; i++)
dims[i] = (MPI_Fint)ldims[i];
FREE( ldims );
}
}
FORTRAN_API void FORT_CALL mpi_group_excl_ ( MPI_Fint *group, MPI_Fint *n, MPI_Fint *ranks, MPI_Fint *newgroup, MPI_Fint *__ierr )
{
MPI_Group l_newgroup;
if (sizeof(MPI_Fint) == sizeof(int))
*__ierr = MPI_Group_excl( MPI_Group_f2c(*group), *n, ranks,
&l_newgroup );
else {
int *l_ranks;
int i;
MPIR_FALLOC(l_ranks,(int*)MALLOC(sizeof(int)* (int)*n),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_Group_excl");
for (i=0; i<*n; i++)
l_ranks[i] = (int)ranks[i];
*__ierr = MPI_Group_excl( MPI_Group_f2c(*group), (int)*n, l_ranks,
&l_newgroup );
FREE( l_ranks );
}
if (*__ierr == MPI_SUCCESS)
*newgroup = MPI_Group_c2f(l_newgroup);
}
/* See the comments in group_rinclf.c. ranges is correct without changes */
EXPORT_MPI_API void FORTRAN_API mpi_group_range_excl_ ( MPI_Fint *group, MPI_Fint *n, MPI_Fint ranges[][3], MPI_Fint *newgroup, MPI_Fint *__ierr )
{
MPI_Group l_newgroup;
if (sizeof(MPI_Fint) == sizeof(int))
*__ierr = MPI_Group_range_excl(MPI_Group_f2c(*group),*n,
ranges, &l_newgroup);
else {
int *l_ranges;
int i;
int j = 0;
MPIR_FALLOC(l_ranges,(int*)MALLOC(sizeof(int)* ((int)*n * 3)),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_Group_range_excl");
for (i=0; i<*n; i++) {
l_ranges[j++] = (int)ranges[i][0];
l_ranges[j++] = (int)ranges[i][1];
l_ranges[j++] = (int)ranges[i][2];
}
*__ierr = MPI_Group_range_excl(MPI_Group_f2c(*group), (int)*n,
(int (*)[3])l_ranges, &l_newgroup);
FREE( l_ranges );
}
*newgroup = MPI_Group_c2f(l_newgroup);
}
FORTRAN_API void FORT_CALL mpi_waitall_(MPI_Fint *count, MPI_Fint array_of_requests[], MPI_Fint array_of_statuses[][MPI_STATUS_SIZE], MPI_Fint *__ierr )
{
int i;
MPI_Request *lrequest = 0;
MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
MPI_Status *c_status = 0;
MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];
if ((int)*count > 0) {
if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
MPIR_FALLOC(lrequest,(MPI_Request*)MALLOC(sizeof(MPI_Request) *
(int)*count), MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_WAITALL" );
MPIR_FALLOC(c_status,(MPI_Status*)MALLOC(sizeof(MPI_Status) *
(int)*count), MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_WAITALL" );
}
else {
lrequest = local_lrequest;
c_status = local_c_status;
}
for (i=0; i<(int)*count; i++) {
lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
}
*__ierr = MPI_Waitall((int)*count,lrequest,c_status);
/* By checking for lrequest[i] = 0, we handle persistant requests */
for (i=0; i<(int)*count; i++) {
array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
}
}
else
*__ierr = MPI_Waitall((int)*count,(MPI_Request *)0, c_status );
if (*__ierr == MPI_SUCCESS)
for (i=0; i<(int)*count; i++)
MPI_Status_c2f(&(c_status[i]), &(array_of_statuses[i][0]) );
if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
FREE( lrequest );
FREE( c_status );
}
}
/* 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);
}
/* 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);
}
FORTRAN_API void FORT_CALL mpi_waitsome_( MPI_Fint *incount, MPI_Fint array_of_requests[], MPI_Fint *outcount, MPI_Fint array_of_indices[],
MPI_Fint array_of_statuses[][MPI_STATUS_SIZE], MPI_Fint *__ierr )
{
int i,j,found;
int loutcount;
int *l_indices = 0;
int local_l_indices[MPIR_USE_LOCAL_ARRAY];
MPI_Request *lrequest = 0;
MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
MPI_Status * c_status = 0;
MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];
if ((int)*incount > 0) {
if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
MPIR_FALLOC(lrequest,(MPI_Request*)MALLOC(sizeof(MPI_Request)* (int)*incount),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_WAITSOME" );
MPIR_FALLOC(l_indices,(int*)MALLOC(sizeof(int)* (int)*incount),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_WAITSOME" );
MPIR_FALLOC(c_status,(MPI_Status*)MALLOC(sizeof(MPI_Status)* (int)*incount),
MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
"MPI_WAITSOME" );
}
else {
lrequest = local_lrequest;
l_indices = local_l_indices;
c_status = local_c_status;
}
for (i=0; i<(int)*incount; i++)
lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
*__ierr = MPI_Waitsome((int)*incount,lrequest,&loutcount,l_indices,
c_status);
/* By checking for lrequest[l_indices[i]] = 0,
we handle persistant requests */
for (i=0; i<(int)*incount; i++) {
if ( i < loutcount) {
if (l_indices[i] >= 0) {
array_of_requests[l_indices[i]] =
MPI_Request_c2f( lrequest[l_indices[i]] );
}
}
else {
found = 0;
j = 0;
while ( (!found) && (j<loutcount) ) {
if (l_indices[j++] == i)
found = 1;
}
if (!found)
array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
}
}
}
else
*__ierr = MPI_Waitsome( (int)*incount, (MPI_Request *)0, &loutcount,
l_indices, c_status );
if (*__ierr != MPI_SUCCESS) return;
for (i=0; i<loutcount; i++) {
MPI_Status_c2f( &c_status[i], &(array_of_statuses[i][0]) );
if (l_indices[i] >= 0)
array_of_indices[i] = l_indices[i] + 1;
}
*outcount = (MPI_Fint)loutcount;
if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
FREE( l_indices );
FREE( lrequest );
FREE( c_status );
}
}
