void mpi_info_get_valuelen_f(MPI_Fint *info, char *key,
MPI_Fint *valuelen, MPI_Flogical *flag,
MPI_Fint *ierr, int key_len)
{
int c_err, ret;
MPI_Info c_info;
char *c_key;
OMPI_SINGLE_NAME_DECL(valuelen);
OMPI_LOGICAL_NAME_DECL(flag);
if (OMPI_SUCCESS != (ret = ompi_fortran_string_f2c(key, key_len, &c_key))) {
c_err = OMPI_ERRHANDLER_INVOKE(MPI_COMM_WORLD, ret, FUNC_NAME);
*ierr = OMPI_INT_2_FINT(c_err);
return;
}
c_info = MPI_Info_f2c(*info);
*ierr = OMPI_INT_2_FINT(MPI_Info_get_valuelen(c_info, c_key,
OMPI_SINGLE_NAME_CONVERT(valuelen),
OMPI_LOGICAL_SINGLE_NAME_CONVERT(flag)));
if (MPI_SUCCESS == OMPI_FINT_2_INT(*ierr)) {
OMPI_SINGLE_INT_2_FINT(valuelen);
OMPI_SINGLE_INT_2_LOGICAL(flag);
}
free(c_key);
}
void mpi_file_delete_(_fcd filename_fcd, MPI_Fint *info, MPI_Fint *ierr)
{
char *filename = _fcdtocp(filename_fcd);
int str_len = _fcdlen(filename_fcd);
#else
FORTRAN_API void FORT_CALL mpi_file_delete_(char *filename FORT_MIXED_LEN(str_len), MPI_Fint *info, MPI_Fint *ierr FORT_END_LEN(str_len))
{
#endif
char *newfname;
int real_len, i;
MPI_Info info_c;
info_c = MPI_Info_f2c(*info);
/* strip trailing blanks */
if (filename <= (char *) 0) {
FPRINTF(stderr, "MPI_File_delete: filename is an invalid address\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
for (i=str_len-1; i>=0; i--) if (filename[i] != ' ') break;
if (i < 0) {
FPRINTF(stderr, "MPI_File_delete: filename is a blank string\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
real_len = i + 1;
newfname = (char *) ADIOI_Malloc((real_len+1)*sizeof(char));
strncpy(newfname, filename, real_len);
newfname[real_len] = '\0';
*ierr = MPI_File_delete(newfname, info_c);
ADIOI_Free(newfname);
}
void mpi_file_set_view_f(MPI_Fint *fh, MPI_Offset *disp,
MPI_Fint *etype, MPI_Fint *filetype,
char *datarep, MPI_Fint *info, MPI_Fint *ierr,
int datarep_len)
{
MPI_File c_fh = MPI_File_f2c(*fh);
MPI_Datatype c_etype = MPI_Type_f2c(*etype);
MPI_Datatype c_filetype = MPI_Type_f2c(*filetype);
MPI_Info c_info = MPI_Info_f2c(*info);
char *c_datarep;
int c_err, ret;
/* Convert the fortran string */
if (OMPI_SUCCESS != (ret = ompi_fortran_string_f2c(datarep, datarep_len,
&c_datarep))) {
c_err = OMPI_ERRHANDLER_INVOKE(c_fh, ret, "MPI_FILE_SET_VIEW");
*ierr = OMPI_INT_2_FINT(c_err);
return;
}
*ierr = OMPI_INT_2_FINT(MPI_File_set_view(c_fh, (MPI_Offset) *disp,
c_etype, c_filetype,
c_datarep, c_info));
free(c_datarep);
}
void ompi_info_set_f(MPI_Fint *info, char *key, char *value, MPI_Fint *ierr,
int key_len, int value_len)
{
int ret, c_ierr;
MPI_Info c_info;
char *c_key = NULL, *c_value = NULL;
if (OMPI_SUCCESS != (ret = ompi_fortran_string_f2c(key, key_len, &c_key)) ||
OMPI_SUCCESS != (ret = ompi_fortran_string_f2c(value, value_len,
&c_value))) {
c_ierr = OMPI_ERRHANDLER_INVOKE(MPI_COMM_WORLD, ret, FUNC_NAME);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
if (NULL != c_key) {
free(c_key);
}
return;
}
c_info = MPI_Info_f2c(*info);
c_ierr = MPI_Info_set(c_info, c_key, c_value);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
free(c_key);
free(c_value);
}
void mpi_file_open_(MPI_Fint *comm,char *filename,MPI_Fint *amode,
MPI_Fint *info, MPI_Fint *fh, MPI_Fint *ierr, int str_len )
{
char *newfname;
MPI_File fh_c;
int real_len, i;
MPI_Comm comm_c;
MPI_Info info_c;
comm_c = MPI_Comm_f2c(*comm);
info_c = MPI_Info_f2c(*info);
/* strip trailing blanks */
if (filename <= (char *) 0) {
FPRINTF(stderr, "MPI_File_open: filename is an invalid address\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
for (i=str_len-1; i>=0; i--) if (filename[i] != ' ') break;
if (i < 0) {
FPRINTF(stderr, "MPI_File_open: filename is a blank string\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
real_len = i + 1;
newfname = (char *) ADIOI_Malloc((real_len+1)*sizeof(char));
ADIOI_Strncpy(newfname, filename, real_len);
newfname[real_len] = '\0';
*ierr = MPI_File_open(comm_c, newfname, *amode, info_c, &fh_c);
*fh = MPI_File_c2f(fh_c);
ADIOI_Free(newfname);
}
void mpi_info_get_valuelen_(MPI_Fint *info, char *key, int *valuelen,
int *flag, int *ierr, int keylen )
{
MPI_Info info_c;
char *newkey;
int new_keylen, lead_blanks, i;
if (key <= (char *) 0) {
FPRINTF(stderr, "MPI_Info_get_valuelen: key is an invalid address\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
/* strip leading and trailing blanks in key */
lead_blanks = 0;
for (i=0; i<keylen; i++)
if (key[i] == ' ') lead_blanks++;
else break;
for (i=keylen-1; i>=0; i--) if (key[i] != ' ') break;
if (i < 0) {
FPRINTF(stderr, "MPI_Info_get_valuelen: key is a blank string\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
new_keylen = i + 1 - lead_blanks;
key += lead_blanks;
newkey = (char *) ADIOI_Malloc((new_keylen+1)*sizeof(char));
strncpy(newkey, key, new_keylen);
newkey[new_keylen] = '\0';
info_c = MPI_Info_f2c(*info);
*ierr = MPI_Info_get_valuelen(info_c, newkey, valuelen, flag);
ADIOI_Free(newkey);
}
void mpi_info_get_nthkey_(MPI_Fint *info, int *n, char *key, int *ierr,
int keylen)
{
MPI_Info info_c;
int i, tmpkeylen;
char *tmpkey;
if (key <= (char *) 0) {
FPRINTF(stderr, "MPI_Info_get_nthkey: key is an invalid address\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
tmpkey = (char *) ADIOI_Malloc((MPI_MAX_INFO_KEY+1) * sizeof(char));
info_c = MPI_Info_f2c(*info);
*ierr = MPI_Info_get_nthkey(info_c, *n, tmpkey);
tmpkeylen = strlen(tmpkey);
if (tmpkeylen <= keylen) {
ADIOI_Strncpy(key, tmpkey, tmpkeylen);
/* blank pad the remaining space */
for (i=tmpkeylen; i<keylen; i++) key[i] = ' ';
}
else {
/* not enough space */
ADIOI_Strncpy(key, tmpkey, keylen);
/* this should be flagged as an error. */
*ierr = MPI_ERR_UNKNOWN;
}
ADIOI_Free(tmpkey);
}
void ompi_alloc_mem_f(MPI_Aint *size, MPI_Fint *info, char *baseptr, MPI_Fint *ierr)
{
int ierr_c;
MPI_Info c_info = MPI_Info_f2c(*info);
ierr_c = MPI_Alloc_mem(*size, c_info, baseptr);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(ierr_c);
}
void mpi_info_free_(MPI_Fint *info, int *ierr )
{
MPI_Info info_c;
info_c = MPI_Info_f2c(*info);
*ierr = MPI_Info_free(&info_c);
*info = MPI_Info_c2f(info_c);
}
void mpi_info_dup_(MPI_Fint * info, MPI_Fint * newinfo, int *ierr)
{
MPI_Info info_c, newinfo_c;
info_c = MPI_Info_f2c(*info);
*ierr = MPI_Info_dup(info_c, &newinfo_c);
*newinfo = MPI_Info_c2f(newinfo_c);
}
void mpi_info_get_(MPI_Fint *info, char *key, int *valuelen, char *value,
int *flag, int *ierr, int keylen, int valspace)
{
MPI_Info info_c;
char *newkey, *tmpvalue;
int new_keylen, lead_blanks, i, tmpvaluelen;
if (key <= (char *) 0) {
FPRINTF(stderr, "MPI_Info_get: key is an invalid address\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
/* strip leading and trailing blanks in key */
lead_blanks = 0;
for (i=0; i<keylen; i++)
if (key[i] == ' ') lead_blanks++;
else break;
for (i=keylen-1; i>=0; i--) if (key[i] != ' ') break;
if (i < 0) {
FPRINTF(stderr, "MPI_Info_get: key is a blank string\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
new_keylen = i + 1 - lead_blanks;
key += lead_blanks;
newkey = (char *) ADIOI_Malloc((new_keylen+1)*sizeof(char));
ADIOI_Strncpy(newkey, key, new_keylen);
newkey[new_keylen] = '\0';
if (value <= (char *) 0) {
FPRINTF(stderr, "MPI_Info_get: value is an invalid address\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
if (*valuelen <= 0) {
FPRINTF(stderr, "MPI_Info_get: Invalid valuelen argument\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
if (*valuelen > valspace) {
FPRINTF(stderr, "MPI_Info_get: valuelen is greater than the amount of memory available in value\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
tmpvalue = (char *) ADIOI_Malloc((*valuelen + 1)*sizeof(char));
info_c = MPI_Info_f2c(*info);
*ierr = MPI_Info_get(info_c, newkey, *valuelen, tmpvalue, flag);
if (*flag) {
tmpvaluelen = strlen(tmpvalue);
ADIOI_Strncpy(value, tmpvalue, tmpvaluelen);
/* blank pad the remaining space */
for (i=tmpvaluelen; i<valspace; i++) value[i] = ' ';
}
ADIOI_Free(newkey);
ADIOI_Free(tmpvalue);
}
FORTRAN_API void FORT_CALL mpi_file_set_info_(MPI_Fint *fh, MPI_Fint *info, int *ierr )
{
MPI_File fh_c;
MPI_Info info_c;
fh_c = MPI_File_f2c(*fh);
info_c = MPI_Info_f2c(*info);
*ierr = MPI_File_set_info(fh_c, info_c);
}
void ompi_win_set_info_f(MPI_Fint *win, MPI_Fint *info, MPI_Fint *ierr)
{
int c_ierr;
MPI_Win c_win;
MPI_Info c_info;
c_win = MPI_Win_f2c(*win);
c_info = MPI_Info_f2c(*info);
c_ierr = MPI_Win_set_info(c_win, c_info);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
}
void mpi_comm_spawn_f(char *command, char *argv, MPI_Fint *maxprocs,
MPI_Fint *info, MPI_Fint *root, MPI_Fint *comm,
MPI_Fint *intercomm, MPI_Fint *array_of_errcodes,
MPI_Fint *ierr, int cmd_len, int string_len)
{
MPI_Comm c_comm, c_new_comm;
MPI_Info c_info;
int size;
int *c_errs;
char **c_argv;
char *c_command;
OMPI_ARRAY_NAME_DECL(array_of_errcodes);
c_comm = MPI_Comm_f2c(*comm);
c_info = MPI_Info_f2c(*info);
MPI_Comm_size(c_comm, &size);
ompi_fortran_string_f2c(command, cmd_len, &c_command);
/* It's allowed to ignore the errcodes */
if (OMPI_IS_FORTRAN_ERRCODES_IGNORE(array_of_errcodes)) {
c_errs = MPI_ERRCODES_IGNORE;
} else {
OMPI_ARRAY_FINT_2_INT_ALLOC(array_of_errcodes, size);
c_errs = OMPI_ARRAY_NAME_CONVERT(array_of_errcodes);
}
/* It's allowed to have no argv */
if (OMPI_IS_FORTRAN_ARGV_NULL(argv)) {
c_argv = MPI_ARGV_NULL;
} else {
ompi_fortran_argv_f2c(argv, string_len, string_len, &c_argv);
}
*ierr = OMPI_INT_2_FINT(MPI_Comm_spawn(c_command, c_argv,
OMPI_FINT_2_INT(*maxprocs),
c_info,
OMPI_FINT_2_INT(*root),
c_comm, &c_new_comm, c_errs));
if (MPI_SUCCESS == OMPI_FINT_2_INT(*ierr)) {
*intercomm = MPI_Comm_c2f(c_new_comm);
}
free(c_command);
if (MPI_ARGV_NULL != c_argv && NULL != c_argv) {
opal_argv_free(c_argv);
}
if (!OMPI_IS_FORTRAN_ERRCODES_IGNORE(array_of_errcodes)) {
OMPI_ARRAY_INT_2_FINT(array_of_errcodes, size);
} else {
OMPI_ARRAY_FINT_2_INT_CLEANUP(array_of_errcodes);
}
}
void mpi_open_port_f(MPI_Fint *info, char *port_name, MPI_Fint *ierr, int port_name_len)
{
MPI_Info c_info;
char c_port_name[MPI_MAX_PORT_NAME];
c_info = MPI_Info_f2c(*info);
*ierr = OMPI_INT_2_FINT(MPI_Open_port(c_info, c_port_name));
if ( MPI_SUCCESS == OMPI_FINT_2_INT (*ierr )) {
ompi_fortran_string_c2f(c_port_name, port_name, port_name_len );
}
}
void ompi_info_dup_f(MPI_Fint *info, MPI_Fint *newinfo, MPI_Fint *ierr)
{
int c_ierr;
MPI_Info c_info, c_new_info;
c_info = MPI_Info_f2c(*info);
c_ierr = MPI_Info_dup(c_info, &c_new_info);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
if (MPI_SUCCESS == c_ierr) {
*newinfo = MPI_Info_c2f(c_new_info);
}
}
void mpi_file_open_(MPI_Fint *comm,_fcd filename_fcd,MPI_Fint *amode,
MPI_Fint *info, MPI_Fint *fh, MPI_Fint *ierr)
{
char *filename = _fcdtocp(filename_fcd);
int str_len = _fcdlen(filename_fcd);
#else
/* Prototype to keep compiler happy */
/*
FORTRAN_API void FORT_CALL mpi_file_open_(MPI_Comm *comm,char *filename,MPI_Fint *amode,
MPI_Fint *info, MPI_Fint *fh, MPI_Fint *ierr, int str_len );
FORTRAN_API void FORT_CALL mpi_file_open_(MPI_Comm *comm,char *filename,MPI_Fint *amode,
MPI_Fint *info, MPI_Fint *fh, MPI_Fint *ierr, int str_len )
*/
/* Prototype to keep compiler happy */
FORTRAN_API void FORT_CALL mpi_file_open_(MPI_Fint *comm,char *filename FORT_MIXED_LEN_DECL,MPI_Fint *amode,
MPI_Fint *info, MPI_Fint *fh, MPI_Fint *ierr FORT_END_LEN_DECL);
FORTRAN_API void FORT_CALL mpi_file_open_(MPI_Fint *comm,char *filename FORT_MIXED_LEN(str_len),MPI_Fint *amode,
MPI_Fint *info, MPI_Fint *fh, MPI_Fint *ierr FORT_END_LEN(str_len))
{
#endif
char *newfname;
MPI_File fh_c;
int real_len, i;
MPI_Info info_c;
info_c = MPI_Info_f2c(*info);
/* strip trailing blanks */
if (filename <= (char *) 0) {
FPRINTF(stderr, "MPI_File_open: filename is an invalid address\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
for (i=str_len-1; i>=0; i--) if (filename[i] != ' ') break;
if (i < 0) {
FPRINTF(stderr, "MPI_File_open: filename is a blank string\n");
MPI_Abort(MPI_COMM_WORLD, 1);
}
real_len = i + 1;
newfname = (char *) ADIOI_Malloc((real_len+1)*sizeof(char));
ADIOI_Strncpy(newfname, filename, real_len);
newfname[real_len] = '\0';
*ierr = MPI_File_open((MPI_Comm)(*comm), newfname, *amode, info_c, &fh_c);
*fh = MPI_File_c2f(fh_c);
ADIOI_Free(newfname);
}
void mpi_publish_name_f(char *service_name, MPI_Fint *info,
char *port_name, MPI_Fint *ierr, int service_name_len, int port_name_len)
{
MPI_Info c_info;
char *c_service_name;
char *c_port_name;
c_info = MPI_Info_f2c(*info);
ompi_fortran_string_f2c(service_name, service_name_len, &c_service_name);
ompi_fortran_string_f2c(port_name, port_name_len, &c_port_name);
*ierr = OMPI_INT_2_FINT(MPI_Publish_name(c_service_name, c_info,
c_port_name));
free ( c_service_name);
free ( c_port_name);
}
void mpi_info_delete_f(MPI_Fint *info, char *key, MPI_Fint *ierr, int key_len)
{
int c_err, ret;
MPI_Info c_info;
char *c_key;
if (OMPI_SUCCESS != (ret = ompi_fortran_string_f2c(key, key_len, &c_key))) {
c_err = OMPI_ERRHANDLER_INVOKE(MPI_COMM_WORLD, ret, FUNC_NAME);
*ierr = OMPI_INT_2_FINT(c_err);
return;
}
c_info = MPI_Info_f2c(*info);
*ierr = OMPI_INT_2_FINT(MPI_Info_delete(c_info, c_key));
free(c_key);
}
void mpi_win_create_f(char *base, MPI_Aint *size, MPI_Fint *disp_unit,
MPI_Fint *info, MPI_Fint *comm, MPI_Fint *win,
MPI_Fint *ierr)
{
MPI_Win c_win;
MPI_Info c_info;
MPI_Comm c_comm;
c_comm = MPI_Comm_f2c(*comm);
c_info = MPI_Info_f2c(*info);
*ierr = OMPI_INT_2_FINT(MPI_Win_create(base, *size,
OMPI_FINT_2_INT(*disp_unit),
c_info, c_comm, &c_win));
if (MPI_SUCCESS == OMPI_FINT_2_INT(*ierr)) {
*win = MPI_Win_c2f(c_win);
}
}
void ompi_win_create_dynamic_f(MPI_Fint *info, MPI_Fint *comm, MPI_Fint *win,
MPI_Fint *ierr)
{
int c_ierr;
MPI_Win c_win;
MPI_Info c_info;
MPI_Comm c_comm;
c_comm = MPI_Comm_f2c(*comm);
c_info = MPI_Info_f2c(*info);
c_ierr = MPI_Win_create_dynamic(c_info, c_comm, &c_win);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
if (MPI_SUCCESS == c_ierr) {
*win = MPI_Win_c2f(c_win);
}
}
void mpif_comm_spawn_(char *command, char **argv, int *maxprocs,
MPI_Fint *info, int *root, MPI_Fint *comm,
MPI_Fint *intercomm, int *array_of_errcodes, int*error)
{
MPI_Comm c_comm = MPI_Comm_f2c(*comm);
MPI_Info c_info = MPI_Info_f2c(*info);
ALLOCATE_ITEMS(MPI_Comm, *maxprocs, c_intercomm, p_intercomm);
int i;
for(i=0; i<*maxprocs;i++)
p_intercomm[i] = MPI_Comm_f2c(intercomm[i]);
*error = MPI_Comm_spawn(command, argv, *maxprocs,
c_info, *root, c_comm,
p_intercomm, array_of_errcodes);
for(i=0; i<*maxprocs;i++)
intercomm[i] = MPI_Comm_c2f(p_intercomm[i]);
FREE_ITEMS(*maxprocs, p_intercomm);
}
void ompi_unpublish_name_f(char *service_name, MPI_Fint *info,
char *port_name, MPI_Fint *ierr,
int service_name_len, int port_name_len)
{
int c_ierr;
MPI_Info c_info;
char *c_service_name;
char *c_port_name;
c_info = MPI_Info_f2c(*info);
ompi_fortran_string_f2c(service_name, service_name_len, &c_service_name);
ompi_fortran_string_f2c(port_name, port_name_len, &c_port_name);
c_ierr = MPI_Unpublish_name(c_service_name, c_info, c_port_name);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
free ( c_service_name);
free ( c_port_name);
}
MPI_Fint c2finfo_ ( MPI_Fint *info )
{
MPI_Info cInfo = MPI_Info_f2c( *info );
int flag;
char value[100];
MPI_Fint errs = 0;
MPI_Info_get( cInfo, (char*)"host", sizeof(value), value, &flag );
if (!flag || strcmp(value,"myname") != 0) {
fprintf( stderr, "Info: Wrong value or no value for host\n" );
errs++;
}
MPI_Info_get( cInfo, (char*)"wdir", sizeof(value), value, &flag );
if (!flag || strcmp( value, "/rdir/foo" ) != 0) {
fprintf( stderr, "Info: Wrong value of no value for wdir\n" );
errs++;
}
return errs;
}
/*----------------------------------------------------------------------------
* Name: h5pset_fapl_mpio_c
* Purpose: Call H5Pset_fapl_mpio to set mode for parallel I/O and the user
* supplied communicator and info object
* Inputs: prp_id - property list identifier
* comm - MPI communicator
* info - MPI info object
* Returns: 0 on success, -1 on failure
* Programmer: Elena Pourmal
* Thursday, October 26, 2000
* Modifications:
*---------------------------------------------------------------------------*/
int_f
nh5pset_fapl_mpio_c(hid_t_f *prp_id, int_f* comm, int_f* info)
{
int ret_value = -1;
hid_t c_prp_id;
herr_t ret;
MPI_Comm c_comm;
MPI_Info c_info;
c_comm = MPI_Comm_f2c(*comm);
c_info = MPI_Info_f2c(*info);
/*
* Call H5Pset_mpi function.
*/
c_prp_id = *prp_id;
ret = H5Pset_fapl_mpio(c_prp_id, c_comm, c_info);
if (ret < 0) return ret_value;
ret_value = 0;
return ret_value;
}
void ompi_info_get_nthkey_f(MPI_Fint *info, MPI_Fint *n, char *key,
MPI_Fint *ierr, int key_len)
{
int c_ierr, ret;
MPI_Info c_info;
char c_key[MPI_MAX_INFO_KEY + 1];
c_info = MPI_Info_f2c(*info);
c_ierr = MPI_Info_get_nthkey(c_info,
OMPI_FINT_2_INT(*n),
c_key);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
if (OMPI_SUCCESS != (ret = ompi_fortran_string_c2f(c_key, key, key_len))) {
c_ierr = OMPI_ERRHANDLER_INVOKE(MPI_COMM_WORLD, ret, FUNC_NAME);
if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
return;
}
}
void mpi_comm_accept_f(char *port_name, MPI_Fint *info, MPI_Fint *root,
MPI_Fint *comm, MPI_Fint *newcomm, MPI_Fint *ierr,
int port_name_len)
{
MPI_Comm c_comm, c_new_comm;
MPI_Info c_info;
char *c_port_name;
c_comm = MPI_Comm_f2c(*comm);
c_info = MPI_Info_f2c(*info);
ompi_fortran_string_f2c(port_name, port_name_len, &c_port_name);
*ierr = OMPI_INT_2_FINT(MPI_Comm_accept(c_port_name, c_info,
OMPI_FINT_2_INT(*root),
c_comm, &c_new_comm));
if (MPI_SUCCESS == OMPI_FINT_2_INT(*ierr)) {
*newcomm = MPI_Comm_c2f(c_new_comm);
}
free ( c_port_name );
}
void mpi_info_get_f(MPI_Fint *info, char *key, MPI_Fint *valuelen,
char *value, ompi_fortran_logical_t *flag, MPI_Fint *ierr,
int key_len, int value_len)
{
int c_err, ret;
MPI_Info c_info;
char *c_key = NULL, c_value[MPI_MAX_INFO_VAL + 1];
OMPI_LOGICAL_NAME_DECL(flag);
if (OMPI_SUCCESS != (ret = ompi_fortran_string_f2c(key, key_len, &c_key))) {
c_err = OMPI_ERRHANDLER_INVOKE(MPI_COMM_WORLD, ret, FUNC_NAME);
*ierr = OMPI_INT_2_FINT(c_err);
return;
}
c_info = MPI_Info_f2c(*info);
*ierr = OMPI_INT_2_FINT(MPI_Info_get(c_info, c_key,
OMPI_FINT_2_INT(*valuelen),
c_value,
OMPI_LOGICAL_SINGLE_NAME_CONVERT(flag)));
if (MPI_SUCCESS == OMPI_FINT_2_INT(*ierr)) {
OMPI_SINGLE_INT_2_LOGICAL(flag);
/* If we found the info key, copy the value back to the
Fortran string (note: all Fortran compilers have FALSE ==
0, so just check for any nonzero value, because not all
Fortran compilers have TRUE == 1). Note: use the full
length of the Fortran string, not *valuelen. See comment
in ompi/mpi/fortran/base/strings.c. */
if (*flag && OMPI_SUCCESS !=
(ret = ompi_fortran_string_c2f(c_value, value, value_len))) {
c_err = OMPI_ERRHANDLER_INVOKE(MPI_COMM_WORLD, ret, FUNC_NAME);
*ierr = OMPI_INT_2_FINT(c_err);
free(c_key);
return;
}
}
free(c_key);
}
void ompi_dist_graph_create_f(MPI_Fint *comm_old, MPI_Fint *n, MPI_Fint *sources,
MPI_Fint *degrees, MPI_Fint *destinations, MPI_Fint *weights,
MPI_Fint *info, ompi_fortran_logical_t *reorder, MPI_Fint *comm_graph,
MPI_Fint *ierr)
{
MPI_Comm c_comm_old, c_comm_graph;
int count = 0, i;
MPI_Info c_info;
OMPI_ARRAY_NAME_DECL(sources);
OMPI_ARRAY_NAME_DECL(degrees);
OMPI_ARRAY_NAME_DECL(destinations);
OMPI_ARRAY_NAME_DECL(weights);
c_comm_old = MPI_Comm_f2c(*comm_old);
c_info = MPI_Info_f2c(*info);
OMPI_ARRAY_FINT_2_INT(sources, *n);
OMPI_ARRAY_FINT_2_INT(degrees, *n);
for( i = 0; i < OMPI_FINT_2_INT(*n); i++ )
count += OMPI_ARRAY_NAME_CONVERT(degrees)[i];
OMPI_ARRAY_FINT_2_INT(destinations, count);
if( !OMPI_IS_FORTRAN_UNWEIGHTED(weights) ) {
OMPI_ARRAY_FINT_2_INT(weights, count);
}
*ierr = OMPI_INT_2_FINT(MPI_Dist_graph_create(c_comm_old, OMPI_FINT_2_INT(*n), OMPI_ARRAY_NAME_CONVERT(sources),
OMPI_ARRAY_NAME_CONVERT(degrees), OMPI_ARRAY_NAME_CONVERT(destinations),
OMPI_IS_FORTRAN_UNWEIGHTED(weights) ? MPI_UNWEIGHTED : OMPI_ARRAY_NAME_CONVERT(weights),
c_info, OMPI_LOGICAL_2_INT(*reorder), &c_comm_graph));
if (OMPI_SUCCESS == OMPI_FINT_2_INT(*ierr)) {
*comm_graph = MPI_Comm_c2f(c_comm_graph);
}
OMPI_ARRAY_FINT_2_INT_CLEANUP(sources);
OMPI_ARRAY_FINT_2_INT_CLEANUP(degrees);
OMPI_ARRAY_FINT_2_INT_CLEANUP(destinations);
if( !OMPI_IS_FORTRAN_UNWEIGHTED(weights) ) {
OMPI_ARRAY_FINT_2_INT_CLEANUP(weights);
}
}
/* Fortran needs to pass MPI comm/info as integers. */
int
nc_open_par_fortran(const char *path, int mode, int comm,
int info, int *ncidp)
{
#ifndef USE_PARALLEL
return NC_ENOPAR;
#else
MPI_Comm comm_c;
MPI_Info info_c;
/* Convert fortran comm and info to C comm and info, if there is a
* function to do so. Otherwise just pass them. */
#ifdef HAVE_MPI_COMM_F2C
comm_c = MPI_Comm_f2c(comm);
info_c = MPI_Info_f2c(info);
#else
comm_c = (MPI_Comm)comm;
info_c = (MPI_Info)info;
#endif
return nc_open_par(path, mode, comm_c, info_c, ncidp);
#endif
}
