SEXP R_sys2blacs_handle(SEXP COMM)
{
SEXP new_ctxt = PROTECT(Rf_allocVector(INTSXP, 1));
SEXP R_APTS = findVar(install(MPI_APTS_R_NAME), R_GlobalEnv);
rmpi_array_pointers *MPI_APTS_ptr = (rmpi_array_pointers*) R_ExternalPtrAddr(R_APTS);
MPI_Comm comm = MPI_APTS_ptr->comm[INT(COMM)];
INT(new_ctxt) = Csys2blacs_handle(comm);
UNPROTECT(1);
return new_ctxt;
}
int Handle( MPI_Comm comm )
{ return Csys2blacs_handle( comm ); }
void test_gemr2d(int M, int N)
{
int repeat = 10;
int32_t one = 1;
int32_t isrc = 0;
int32_t num_ranks;
MPI_Comm_size(MPI_COMM_WORLD, &num_ranks);
int32_t rank;
MPI_Comm_rank(MPI_COMM_WORLD, &rank);
int32_t bs_row_A = M / num_ranks + std::min(1, M % num_ranks);
int32_t bs_col_A = 1;
int32_t bs_row_B = 1;
int32_t bs_col_B = 1;
int32_t blacs_handler = Csys2blacs_handle(MPI_COMM_WORLD);
int32_t context1 = blacs_handler;
int32_t context2 = blacs_handler;
/* create BLACS context */
Cblacs_gridinit(&context1, "C", num_ranks, 1);
/* get row and column ranks */
int32_t rank_row1, rank_col1;
Cblacs_gridinfo(context1, &num_ranks, &one, &rank_row1, &rank_col1);
/* get local number of rows and columns of a matrix */
int32_t num_rows_local1, num_cols_local1;
num_rows_local1 = numroc_(&M, &bs_row_A, &rank_row1, &isrc, &num_ranks);
num_cols_local1 = numroc_(&N, &bs_col_A, &rank_col1, &isrc, &one);
Cblacs_gridinit(&context2, "C", 1, num_ranks);
int32_t rank_row2, rank_col2;
Cblacs_gridinfo(context2, &one, &num_ranks, &rank_row2, &rank_col2);
int32_t num_rows_local2, num_cols_local2;
num_rows_local2 = numroc_(&M, &bs_row_B, &rank_row2, &isrc, &one);
num_cols_local2 = numroc_(&N, &bs_col_B, &rank_col2, &isrc, &num_ranks);
if (rank == 0)
{
printf("local dimensions of A: %i x %i\n", num_rows_local1, num_cols_local1);
printf("local dimensions of B: %i x %i\n", num_rows_local2, num_cols_local2);
}
int32_t descA[9], descB[9], info;
descinit_(descA, &M, &N, &bs_row_A, &bs_col_A, &isrc, &isrc, &context1, &num_rows_local1, &info);
descinit_(descB, &M, &N, &bs_row_B, &bs_col_B, &isrc, &isrc, &context2, &num_rows_local2, &info);
std::vector<double_complex> A(num_rows_local1 * num_cols_local1);
std::vector<double_complex> B(num_rows_local2 * num_cols_local2, double_complex(0, 0));
std::vector<double_complex> C(num_rows_local1 * num_cols_local1);
for (int i = 0; i < num_rows_local1 * num_cols_local1; i++)
{
A[i] = double_complex(double(rand()) / RAND_MAX, double(rand()) / RAND_MAX);
C[i] = A[i];
}
double time = -MPI_Wtime();
for (int i = 0; i < repeat; i++)
{
pzgemr2d_(&M, &N, &A[0], &one, &one, descA, &B[0], &one, &one, descB, &context1);
}
time += MPI_Wtime();
if (rank == 0)
{
printf("average time %.4f sec, swap speed: %.4f GB/sec\n", time / repeat,
sizeof(double_complex) * repeat * M * N / double(1 << 30) / time);
}
/* check correctness */
pzgemr2d_(&M, &N, &B[0], &one, &one, descB, &A[0], &one, &one, descA, &context1);
for (int i = 0; i < num_rows_local1 * num_cols_local1; i++)
{
if (std::abs(A[i] - C[i]) > 1e-14)
{
printf("Fail.\n");
exit(0);
}
}
Cblacs_gridexit(context1);
Cblacs_gridexit(context2);
Cfree_blacs_system_handle(blacs_handler);
}
F_VOID_FUNC blacs_get_(int *ConTxt, int *what, int *val)
#endif
{
int Csys2blacs_handle(MPI_Comm);
int ierr, *iptr;
int comm;
BLACSCONTEXT *ctxt;
switch( Mpval(what) )
{
case SGET_SYSCONTXT:
if (BI_COMM_WORLD == NULL) Cblacs_pinfo(val, &ierr);
#if (INTFACE == C_CALL)
*val = Csys2blacs_handle(MPI_COMM_WORLD);
#else
*val = *BI_COMM_WORLD;
#endif
break;
case SGET_MSGIDS:
if (BI_COMM_WORLD == NULL) Cblacs_pinfo(val, &val[1]);
iptr = &val[1];
ierr=MPI_Attr_get(MPI_COMM_WORLD, MPI_TAG_UB, (BVOID **) &iptr,val);
val[0] = 0;
val[1] = *iptr;
break;
case SGET_DEBUGLVL:
*val = BlacsDebugLvl;
break;
case SGET_BLACSCONTXT:
MGetConTxt(Mpval(ConTxt), ctxt);
#if (INTFACE == C_CALL)
*val = Csys2blacs_handle(ctxt->pscp.comm);
#else /* if user called the fortran interface to the BLACS */
*val = MPI_Comm_c2f(ctxt->pscp.comm);
#endif
break;
case SGET_NR_BS:
MGetConTxt(Mpval(ConTxt), ctxt);
*val = ctxt->Nr_bs;
break;
case SGET_NB_BS:
MGetConTxt(Mpval(ConTxt), ctxt);
*val = ctxt->Nb_bs - 1;
break;
case SGET_NR_CO:
MGetConTxt(Mpval(ConTxt), ctxt);
*val = ctxt->Nr_co;
break;
case SGET_NB_CO:
MGetConTxt(Mpval(ConTxt), ctxt);
*val = ctxt->Nb_co - 1;
break;
case SGET_TOPSREPEAT:
MGetConTxt(Mpval(ConTxt), ctxt);
*val = ctxt->TopsRepeat;
break;
case SGET_TOPSCOHRNT:
MGetConTxt(Mpval(ConTxt), ctxt);
*val = ctxt->TopsCohrnt;
break;
default:
BI_BlacsWarn(Mpval(ConTxt), __LINE__, __FILE__, "Unknown WHAT (%d)",
Mpval(what));
}
}
