C++ MPI_Comm_f2c函数代码示例

EXPORT_MPI_API void FORTRAN_API mpi_attr_get_ ( MPI_Fint *comm, MPI_Fint *keyval, MPI_Fint *attr_value, MPI_Fint *found, MPI_Fint *__ierr )
{
    void *vval;
    int  l_found;

    *__ierr = MPI_Attr_get( MPI_Comm_f2c(*comm), (int)*keyval, &vval,
                            &l_found);

    /* Convert attribute value to integer.  This code handles the case
       where sizeof(int) < sizeof(void *), and the value was stored as a
       void * 
     */
    if ((int)*__ierr || l_found == 0)
	*attr_value = 0;
    else {
	MPI_Aint lvval = (MPI_Aint)vval;
	*attr_value = (int)lvval;
    }

    *found = MPIR_TO_FLOG(l_found);
    return;
}

void mpi_reduce_f(char *sendbuf, char *recvbuf, MPI_Fint *count,
		  MPI_Fint *datatype, MPI_Fint *op, 
		  MPI_Fint *root, MPI_Fint *comm, MPI_Fint *ierr)
{
    MPI_Datatype c_type;
    MPI_Op c_op;
    MPI_Comm c_comm;

    c_type = MPI_Type_f2c(*datatype);
    c_op = MPI_Op_f2c(*op);
    c_comm = MPI_Comm_f2c(*comm);

    sendbuf = (char *) OMPI_F2C_IN_PLACE(sendbuf);
    sendbuf = (char *) OMPI_F2C_BOTTOM(sendbuf);
    recvbuf = (char *) OMPI_F2C_BOTTOM(recvbuf);

    *ierr = OMPI_INT_2_FINT(MPI_Reduce(sendbuf, recvbuf,
				       OMPI_FINT_2_INT(*count),
				       c_type, c_op, 
				       OMPI_FINT_2_INT(*root),
				       c_comm));
}

void mpi_gather_f(char *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype,
		  char *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, 
		  MPI_Fint *root, MPI_Fint *comm, MPI_Fint *ierr)
{
    MPI_Comm c_comm;
    MPI_Datatype c_sendtype, c_recvtype;

    c_comm = MPI_Comm_f2c(*comm);
    c_sendtype = MPI_Type_f2c(*sendtype);
    c_recvtype = MPI_Type_f2c(*recvtype);

    sendbuf = (char *) OMPI_F2C_IN_PLACE(sendbuf);
    sendbuf = (char *) OMPI_F2C_BOTTOM(sendbuf);
    recvbuf = (char *) OMPI_F2C_BOTTOM(recvbuf);

    *ierr = OMPI_INT_2_FINT(MPI_Gather(sendbuf, OMPI_FINT_2_INT(*sendcount),
				       c_sendtype, recvbuf, 
				       OMPI_FINT_2_INT(*recvcount),
				       c_recvtype,
				       OMPI_FINT_2_INT(*root),
				       c_comm));
}

void mpi_recv_f(char *buf, MPI_Fint *count, MPI_Fint *datatype, 
                MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm, 
                MPI_Fint *status, MPI_Fint *ierr)
{
   MPI_Status *c_status;
#if OMPI_SIZEOF_FORTRAN_INTEGER != SIZEOF_INT
   MPI_Status c_status2;
#endif
   MPI_Comm c_comm = MPI_Comm_f2c(*comm);
   MPI_Datatype c_type = MPI_Type_f2c(*datatype);

   /* See if we got MPI_STATUS_IGNORE */
   if (OMPI_IS_FORTRAN_STATUS_IGNORE(status)) {
      c_status = MPI_STATUS_IGNORE;
   } else {
      /* If sizeof(int) == sizeof(INTEGER), then there's no
         translation necessary -- let the underlying functions write
         directly into the Fortran status */

#if OMPI_SIZEOF_FORTRAN_INTEGER == SIZEOF_INT
      c_status = (MPI_Status *) status;
#else
      c_status = &c_status2;
#endif
   }

   /* Call the C function */
   *ierr = OMPI_INT_2_FINT(MPI_Recv(OMPI_F2C_BOTTOM(buf), OMPI_FINT_2_INT(*count),
                                    c_type, OMPI_FINT_2_INT(*source), 
                                    OMPI_FINT_2_INT(*tag), c_comm,
                                    c_status));
#if OMPI_SIZEOF_FORTRAN_INTEGER != SIZEOF_INT
   if (MPI_SUCCESS == OMPI_FINT_2_INT(*ierr) &&
       MPI_STATUS_IGNORE != c_status) {
       MPI_Status_c2f(c_status, status);
   }
#endif
}

