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