/**
* Distribute a global matrix stored on rank 0 to all processors
* in the grid.
*
* @param desc
* Descriptor array for desired output distributed matrix.
* @param
*/
int dmat_as_ddmatrix(int *desc, double *A_global, double *A_local)
{
const int M = desc[2], N = desc[3];
const int Mb = desc[4], Nb = desc[5];
int nrows, ncols; // size of A_local
int row, col; // index over global matrix
int recvr = 0, recvc = 0; // local matrix index
int ictxt = desc[1]; // blacs context
int nprow, npcol; // number process rows/cols
int myprow, mypcol; // current process row/col
int rdest = 0, cdest = 0; // process grid row x col destination
int nr, nc; // message size; max Mb/Nb
dmat_ldimget(desc, &nrows, &ncols);
if (nrows < 1 || ncols < 1)
return -1;
Cblacs_gridinfo(ictxt, &nprow, &npcol, &myprow, &mypcol);
const int owner = (myprow == 0 && mypcol == 0);
for (row=0; row<M; row+=Mb, rdest=(rdest+1)%nprow)
{
cdest = 0;
nr = Mb;
// Is this the last row block?
if (M - row < Mb)
nr = M - row;
for (col=0; col<N; col+=Nb, cdest=(cdest+1)%npcol)
{
nc = Nb;
// Is this the last col block?
if (N - col < Nb)
nc = N - col;
if (owner)
{
// Send a nr x nc submatrix to process (rdest, cdest)
Cdgesd2d(ictxt, nr, nc, A_global + (row + M*col), M, rdest, cdest);
}
if (myprow == rdest && mypcol == cdest)
{
// Receive nr x nc submatrix to recvr x recvc in A_local
Cdgerv2d(ictxt, nr, nc, A_local + (recvr + nrows*recvc), nrows, 0, 0);
recvc = (recvc+nc)%ncols;
}
}
if (myprow == rdest)
recvr = (recvr+nr)%nrows;
}
return 0;
}
// Point to point send/receive
SEXP R_dgesd2d1(SEXP ICTXT, SEXP M, SEXP N, SEXP A, SEXP LDA, SEXP RDEST, SEXP CDEST)
{
const int m = INTEGER(M)[0], n = INTEGER(N)[0];
SEXP OUT;
PROTECT(OUT = allocMatrix(REALSXP, m, n));
memcpy(REAL(OUT), REAL(A), m*n*sizeof(double));
Cdgesd2d(INTEGER(ICTXT)[0], m, n, REAL(OUT), INTEGER(LDA)[0],
INTEGER(RDEST)[0], INTEGER(CDEST)[0]);
UNPROTECT(1);
return(OUT);
}
int
pdtrans(char *trans, int *m, int *n, int * mb, int *nb, double *a, int *lda, double *beta,
double *c__, int *ldc, int *imrow, int *imcol, double *work, int *iwork) {
/* System generated locals */
long a_dim1, a_offset, c_dim1, c_offset;
int i__1, i__2, i__3, i__4;
/* Local variables */
int j1, k1, k2, ml, nl, mp, mq, np, nq, mb0, mb1, mb2, nb0,
nb1, nb2, kia, kja, kic, kjc, lbm, lbn, lcm, ldt, lbm0, lbm1,
lbm2, lbn0, lbn1, lbn2, igcd;
long ipt;
int mcol, info, lcmp, lcmq, item, ncol, kmod1, kmod2;
double tbeta;
int kpcol, mpcol, npcol, mrcol, mycol, kprow, mprow, nprow, mrrow, myrow;
/* -- PUMMA Package routine (version 2.1) -- */
/* Jaeyoung Choi, Oak Ridge National Laboratory. */
/* Jack Dongarra, Univ. of Tennessee, Oak Ridge National Laboratory. */
/* David Walker, Oak Ridge National Laboratory. */
/* October 31, 1994. */
/* Purpose */
/* PDTRANS routine is one of the PUMMA package based on block cyclic */
/* data distribution on 2-D process configuration. */
/* It is used for the following matrix transposition, */
/* Form C := A' + beta*C */
/* where beta is a scalar, and A and C are matrices, with A an M by N */
/* matrix (globally), and C an N by M matrix (globally). */
/* Parameters */
/* TRANS - (input) CHARACTER*1 */
/* TRANS specifies whether A is transposed or conjugate */
/* transposed. */
/* TRANS = 'T', transpose; */
/* TRANS = 'C', conjugate transpose. */
/* M - (input) INTEGER */
/* M specifies the (global) number of rows of the matrix A and */
/* the (global) number of rows of the matrix C. M >= 0. */
/* N - (input) INTEGER */
/* N specifies the (global) number of columns of the matrix A */
/* and columns of the matrix B. N >= 0. */
/* MB - (input) INTEGER */
/* MB specifies the row block size of the matrix A and the */
/* column block of the matrix C. MB >= 1. */
/* NB - (input) INTEGER */
/* NB specifies the column block size of the matrix A and the */
/* row block size of the matrix C. NB >= 1. */
/* A - (input) DOUBLE PRECISION array of DIMENSION ( LDA, Nq ). */
/* The leading Mp by Nq part of the array A must contain the */
/* local matrix A. Mp and Nq are local variables */
/* (see description of local parameters). */
/* LDA - (input) INTEGER */
/* The leading dimension of the (local) array A. */
/* LDA >= MAX( 1, Mp ). */
/* BETA - (input) DOUBLE PRECISION */
/* BETA specifies the scalar beta. When BETA is supplied as */
/* zero then C need not be set on input. */
/* C - (input/ouput) DOUBLE PRECISION array of DIMENSION (LDC, Mq). */
/* On entry the leading Np by Mq part of the array C must */
/* contain the local matrix C, except when beta is zero, */
/* in which case C need not be set on entry. */
/* On exit, the array C is overwritten by the Np by Mq matrix */
/* (A'+bata*C). Np and Mq are local variables */
/* (see description of local parameters). */
/* LDC - (input) INTEGER */
/* The leading dimension of the (local) array C. */
/* LDC >= MAX( 1, Np ). */
/* IMROW - (input) INTEGER */
/* IMROW specifies a row of the process template, which holds */
/* the first block of the matrices. 0 <= IMROW < NPROW. */
/* IMCOL - (input) INTEGER */
/* IMCOL specifies a column of the process template, which */
/* holds the first block of the matrices. 0 <= IMCOL < NPCOL. */
/* WORK - (workspace) DOUBLE PRECISION array */
/* See requirements. */
/* IWORK - (workspace) INTEGER array */
/* See requirements. */
/* Local Parameters */
/* LCM = the lowest common multiple of P and Q */
/* LCMP = LCM/P = number of template rows in LCM block */
/* LCMQ = LCM/Q = number of template columns in LCM block */
/* IGCD = the greatest common divisor (GCD) of P and Q */
/* MpxNq = size of (local) matrix A in the process, iam */
/* NpxMq = size of (local) matrix C in the process, iam */
/* KMOD = Define Group I.D. */
/* item = temporal integer parameter */
/* Two buffers for storing A' and T(= subblock of A') */
/* WORK <== A' */
/* WORK(IPT) <== T */
/* Three interger buffers */
/* IWORK(1,k) <== starting point of row subblock of A to send and */
/* C to receive in K2 loop (rowwise communication) */
/* IWORK(2,k) <== starting point of column subblock of A to send in */
/* J1 loop (columnwise communication) */
/* IWORK(3,k) <== starting point of column subblock of C to receive */
/* in J1 loop (columnwise communication) */
/* Requirements (approximate) */
/* Size(IWORK) = 3 x MAX(P, Q) */
/* Size(WORK) = 2 x Ceil(Ceil(M,MB),LCM)xMB x Ceil(Ceil(N,NB),LCM)xNB */
/* Get grid parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
--iwork;
/* Function Body */
Cblacs_gridinfo(context_1.ictxt, &nprow, &npcol, &myrow, &mycol);
/* Test for the input parameters. */
info = 0;
if (*trans != 'T' && *trans != 'C') {
info = 1;
} else if (*m < 0) {
info = 2;
} else if (*n < 0) {
info = 3;
} else if (*mb < 1) {
info = 4;
} else if (*nb < 1) {
info = 5;
} else if (*lda < 1) {
info = 7;
} else if (*ldc < 1) {
info = 10;
} else if (*imrow < 0 || *imrow >= nprow) {
info = 11;
} else if (*imcol < 0 || *imcol >= npcol) {
info = 12;
}
L10:
if (info != 0) {
pxerbla( &context_1.ictxt, "PDTRANS", &info );
return 0;
}
/* Initialize parameters */
mprow = nprow + myrow;
mpcol = npcol + mycol;
mrrow = (mprow - *imrow) % nprow;
mrcol = (mpcol - *imcol) % npcol;
lcm = ilcm_(&nprow, &npcol);
lcmp = lcm / nprow;
lcmq = lcm / npcol;
igcd = nprow / lcmq;
mp = numroc_(m, mb, &mrrow, &c__0, &nprow);
mq = numroc_(m, mb, &mrcol, &c__0, &npcol);
np = numroc_(n, nb, &mrrow, &c__0, &nprow);
nq = numroc_(n, nb, &mrcol, &c__0, &npcol);
i__1 = iceil_(m, mb);
lbm = iceil_(&i__1, &lcm);
i__1 = iceil_(n, nb);
lbn = iceil_(&i__1, &lcm);
/* Test for the input parameters again with local parameters */
if (*lda < mp) {
info = 7;
} else if (*ldc < np) {
info = 10;
}
if (info != 0) {
goto L10;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0) {
return 0;
}
/* At first, scale C with beta if beta != 0.0 & beta != 1.0 */
tbeta = *beta;
if (*beta != 0. && *beta != 1.) {
i__1 = mq;
for (j1 = 1; j1 <= i__1; ++j1) {
HPL_dscal( np, *beta, &c__[j1 * c_dim1 + 1], 1 );
/* L20: */
}
tbeta = 1.;
}
commtrb_1.iaz = lcmp * *mb;
commtrb_1.jaz = lcmq * *nb;
commtrb_1.itz = lcmp * *nb;
commtrb_1.jtz = lcmq * *mb;
ml = lbm * *mb;
nl = lbn * *nb;
ipt = (long)ml * (long)nl + 1;
ldt = nl;
kprow = mrrow + nprow;
kpcol = mrcol + npcol;
/* Initialize Parameters -- Compute the positions of subblocks */
i__1 = npcol - 1;
for (k1 = 0; k1 <= i__1; ++k1) {
ncol = (kpcol - k1) % npcol;
i__2 = lcmq - 1;
for (j1 = 0; j1 <= i__2; ++j1) {
item = npcol * j1 + ncol;
if (item % nprow == mrrow) {
iwork[ncol * 3 + 1] = item / nprow;
}
/* L30: */
}
}
i__2 = lcmq - 1;
for (j1 = 0; j1 <= i__2; ++j1) {
item = (npcol * j1 + mrcol) % nprow;
iwork[item * 3 + 2] = j1;
iwork[item * 3 + 3] = j1;
i__1 = igcd - 1;
for (k1 = 1; k1 <= i__1; ++k1) {
iwork[(item + nprow - k1) % nprow * 3 + 2] = j1;
iwork[(item + k1) % nprow * 3 + 3] = j1;
/* L40: */
}
}
/* Set parameters for efficient copying */
lbm0 = lbm;
lbm1 = lbm;
lbm2 = lbm;
lbn0 = lbn;
lbn1 = lbn;
lbn2 = lbn;
mb0 = *mb;
mb1 = *mb;
mb2 = *mb;
nb0 = *nb;
nb1 = *nb;
nb2 = *nb;
if (nprow == npcol) {
lbm0 = 1;
lbn0 = 1;
mb0 = mp;
nb0 = nq;
}
if (nprow == lcm) {
lbm1 = 1;
lbn2 = 1;
mb1 = mp;
nb2 = np;
}
if (npcol == lcm) {
lbn1 = 1;
lbm2 = 1;
nb1 = nq;
mb2 = mq;
}
/* For each K2 loop (rowwise), Copy A' to WORK & Send it to KTPROC */
/* then, Receive WORK and Copy WORK to C */
kmod1 = (nprow + mrcol - mrrow) % igcd;
kmod2 = (igcd - kmod1) % igcd;
i__1 = lcmp - 1;
for (k2 = 0; k2 <= i__1; ++k2) {
/* Copy A' to WORK in the appropriate order & Send it */
k1 = k2 * igcd + kmod1;
mcol = (kpcol - k1) % npcol;
kia = iwork[mcol * 3 + 1] * *mb;
mcol = (mcol + *imcol) % npcol;
ncol = (mrcol + k2 * igcd + kmod2) % npcol;
kic = iwork[ncol * 3 + 1] * *nb;
ncol = (ncol + *imcol) % npcol;
i__2 = lcmq - 1;
for (j1 = 0; j1 <= i__2; ++j1) {
kja = iwork[(mrrow + igcd * j1) % nprow * 3 + 2] * *nb;
if (myrow == (myrow + igcd * j1 + kmod1) % nprow && mycol == mcol)
{
kjc = iwork[(kprow - igcd * j1) % nprow * 3 + 3] * *mb;
i__3 = mp - kia;
i__4 = nq - kja;
dtr2mx_(&a[kia + 1 + (kja + 1) * a_dim1], lda, &tbeta, &c__[
kic + 1 + (kjc + 1) * c_dim1], ldc, &lbm0, &lbn0, &
mb0, &nb0, &i__3, &i__4);
} else {
i__3 = mp - kia;
i__4 = nq - kja;
dtr2bf_(&a[kia + 1 + (kja + 1) * a_dim1], lda, &work[1], &ldt,
&lbm1, &lbn1, &mb1, &nb1, &i__3, &i__4);
if (nprow == npcol && *beta == 0. && *ldc == ldt) {
i__3 = (myrow + igcd * j1 + kmod1) % nprow;
i__4 = (mprow - igcd * j1 - kmod2) % nprow;
kjc = iwork[(kprow - igcd * j1) % nprow * 3 + 3] * *mb;
#if 0
Cdgesd2d(context_1.ictxt,nl,ml,&work[1],nl,i__3,mcol);
Cdgerv2d(context_1.ictxt,nl,ml,&c__[(kjc + 1) * c_dim1 + 1],*ldc,i__4,ncol);
#else
Cblacs_dSendrecv( context_1.ictxt,
nl, ml, &work[1], nl, i__3, mcol,
nl, ml, &c__[(kjc + 1) * c_dim1 + 1], *ldc, i__4, ncol );
#endif
} else {
i__3 = (myrow + igcd * j1 + kmod1) % nprow;
i__4 = (mprow - igcd * j1 - kmod2) % nprow;
#if 0
Cdgesd2d(context_1.ictxt,nl,ml,&work[1],nl,i__3,mcol);
Cdgerv2d(context_1.ictxt,nl,ml,&work[ipt],nl, i__4,ncol);
#else
Cblacs_dSendrecv( context_1.ictxt,
nl, ml, &work[1], nl, i__3, mcol,
nl, ml, &work[ipt], nl, i__4, ncol );
#endif
kjc = iwork[(kprow - igcd * j1) % nprow * 3 + 3] * *mb;
i__3 = np - kic;
i__4 = mq - kjc;
dmv2mx_(&work[ipt], &ldt, &tbeta, &c__[kic + 1 + (kjc + 1)
* c_dim1], ldc, &lbn2, &lbm2, &nb2, &mb2, &i__3,
&i__4);
}
}
}
}
return 0;
} /* pdtrans_ */