void ompi_unpack_f(char *inbuf, MPI_Fint *insize, MPI_Fint *position,
		  char *outbuf, MPI_Fint *outcount, MPI_Fint *datatype,
		  MPI_Fint *comm, MPI_Fint *ierr)
{
   int c_ierr;
   MPI_Comm c_comm;
   MPI_Datatype c_type;
   OMPI_SINGLE_NAME_DECL(position);

   c_comm = MPI_Comm_f2c(*comm);
   c_type = MPI_Type_f2c(*datatype);
   OMPI_SINGLE_FINT_2_INT(position);

   c_ierr = MPI_Unpack(inbuf, OMPI_FINT_2_INT(*insize),
                       OMPI_SINGLE_NAME_CONVERT(position),
                       OMPI_F2C_BOTTOM(outbuf), OMPI_FINT_2_INT(*outcount),
                       c_type, c_comm);
   if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);

   if (MPI_SUCCESS == c_ierr) {
        OMPI_SINGLE_INT_2_FINT(position);
    }
}

void nbc_ialltoallv_f(void *sendbuf, int *sendcounts, int *sdispls, int *sendtype,
    void *recvbuf, int *recvcounts, int *rdispls, int *recvtype, int *fcomm, int *fhandle, int *ierr) {
#else
void NBC_F77_FUNC_(nbc_ialltoallv,NBC_IALLTOALLV)(void *sendbuf, int *sendcounts, int *sdispls, int *sendtype,
    void *recvbuf, int *recvcounts, int *rdispls, int *recvtype, int *fcomm, int *fhandle, int *ierr);
void NBC_F77_FUNC_(nbc_ialltoallv,NBC_IALLTOALLV)(void *sendbuf, int *sendcounts, int *sdispls, int *sendtype,
    void *recvbuf, int *recvcounts, int *rdispls, int *recvtype, int *fcomm, int *fhandle, int *ierr)  {
#endif
  MPI_Datatype rtype, stype;
  MPI_Comm comm;
  NBC_Handle *handle;

  /* this is the only MPI-2 we need :-( */
  rtype = MPI_Type_f2c(*recvtype);
  stype = MPI_Type_f2c(*sendtype);
  comm = MPI_Comm_f2c(*fcomm);

  /* create a new handle in handle table */
  NBC_Create_fortran_handle(fhandle, &handle);

  /* call NBC function */
  *ierr = NBC_Ialltoallv(sendbuf, sendcounts, sdispls, stype, recvbuf, recvcounts, rdispls, rtype, comm, handle);
}

void ompi_cart_shift_f(MPI_Fint *comm, MPI_Fint *direction, MPI_Fint *disp,
		      MPI_Fint *rank_source, MPI_Fint *rank_dest,
		      MPI_Fint *ierr)
{
    int c_ierr;
    MPI_Comm c_comm;
    OMPI_SINGLE_NAME_DECL(rank_source);
    OMPI_SINGLE_NAME_DECL(rank_dest);

    c_comm = MPI_Comm_f2c(*comm);

    c_ierr = MPI_Cart_shift(c_comm, 
                            OMPI_FINT_2_INT(*direction),
                            OMPI_FINT_2_INT(*disp),
                            OMPI_SINGLE_NAME_CONVERT(rank_source),
                            OMPI_SINGLE_NAME_CONVERT(rank_dest));
    if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);

    if (MPI_SUCCESS == c_ierr) {
        OMPI_SINGLE_INT_2_FINT(rank_source);
        OMPI_SINGLE_INT_2_FINT(rank_dest);
    }
}

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

