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