/**
 * ADIOS init and create group etc.
 * Return: pointer to the ADIOS group structure
 */
SEXP R_create(SEXP R_groupname,
              SEXP R_buffersize,
              SEXP R_comm)
{
    const char *groupname = CHARPT(R_groupname, 0);
    int buffer = asInteger(R_buffersize);
    MPI_Comm comm = MPI_Comm_f2c(INTEGER(R_comm)[0]);

    int64_t m_adios_group;
    
    adios_init_noxml (comm);
    adios_set_max_buffer_size (buffer); // Default buffer size for write is 20. User can change this value

    adios_declare_group (&m_adios_group, groupname, "", adios_flag_yes);
    adios_select_method (m_adios_group, "MPI", "", ""); // Default method is MPI. Let users choose different methods later.

    // Pass group pointer to R
    SEXP R_group = PROTECT(allocVector(REALSXP, 1));
    REAL(R_group)[0] = (double)m_adios_group;
    UNPROTECT(1);

    return R_group;
}

void NAME_ROUTINE_C2F(mpi_reduce) (void *sendbuf, void *recvbuf, MPI_Fint *count,
	MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *root, MPI_Fint *comm,
	MPI_Fint *ierror)
#endif
{
	MPI_Comm c = MPI_Comm_f2c(*comm);

#if defined(ENABLE_LOAD_BALANCING)
	DLB_MPI_Reduce_F_enter (MPI3_VOID_P_CAST sendbuf, recvbuf, count, datatype, op, root, comm, ierror);
#endif

	Extrae_MPI_ProcessCollectiveCommunicator (c);

	if (mpitrace_on)
	{
		DEBUG_INTERFACE(ENTER)
		Backend_Enter_Instrumentation (2+Caller_Count[CALLER_MPI]);
		PMPI_Reduce_Wrapper (MPI3_VOID_P_CAST sendbuf, recvbuf, count, datatype, op, root, comm,
                         ierror);
		Backend_Leave_Instrumentation ();
		DEBUG_INTERFACE(LEAVE)
	}
	else

void MUMPS_CALL
MUMPS_PARMETIS_64(MUMPS_INT8 *first,      MUMPS_INT8 *vertloctab,
                  MUMPS_INT8 *edgeloctab,
#if defined(parmetis3)
                  MUMPS_INT  *numflag, MUMPS_INT  *options,
#else
                  MUMPS_INT8 *numflag, MUMPS_INT8 *options,
#endif
                  MUMPS_INT8 *order,
                  MUMPS_INT8 *sizes,         MUMPS_INT *comm,
                  MUMPS_INT  *ierr)
{
  MPI_Comm  int_comm;
#if defined(parmetis)
#  if (IDXTYPEWIDTH == 64)
  int iierr;
#endif
#endif
  int_comm = MPI_Comm_f2c(*comm);
#if defined(parmetis3)
  /* Prototype may not match with 32-bit integers and Parmetis3 */
  ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm);
#elif defined(parmetis)
#  if (IDXTYPEWIDTH == 64)
      *ierr=0;
      iierr=ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm);
      if(iierr != METIS_OK)
        *ierr=1;
#  else
      /* SHOULD NEVER BE CALLED */
      printf("** Error: ParMETIS version >= 4, IDXTYPE WIDTH !=64, but MUMPS_PARMETIS_64 was called\n");
      *ierr=1;
#  endif
#endif
  return;
}

void mpi_sendrecv_replace_f(char *buf, MPI_Fint *count, MPI_Fint *datatype,
			    MPI_Fint *dest, MPI_Fint *sendtag,
			    MPI_Fint *source, MPI_Fint *recvtag,
			    MPI_Fint *comm, MPI_Fint *status, MPI_Fint *ierr)
{
   MPI_Datatype c_type = MPI_Type_f2c(*datatype);
   MPI_Comm c_comm;
   MPI_Status c_status;

   c_comm = MPI_Comm_f2c (*comm);
   
   *ierr = OMPI_INT_2_FINT(MPI_Sendrecv_replace(OMPI_F2C_BOTTOM(buf),
                                                OMPI_FINT_2_INT(*count),
                                                c_type, 
                                                OMPI_FINT_2_INT(*dest), 
                                                OMPI_FINT_2_INT(*sendtag), 
                                                OMPI_FINT_2_INT(*source), 
                                                OMPI_FINT_2_INT(*recvtag),
                                                c_comm, &c_status));
    if (MPI_SUCCESS == OMPI_FINT_2_INT(*ierr) &&
        !OMPI_IS_FORTRAN_STATUS_IGNORE(status)) {
      MPI_Status_c2f(&c_status, status);
   }
}

RSL_LITE_EXCH_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ,
                  int * sendw_m, int * sendw_p, int * recvw_m , int * recvw_p )
{
  int me, np, np_x, np_y ;
  int yp, ym, xp, xm ;
#ifndef STUBMPI
  MPI_Status stat ;
  MPI_Comm comm, *comm0, dummy_comm ;

  comm0 = &dummy_comm ;
  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
  comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
  if ( np_x > 1 ) {
    MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
    if ( xp != MPI_PROC_NULL && *recvw_p > 0 ) {
      MPI_Irecv ( buffer_for_proc( xp, xp_curs_recv, RSL_RECVBUF ), xp_curs_recv, MPI_CHAR, xp, me, comm, &xp_recv ) ;
    }
    if ( xm != MPI_PROC_NULL && *recvw_m > 0 ) {
      MPI_Irecv ( buffer_for_proc( xm, xm_curs_recv, RSL_RECVBUF ), xm_curs_recv, MPI_CHAR, xm, me, comm, &xm_recv ) ;
    }
    if ( xp != MPI_PROC_NULL && *sendw_p > 0 ) {
      MPI_Isend ( buffer_for_proc( xp, 0,       RSL_SENDBUF ), xp_curs, MPI_CHAR, xp, xp, comm, &xp_send ) ;
    }
    if ( xm != MPI_PROC_NULL && *sendw_m > 0 ) {
      MPI_Isend ( buffer_for_proc( xm, 0,       RSL_SENDBUF ), xm_curs, MPI_CHAR, xm, xm, comm, &xm_send ) ;
    }
    if ( xp != MPI_PROC_NULL && *recvw_p > 0 ) {  MPI_Wait( &xp_recv, &stat ) ;  }
    if ( xm != MPI_PROC_NULL && *recvw_m > 0 ) {  MPI_Wait( &xm_recv, &stat ) ;  }
    if ( xp != MPI_PROC_NULL && *sendw_p > 0 ) {  MPI_Wait( &xp_send, &stat ) ;  }
    if ( xm != MPI_PROC_NULL && *sendw_m > 0 ) {  MPI_Wait( &xm_send, &stat ) ;  }
  }
  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
  yp_curs_recv = 0 ; ym_curs_recv = 0 ; 
  xp_curs_recv = 0 ; xm_curs_recv = 0 ;
#endif
}

void ompi_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)
{
    int c_ierr;
    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);


    c_ierr = MPI_Comm_accept(c_port_name, c_info, 
                             OMPI_FINT_2_INT(*root), 
                             c_comm, &c_new_comm);
    if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);

    if (MPI_SUCCESS == c_ierr) {
        *newcomm = MPI_Comm_c2f(c_new_comm);
    }
    free ( c_port_name );
}

void PETSC_STDCALL  dmcartesiancreate_(MPI_Fint * comm,DM *mesh, int *__ierr ){
*__ierr = DMCartesianCreate(
	MPI_Comm_f2c( *(comm) ),mesh);
}