void
pzgstrs(int_t n, LUstruct_t *LUstruct,
ScalePermstruct_t *ScalePermstruct,
gridinfo_t *grid, doublecomplex *B,
int_t m_loc, int_t fst_row, int_t ldb, int nrhs,
SOLVEstruct_t *SOLVEstruct,
SuperLUStat_t *stat, int *info)
{
/*
* Purpose
* =======
*
* PZGSTRS solves a system of distributed linear equations
* A*X = B with a general N-by-N matrix A using the LU factorization
* computed by PZGSTRF.
* If the equilibration, and row and column permutations were performed,
* the LU factorization was performed for A1 where
* A1 = Pc*Pr*diag(R)*A*diag(C)*Pc^T = L*U
* and the linear system solved is
* A1 * Y = Pc*Pr*B1, where B was overwritten by B1 = diag(R)*B, and
* the permutation to B1 by Pc*Pr is applied internally in this routine.
*
* Arguments
* =========
*
* n (input) int (global)
* The order of the system of linear equations.
*
* LUstruct (input) LUstruct_t*
* The distributed data structures storing L and U factors.
* The L and U factors are obtained from PZGSTRF for
* the possibly scaled and permuted matrix A.
* See superlu_zdefs.h for the definition of 'LUstruct_t'.
* A may be scaled and permuted into A1, so that
* A1 = Pc*Pr*diag(R)*A*diag(C)*Pc^T = L*U
*
* grid (input) gridinfo_t*
* The 2D process mesh. It contains the MPI communicator, the number
* of process rows (NPROW), the number of process columns (NPCOL),
* and my process rank. It is an input argument to all the
* parallel routines.
* Grid can be initialized by subroutine SUPERLU_GRIDINIT.
* See superlu_defs.h for the definition of 'gridinfo_t'.
*
* B (input/output) doublecomplex*
* On entry, the distributed right-hand side matrix of the possibly
* equilibrated system. That is, B may be overwritten by diag(R)*B.
* On exit, the distributed solution matrix Y of the possibly
* equilibrated system if info = 0, where Y = Pc*diag(C)^(-1)*X,
* and X is the solution of the original system.
*
* m_loc (input) int (local)
* The local row dimension of matrix B.
*
* fst_row (input) int (global)
* The row number of B's first row in the global matrix.
*
* ldb (input) int (local)
* The leading dimension of matrix B.
*
* nrhs (input) int (global)
* Number of right-hand sides.
*
* SOLVEstruct (output) SOLVEstruct_t* (global)
* Contains the information for the communication during the
* solution phase.
*
* stat (output) SuperLUStat_t*
* Record the statistics about the triangular solves.
* See util.h for the definition of 'SuperLUStat_t'.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
*
*/
Glu_persist_t *Glu_persist = LUstruct->Glu_persist;
LocalLU_t *Llu = LUstruct->Llu;
doublecomplex alpha = {1.0, 0.0};
doublecomplex zero = {0.0, 0.0};
doublecomplex *lsum; /* Local running sum of the updates to B-components */
doublecomplex *x; /* X component at step k. */
/* NOTE: x and lsum are of same size. */
doublecomplex *lusup, *dest;
doublecomplex *recvbuf, *tempv;
doublecomplex *rtemp; /* Result of full matrix-vector multiply. */
int_t **Ufstnz_br_ptr = Llu->Ufstnz_br_ptr;
int_t *Urbs, *Urbs1; /* Number of row blocks in each block column of U. */
Ucb_indptr_t **Ucb_indptr;/* Vertical linked list pointing to Uindex[] */
int_t **Ucb_valptr; /* Vertical linked list pointing to Unzval[] */
int_t iam, kcol, krow, mycol, myrow;
int_t i, ii, il, j, jj, k, lb, ljb, lk, lptr, luptr;
int_t nb, nlb, nub, nsupers;
int_t *xsup, *supno, *lsub, *usub;
int_t *ilsum; /* Starting position of each supernode in lsum (LOCAL)*/
int_t Pc, Pr;
int knsupc, nsupr;
int ldalsum; /* Number of lsum entries locally owned. */
int maxrecvsz, p, pi;
int_t **Lrowind_bc_ptr;
doublecomplex **Lnzval_bc_ptr;
MPI_Status status;
#ifdef ISEND_IRECV
MPI_Request *send_req, recv_req;
#endif
pxgstrs_comm_t *gstrs_comm = SOLVEstruct->gstrs_comm;
/*-- Counts used for L-solve --*/
int_t *fmod; /* Modification count for L-solve --
Count the number of local block products to
be summed into lsum[lk]. */
int_t **fsendx_plist = Llu->fsendx_plist;
int_t nfrecvx = Llu->nfrecvx; /* Number of X components to be recv'd. */
int_t *frecv; /* Count of lsum[lk] contributions to be received
from processes in this row.
It is only valid on the diagonal processes. */
int_t nfrecvmod = 0; /* Count of total modifications to be recv'd. */
int_t nleaf = 0, nroot = 0;
/*-- Counts used for U-solve --*/
int_t *bmod; /* Modification count for U-solve. */
int_t **bsendx_plist = Llu->bsendx_plist;
int_t nbrecvx = Llu->nbrecvx; /* Number of X components to be recv'd. */
int_t *brecv; /* Count of modifications to be recv'd from
processes in this row. */
int_t nbrecvmod = 0; /* Count of total modifications to be recv'd. */
double t;
#if ( DEBUGlevel>=2 )
int_t Ublocks = 0;
#endif
t = SuperLU_timer_();
/* Test input parameters. */
*info = 0;
if ( n < 0 ) *info = -1;
else if ( nrhs < 0 ) *info = -9;
if ( *info ) {
pxerbla("PZGSTRS", grid, -*info);
return;
}
/*
* Initialization.
*/
iam = grid->iam;
Pc = grid->npcol;
Pr = grid->nprow;
myrow = MYROW( iam, grid );
mycol = MYCOL( iam, grid );
xsup = Glu_persist->xsup;
supno = Glu_persist->supno;
nsupers = supno[n-1] + 1;
Lrowind_bc_ptr = Llu->Lrowind_bc_ptr;
Lnzval_bc_ptr = Llu->Lnzval_bc_ptr;
nlb = CEILING( nsupers, Pr ); /* Number of local block rows. */
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Enter pzgstrs()");
#endif
stat->ops[SOLVE] = 0.0;
Llu->SolveMsgSent = 0;
/* Save the count to be altered so it can be used by
subsequent call to PDGSTRS. */
if ( !(fmod = intMalloc_dist(nlb)) )
ABORT("Calloc fails for fmod[].");
for (i = 0; i < nlb; ++i) fmod[i] = Llu->fmod[i];
if ( !(frecv = intMalloc_dist(nlb)) )
ABORT("Malloc fails for frecv[].");
Llu->frecv = frecv;
#ifdef ISEND_IRECV
k = SUPERLU_MAX( Llu->nfsendx, Llu->nbsendx ) + nlb;
if ( !(send_req = (MPI_Request*) SUPERLU_MALLOC(k*sizeof(MPI_Request))) )
ABORT("Malloc fails for send_req[].");
#endif
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("N", strlen("N"));
ftcs3 = _cptofcd("U", strlen("U"));
#endif
/* Obtain ilsum[] and ldalsum for process column 0. */
ilsum = Llu->ilsum;
ldalsum = Llu->ldalsum;
/* Allocate working storage. */
knsupc = sp_ienv_dist(3);
maxrecvsz = knsupc * nrhs + SUPERLU_MAX( XK_H, LSUM_H );
if ( !(lsum = doublecomplexCalloc_dist(((size_t)ldalsum)*nrhs + nlb*LSUM_H)) )
ABORT("Calloc fails for lsum[].");
if ( !(x = doublecomplexMalloc_dist(ldalsum * nrhs + nlb * XK_H)) )
ABORT("Malloc fails for x[].");
if ( !(recvbuf = doublecomplexMalloc_dist(maxrecvsz)) )
ABORT("Malloc fails for recvbuf[].");
if ( !(rtemp = doublecomplexCalloc_dist(maxrecvsz)) )
ABORT("Malloc fails for rtemp[].");
/*---------------------------------------------------
* Forward solve Ly = b.
*---------------------------------------------------*/
/* Redistribute B into X on the diagonal processes. */
pzReDistribute_B_to_X(B, m_loc, nrhs, ldb, fst_row, ilsum, x,
ScalePermstruct, Glu_persist, grid, SOLVEstruct);
/* Set up the headers in lsum[]. */
ii = 0;
for (k = 0; k < nsupers; ++k) {
knsupc = SuperSize( k );
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* Local block number. */
il = LSUM_BLK( lk );
lsum[il - LSUM_H].r = k;/* Block number prepended in the header.*/
lsum[il - LSUM_H].i = 0;
}
ii += knsupc;
}
/*
* Compute frecv[] and nfrecvmod counts on the diagonal processes.
*/
{
superlu_scope_t *scp = &grid->rscp;
for (k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* Local block number. */
kcol = PCOL( k, grid ); /* Root process in this row scope. */
if ( mycol != kcol && fmod[lk] )
i = 1; /* Contribution from non-diagonal process. */
else i = 0;
MPI_Reduce( &i, &frecv[lk], 1, mpi_int_t,
MPI_SUM, kcol, scp->comm );
if ( mycol == kcol ) { /* Diagonal process. */
nfrecvmod += frecv[lk];
if ( !frecv[lk] && !fmod[lk] ) ++nleaf;
#if ( DEBUGlevel>=2 )
printf("(%2d) frecv[%4d] %2d\n", iam, k, frecv[lk]);
assert( frecv[lk] < Pc );
#endif
}
}
}
}
/* ---------------------------------------------------------
Solve the leaf nodes first by all the diagonal processes.
--------------------------------------------------------- */
#if ( DEBUGlevel>=2 )
printf("(%2d) nleaf %4d\n", iam, nleaf);
#endif
for (k = 0; k < nsupers && nleaf; ++k) {
krow = PROW( k, grid );
kcol = PCOL( k, grid );
if ( myrow == krow && mycol == kcol ) { /* Diagonal process */
knsupc = SuperSize( k );
lk = LBi( k, grid );
if ( frecv[lk]==0 && fmod[lk]==0 ) {
fmod[lk] = -1; /* Do not solve X[k] in the future. */
ii = X_BLK( lk );
lk = LBj( k, grid ); /* Local block number, column-wise. */
lsub = Lrowind_bc_ptr[lk];
lusup = Lnzval_bc_ptr[lk];
nsupr = lsub[1];
#ifdef _CRAY
CTRSM(ftcs1, ftcs1, ftcs2, ftcs3, &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc);
#elif defined (USE_VENDOR_BLAS)
ztrsm_("L", "L", "N", "U", &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc, 1, 1, 1, 1);
#else
ztrsm_("L", "L", "N", "U", &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc);
#endif
stat->ops[SOLVE] += 4 * knsupc * (knsupc - 1) * nrhs
+ 10 * knsupc * nrhs; /* complex division */
--nleaf;
#if ( DEBUGlevel>=2 )
printf("(%2d) Solve X[%2d]\n", iam, k);
#endif
/*
* Send Xk to process column Pc[k].
*/
for (p = 0; p < Pr; ++p) {
if ( fsendx_plist[lk][p] != EMPTY ) {
pi = PNUM( p, kcol, grid );
#ifdef ISEND_IRECV
MPI_Isend( &x[ii - XK_H], knsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm,
&send_req[Llu->SolveMsgSent++]);
#else
MPI_Send( &x[ii - XK_H], knsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm );
#endif
#if ( DEBUGlevel>=2 )
printf("(%2d) Sent X[%2.0f] to P %2d\n",
iam, x[ii-XK_H], pi);
#endif
}
}
/*
* Perform local block modifications: lsum[i] -= L_i,k * X[k]
*/
nb = lsub[0] - 1;
lptr = BC_HEADER + LB_DESCRIPTOR + knsupc;
luptr = knsupc; /* Skip diagonal block L(k,k). */
zlsum_fmod(lsum, x, &x[ii], rtemp, nrhs, knsupc, k,
fmod, nb, lptr, luptr, xsup, grid, Llu,
send_req, stat);
}
} /* if diagonal process ... */
} /* for k ... */
/* -----------------------------------------------------------
Compute the internal nodes asynchronously by all processes.
----------------------------------------------------------- */
#if ( DEBUGlevel>=2 )
printf("(%2d) nfrecvx %4d, nfrecvmod %4d, nleaf %4d\n",
iam, nfrecvx, nfrecvmod, nleaf);
#endif
while ( nfrecvx || nfrecvmod ) { /* While not finished. */
/* Receive a message. */
#ifdef ISEND_IRECV
/* -MPI- FATAL: Remote protocol queue full */
MPI_Irecv( recvbuf, maxrecvsz, SuperLU_MPI_DOUBLE_COMPLEX,
MPI_ANY_SOURCE, MPI_ANY_TAG, grid->comm, &recv_req );
MPI_Wait( &recv_req, &status );
#else
MPI_Recv( recvbuf, maxrecvsz, SuperLU_MPI_DOUBLE_COMPLEX,
MPI_ANY_SOURCE, MPI_ANY_TAG, grid->comm, &status );
#endif
k = (*recvbuf).r;
#if ( DEBUGlevel>=2 )
printf("(%2d) Recv'd block %d, tag %2d\n", iam, k, status.MPI_TAG);
#endif
switch ( status.MPI_TAG ) {
case Xk:
--nfrecvx;
lk = LBj( k, grid ); /* Local block number, column-wise. */
lsub = Lrowind_bc_ptr[lk];
lusup = Lnzval_bc_ptr[lk];
if ( lsub ) {
nb = lsub[0];
lptr = BC_HEADER;
luptr = 0;
knsupc = SuperSize( k );
/*
* Perform local block modifications: lsum[i] -= L_i,k * X[k]
*/
zlsum_fmod(lsum, x, &recvbuf[XK_H], rtemp, nrhs, knsupc, k,
fmod, nb, lptr, luptr, xsup, grid, Llu,
send_req, stat);
} /* if lsub */
break;
case LSUM: /* Receiver must be a diagonal process */
--nfrecvmod;
lk = LBi( k, grid ); /* Local block number, row-wise. */
ii = X_BLK( lk );
knsupc = SuperSize( k );
tempv = &recvbuf[LSUM_H];
RHS_ITERATE(j) {
for (i = 0; i < knsupc; ++i)
z_add(&x[i + ii + j*knsupc],
&x[i + ii + j*knsupc],
&tempv[i + j*knsupc]);
}
if ( (--frecv[lk])==0 && fmod[lk]==0 ) {
fmod[lk] = -1; /* Do not solve X[k] in the future. */
lk = LBj( k, grid ); /* Local block number, column-wise. */
lsub = Lrowind_bc_ptr[lk];
lusup = Lnzval_bc_ptr[lk];
nsupr = lsub[1];
#ifdef _CRAY
CTRSM(ftcs1, ftcs1, ftcs2, ftcs3, &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc);
#elif defined (USE_VENDOR_BLAS)
ztrsm_("L", "L", "N", "U", &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc, 1, 1, 1, 1);
#else
ztrsm_("L", "L", "N", "U", &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc);
#endif
stat->ops[SOLVE] += 4 * knsupc * (knsupc - 1) * nrhs
+ 10 * knsupc * nrhs; /* complex division */
#if ( DEBUGlevel>=2 )
printf("(%2d) Solve X[%2d]\n", iam, k);
#endif
/*
* Send Xk to process column Pc[k].
*/
kcol = PCOL( k, grid );
for (p = 0; p < Pr; ++p) {
if ( fsendx_plist[lk][p] != EMPTY ) {
pi = PNUM( p, kcol, grid );
#ifdef ISEND_IRECV
MPI_Isend( &x[ii-XK_H], knsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm,
&send_req[Llu->SolveMsgSent++]);
#else
MPI_Send( &x[ii - XK_H], knsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm );
#endif
#if ( DEBUGlevel>=2 )
printf("(%2d) Sent X[%2.0f] to P %2d\n",
iam, x[ii-XK_H], pi);
#endif
}
}
/*
* Perform local block modifications.
*/
nb = lsub[0] - 1;
lptr = BC_HEADER + LB_DESCRIPTOR + knsupc;
luptr = knsupc; /* Skip diagonal block L(k,k). */
zlsum_fmod(lsum, x, &x[ii], rtemp, nrhs, knsupc, k,
fmod, nb, lptr, luptr, xsup, grid, Llu,
send_req, stat);
} /* if */
break;
#if ( DEBUGlevel>=2 )
default:
printf("(%2d) Recv'd wrong message tag %4d\n", status.MPI_TAG);
break;
#endif
} /* switch */
} /* while not finished ... */
#if ( PRNTlevel>=2 )
t = SuperLU_timer_() - t;
if ( !iam ) printf(".. L-solve time\t%8.2f\n", t);
t = SuperLU_timer_();
#endif
#if ( DEBUGlevel==2 )
{
printf("(%d) .. After L-solve: y =\n", iam);
for (i = 0, k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
kcol = PCOL( k, grid );
if ( myrow == krow && mycol == kcol ) { /* Diagonal process */
knsupc = SuperSize( k );
lk = LBi( k, grid );
ii = X_BLK( lk );
for (j = 0; j < knsupc; ++j)
printf("\t(%d)\t%4d\t%.10f\n", iam, xsup[k]+j, x[ii+j]);
fflush(stdout);
}
MPI_Barrier( grid->comm );
}
}
#endif
SUPERLU_FREE(fmod);
SUPERLU_FREE(frecv);
SUPERLU_FREE(rtemp);
#ifdef ISEND_IRECV
for (i = 0; i < Llu->SolveMsgSent; ++i) MPI_Request_free(&send_req[i]);
Llu->SolveMsgSent = 0;
#endif
/*---------------------------------------------------
* Back solve Ux = y.
*
* The Y components from the forward solve is already
* on the diagonal processes.
*---------------------------------------------------*/
/* Save the count to be altered so it can be used by
subsequent call to PZGSTRS. */
if ( !(bmod = intMalloc_dist(nlb)) )
ABORT("Calloc fails for bmod[].");
for (i = 0; i < nlb; ++i) bmod[i] = Llu->bmod[i];
if ( !(brecv = intMalloc_dist(nlb)) )
ABORT("Malloc fails for brecv[].");
Llu->brecv = brecv;
/*
* Compute brecv[] and nbrecvmod counts on the diagonal processes.
*/
{
superlu_scope_t *scp = &grid->rscp;
for (k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* Local block number. */
kcol = PCOL( k, grid ); /* Root process in this row scope. */
if ( mycol != kcol && bmod[lk] )
i = 1; /* Contribution from non-diagonal process. */
else i = 0;
MPI_Reduce( &i, &brecv[lk], 1, mpi_int_t,
MPI_SUM, kcol, scp->comm );
if ( mycol == kcol ) { /* Diagonal process. */
nbrecvmod += brecv[lk];
if ( !brecv[lk] && !bmod[lk] ) ++nroot;
#if ( DEBUGlevel>=2 )
printf("(%2d) brecv[%4d] %2d\n", iam, k, brecv[lk]);
assert( brecv[lk] < Pc );
#endif
}
}
}
}
/* Re-initialize lsum to zero. Each block header is already in place. */
for (k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
if ( myrow == krow ) {
knsupc = SuperSize( k );
lk = LBi( k, grid );
il = LSUM_BLK( lk );
dest = &lsum[il];
RHS_ITERATE(j) {
for (i = 0; i < knsupc; ++i) dest[i + j*knsupc] = zero;
}
}
}
void
pzgstrs_Bglobal(int_t n, LUstruct_t *LUstruct, gridinfo_t *grid,
doublecomplex *B, int_t ldb, int nrhs,
SuperLUStat_t *stat, int *info)
{
Glu_persist_t *Glu_persist = LUstruct->Glu_persist;
LocalLU_t *Llu = LUstruct->Llu;
doublecomplex alpha = {1.0, 0.0};
doublecomplex zero = {0.0, 0.0};
doublecomplex *lsum; /* Local running sum of the updates to B-components */
doublecomplex *x; /* X component at step k. */
doublecomplex *lusup, *dest;
doublecomplex *recvbuf, *tempv;
doublecomplex *rtemp; /* Result of full matrix-vector multiply. */
int_t **Ufstnz_br_ptr = Llu->Ufstnz_br_ptr;
int_t *Urbs, *Urbs1; /* Number of row blocks in each block column of U. */
Ucb_indptr_t **Ucb_indptr;/* Vertical linked list pointing to Uindex[] */
int_t **Ucb_valptr; /* Vertical linked list pointing to Unzval[] */
int_t kcol, krow, mycol, myrow;
int_t i, ii, il, j, jj, k, lb, ljb, lk, lptr, luptr;
int_t nb, nlb, nub, nsupers;
int_t *xsup, *lsub, *usub;
int_t *ilsum; /* Starting position of each supernode in lsum (LOCAL)*/
int Pc, Pr, iam;
int knsupc, nsupr;
int ldalsum; /* Number of lsum entries locally owned. */
int maxrecvsz, p, pi;
int_t **Lrowind_bc_ptr;
doublecomplex **Lnzval_bc_ptr;
MPI_Status status;
#if defined (ISEND_IRECV) || defined (BSEND)
MPI_Request *send_req, recv_req;
#endif
/*-- Counts used for L-solve --*/
int_t *fmod; /* Modification count for L-solve. */
int_t **fsendx_plist = Llu->fsendx_plist;
int_t nfrecvx = Llu->nfrecvx; /* Number of X components to be recv'd. */
int_t *frecv; /* Count of modifications to be recv'd from
processes in this row. */
int_t nfrecvmod = 0; /* Count of total modifications to be recv'd. */
int_t nleaf = 0, nroot = 0;
/*-- Counts used for U-solve --*/
int_t *bmod; /* Modification count for L-solve. */
int_t **bsendx_plist = Llu->bsendx_plist;
int_t nbrecvx = Llu->nbrecvx; /* Number of X components to be recv'd. */
int_t *brecv; /* Count of modifications to be recv'd from
processes in this row. */
int_t nbrecvmod = 0; /* Count of total modifications to be recv'd. */
double t;
#if ( DEBUGlevel>=2 )
int_t Ublocks = 0;
#endif
int_t *mod_bit = Llu->mod_bit; /* flag contribution from each row block */
t = SuperLU_timer_();
/* Test input parameters. */
*info = 0;
if ( n < 0 ) *info = -1;
else if ( nrhs < 0 ) *info = -9;
if ( *info ) {
pxerr_dist("PZGSTRS_BGLOBAL", grid, -*info);
return;
}
/*
* Initialization.
*/
iam = grid->iam;
Pc = grid->npcol;
Pr = grid->nprow;
myrow = MYROW( iam, grid );
mycol = MYCOL( iam, grid );
nsupers = Glu_persist->supno[n-1] + 1;
xsup = Glu_persist->xsup;
Lrowind_bc_ptr = Llu->Lrowind_bc_ptr;
Lnzval_bc_ptr = Llu->Lnzval_bc_ptr;
nlb = CEILING( nsupers, Pr ); /* Number of local block rows. */
stat->ops[SOLVE] = 0.0;
Llu->SolveMsgSent = 0;
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Enter pzgstrs_Bglobal()");
#endif
/* Save the count to be altered so it can be used by
subsequent call to PDGSTRS_BGLOBAL. */
if ( !(fmod = intMalloc_dist(nlb)) )
ABORT("Calloc fails for fmod[].");
for (i = 0; i < nlb; ++i) fmod[i] = Llu->fmod[i];
if ( !(frecv = intMalloc_dist(nlb)) )
ABORT("Malloc fails for frecv[].");
Llu->frecv = frecv;
#if defined (ISEND_IRECV) || defined (BSEND)
k = SUPERLU_MAX( Llu->nfsendx, Llu->nbsendx ) + nlb;
if ( !(send_req = (MPI_Request*) SUPERLU_MALLOC(k*sizeof(MPI_Request))) )
ABORT("Malloc fails for send_req[].");
#endif
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("N", strlen("N"));
ftcs3 = _cptofcd("U", strlen("U"));
#endif
/* Obtain ilsum[] and ldalsum for process column 0. */
ilsum = Llu->ilsum;
ldalsum = Llu->ldalsum;
/* Allocate working storage. */
knsupc = sp_ienv_dist(3);
maxrecvsz = knsupc * nrhs + SUPERLU_MAX( XK_H, LSUM_H );
if ( !(lsum = doublecomplexCalloc_dist(((size_t)ldalsum) * nrhs
+ nlb * LSUM_H)) )
ABORT("Calloc fails for lsum[].");
if ( !(x = doublecomplexMalloc_dist(((size_t)ldalsum) * nrhs
+ nlb * XK_H)) )
ABORT("Malloc fails for x[].");
if ( !(recvbuf = doublecomplexMalloc_dist(maxrecvsz)) )
ABORT("Malloc fails for recvbuf[].");
if ( !(rtemp = doublecomplexCalloc_dist(maxrecvsz)) )
ABORT("Malloc fails for rtemp[].");
/*---------------------------------------------------
* Forward solve Ly = b.
*---------------------------------------------------*/
/*
* Copy B into X on the diagonal processes.
*/
ii = 0;
for (k = 0; k < nsupers; ++k) {
knsupc = SuperSize( k );
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* Local block number. */
il = LSUM_BLK( lk );
lsum[il - LSUM_H].r = k;/* Block number prepended in the header. */
lsum[il - LSUM_H].i = 0;
kcol = PCOL( k, grid );
if ( mycol == kcol ) { /* Diagonal process. */
jj = X_BLK( lk );
x[jj - XK_H].r = k; /* Block number prepended in the header. */
x[jj - XK_H].i = 0;
RHS_ITERATE(j)
for (i = 0; i < knsupc; ++i) /* X is stored in blocks. */
x[i + jj + j*knsupc] = B[i + ii + j*ldb];
}
}
void
pzgstrs(int_t n, LUstruct_t *LUstruct,
ScalePermstruct_t *ScalePermstruct,
gridinfo_t *grid, doublecomplex *B,
int_t m_loc, int_t fst_row, int_t ldb, int nrhs,
SOLVEstruct_t *SOLVEstruct,
SuperLUStat_t *stat, int *info)
{
Glu_persist_t *Glu_persist = LUstruct->Glu_persist;
LocalLU_t *Llu = LUstruct->Llu;
doublecomplex alpha = {1.0, 0.0};
doublecomplex zero = {0.0, 0.0};
doublecomplex *lsum; /* Local running sum of the updates to B-components */
doublecomplex *x; /* X component at step k. */
/* NOTE: x and lsum are of same size. */
doublecomplex *lusup, *dest;
doublecomplex *recvbuf, *tempv;
doublecomplex *rtemp; /* Result of full matrix-vector multiply. */
int_t **Ufstnz_br_ptr = Llu->Ufstnz_br_ptr;
int_t *Urbs, *Urbs1; /* Number of row blocks in each block column of U. */
Ucb_indptr_t **Ucb_indptr;/* Vertical linked list pointing to Uindex[] */
int_t **Ucb_valptr; /* Vertical linked list pointing to Unzval[] */
int_t iam, kcol, krow, mycol, myrow;
int_t i, ii, il, j, jj, k, lb, ljb, lk, lptr, luptr;
int_t nb, nlb, nub, nsupers;
int_t *xsup, *supno, *lsub, *usub;
int_t *ilsum; /* Starting position of each supernode in lsum (LOCAL)*/
int_t Pc, Pr;
int knsupc, nsupr;
int ldalsum; /* Number of lsum entries locally owned. */
int maxrecvsz, p, pi;
int_t **Lrowind_bc_ptr;
doublecomplex **Lnzval_bc_ptr;
MPI_Status status;
MPI_Request *send_req, recv_req;
pxgstrs_comm_t *gstrs_comm = SOLVEstruct->gstrs_comm;
/*-- Counts used for L-solve --*/
int_t *fmod; /* Modification count for L-solve --
Count the number of local block products to
be summed into lsum[lk]. */
int_t **fsendx_plist = Llu->fsendx_plist;
int_t nfrecvx = Llu->nfrecvx; /* Number of X components to be recv'd. */
int_t *frecv; /* Count of lsum[lk] contributions to be received
from processes in this row.
It is only valid on the diagonal processes. */
int_t nfrecvmod = 0; /* Count of total modifications to be recv'd. */
int_t nleaf = 0, nroot = 0;
/*-- Counts used for U-solve --*/
int_t *bmod; /* Modification count for U-solve. */
int_t **bsendx_plist = Llu->bsendx_plist;
int_t nbrecvx = Llu->nbrecvx; /* Number of X components to be recv'd. */
int_t *brecv; /* Count of modifications to be recv'd from
processes in this row. */
int_t nbrecvmod = 0; /* Count of total modifications to be recv'd. */
double t;
#if ( DEBUGlevel>=2 )
int_t Ublocks = 0;
#endif
int_t *mod_bit = Llu->mod_bit; /* flag contribution from each row block */
t = SuperLU_timer_();
/* Test input parameters. */
*info = 0;
if ( n < 0 ) *info = -1;
else if ( nrhs < 0 ) *info = -9;
if ( *info ) {
pxerbla("PZGSTRS", grid, -*info);
return;
}
/*
* Initialization.
*/
iam = grid->iam;
Pc = grid->npcol;
Pr = grid->nprow;
myrow = MYROW( iam, grid );
mycol = MYCOL( iam, grid );
xsup = Glu_persist->xsup;
supno = Glu_persist->supno;
nsupers = supno[n-1] + 1;
Lrowind_bc_ptr = Llu->Lrowind_bc_ptr;
Lnzval_bc_ptr = Llu->Lnzval_bc_ptr;
nlb = CEILING( nsupers, Pr ); /* Number of local block rows. */
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Enter pzgstrs()");
#endif
stat->ops[SOLVE] = 0.0;
Llu->SolveMsgSent = 0;
/* Save the count to be altered so it can be used by
subsequent call to PDGSTRS. */
if ( !(fmod = intMalloc_dist(nlb)) )
ABORT("Calloc fails for fmod[].");
for (i = 0; i < nlb; ++i) fmod[i] = Llu->fmod[i];
if ( !(frecv = intMalloc_dist(nlb)) )
ABORT("Malloc fails for frecv[].");
Llu->frecv = frecv;
k = SUPERLU_MAX( Llu->nfsendx, Llu->nbsendx ) + nlb;
if ( !(send_req = (MPI_Request*) SUPERLU_MALLOC(k*sizeof(MPI_Request))) )
ABORT("Malloc fails for send_req[].");
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("N", strlen("N"));
ftcs3 = _cptofcd("U", strlen("U"));
#endif
/* Obtain ilsum[] and ldalsum for process column 0. */
ilsum = Llu->ilsum;
ldalsum = Llu->ldalsum;
/* Allocate working storage. */
knsupc = sp_ienv_dist(3);
maxrecvsz = knsupc * nrhs + SUPERLU_MAX( XK_H, LSUM_H );
if ( !(lsum = doublecomplexCalloc_dist(((size_t)ldalsum)*nrhs + nlb*LSUM_H)) )
ABORT("Calloc fails for lsum[].");
if ( !(x = doublecomplexMalloc_dist(ldalsum * nrhs + nlb * XK_H)) )
ABORT("Malloc fails for x[].");
if ( !(recvbuf = doublecomplexMalloc_dist(maxrecvsz)) )
ABORT("Malloc fails for recvbuf[].");
if ( !(rtemp = doublecomplexCalloc_dist(maxrecvsz)) )
ABORT("Malloc fails for rtemp[].");
/*---------------------------------------------------
* Forward solve Ly = b.
*---------------------------------------------------*/
/* Redistribute B into X on the diagonal processes. */
pzReDistribute_B_to_X(B, m_loc, nrhs, ldb, fst_row, ilsum, x,
ScalePermstruct, Glu_persist, grid, SOLVEstruct);
/* Set up the headers in lsum[]. */
ii = 0;
for (k = 0; k < nsupers; ++k) {
knsupc = SuperSize( k );
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* Local block number. */
il = LSUM_BLK( lk );
lsum[il - LSUM_H].r = k;/* Block number prepended in the header.*/
lsum[il - LSUM_H].i = 0;
}
ii += knsupc;
}
/*
* Compute frecv[] and nfrecvmod counts on the diagonal processes.
*/
{
superlu_scope_t *scp = &grid->rscp;
#if 1
for (k = 0; k < nlb; ++k) mod_bit[k] = 0;
for (k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* local block number */
kcol = PCOL( k, grid );
if ( mycol != kcol && fmod[lk] )
mod_bit[lk] = 1; /* contribution from off-diagonal */
}
}
/*PrintInt10("mod_bit", nlb, mod_bit);*/
#if ( PROFlevel>=2 )
t_reduce_tmp = SuperLU_timer_();
#endif
/* Every process receives the count, but it is only useful on the
diagonal processes. */
MPI_Allreduce( mod_bit, frecv, nlb, mpi_int_t, MPI_SUM, scp->comm );
#if ( PROFlevel>=2 )
t_reduce += SuperLU_timer_() - t_reduce_tmp;
#endif
for (k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* local block number */
kcol = PCOL( k, grid );
if ( mycol == kcol ) { /* diagonal process */
nfrecvmod += frecv[lk];
if ( !frecv[lk] && !fmod[lk] ) ++nleaf;
}
}
}
#else /* old */
for (k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* Local block number. */
kcol = PCOL( k, grid ); /* Root process in this row scope. */
if ( mycol != kcol && fmod[lk] )
i = 1; /* Contribution from non-diagonal process. */
else i = 0;
MPI_Reduce( &i, &frecv[lk], 1, mpi_int_t,
MPI_SUM, kcol, scp->comm );
if ( mycol == kcol ) { /* Diagonal process. */
nfrecvmod += frecv[lk];
if ( !frecv[lk] && !fmod[lk] ) ++nleaf;
#if ( DEBUGlevel>=2 )
printf("(%2d) frecv[%4d] %2d\n", iam, k, frecv[lk]);
assert( frecv[lk] < Pc );
#endif
}
}
}
#endif
}
/* ---------------------------------------------------------
Solve the leaf nodes first by all the diagonal processes.
--------------------------------------------------------- */
#if ( DEBUGlevel>=2 )
printf("(%2d) nleaf %4d\n", iam, nleaf);
#endif
for (k = 0; k < nsupers && nleaf; ++k) {
krow = PROW( k, grid );
kcol = PCOL( k, grid );
if ( myrow == krow && mycol == kcol ) { /* Diagonal process */
knsupc = SuperSize( k );
lk = LBi( k, grid );
if ( frecv[lk]==0 && fmod[lk]==0 ) {
fmod[lk] = -1; /* Do not solve X[k] in the future. */
ii = X_BLK( lk );
lk = LBj( k, grid ); /* Local block number, column-wise. */
lsub = Lrowind_bc_ptr[lk];
lusup = Lnzval_bc_ptr[lk];
nsupr = lsub[1];
#ifdef _CRAY
CTRSM(ftcs1, ftcs1, ftcs2, ftcs3, &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc);
#elif defined (USE_VENDOR_BLAS)
ztrsm_("L", "L", "N", "U", &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc, 1, 1, 1, 1);
#else
ztrsm_("L", "L", "N", "U", &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc);
#endif
stat->ops[SOLVE] += 4 * knsupc * (knsupc - 1) * nrhs
+ 10 * knsupc * nrhs; /* complex division */
--nleaf;
#if ( DEBUGlevel>=2 )
printf("(%2d) Solve X[%2d]\n", iam, k);
#endif
/*
* Send Xk to process column Pc[k].
*/
for (p = 0; p < Pr; ++p) {
if ( fsendx_plist[lk][p] != EMPTY ) {
pi = PNUM( p, kcol, grid );
MPI_Isend( &x[ii - XK_H], knsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm,
&send_req[Llu->SolveMsgSent++]);
#if 0
MPI_Send( &x[ii - XK_H], knsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm );
#endif
#if ( DEBUGlevel>=2 )
printf("(%2d) Sent X[%2.0f] to P %2d\n",
iam, x[ii-XK_H], pi);
#endif
}
}
/*
* Perform local block modifications: lsum[i] -= L_i,k * X[k]
*/
nb = lsub[0] - 1;
lptr = BC_HEADER + LB_DESCRIPTOR + knsupc;
luptr = knsupc; /* Skip diagonal block L(k,k). */
zlsum_fmod(lsum, x, &x[ii], rtemp, nrhs, knsupc, k,
fmod, nb, lptr, luptr, xsup, grid, Llu,
send_req, stat);
}
} /* if diagonal process ... */
} /* for k ... */
/* -----------------------------------------------------------
Compute the internal nodes asynchronously by all processes.
----------------------------------------------------------- */
#if ( DEBUGlevel>=2 )
printf("(%2d) nfrecvx %4d, nfrecvmod %4d, nleaf %4d\n",
iam, nfrecvx, nfrecvmod, nleaf);
#endif
while ( nfrecvx || nfrecvmod ) { /* While not finished. */
/* Receive a message. */
MPI_Recv( recvbuf, maxrecvsz, SuperLU_MPI_DOUBLE_COMPLEX,
MPI_ANY_SOURCE, MPI_ANY_TAG, grid->comm, &status );
k = (*recvbuf).r;
#if ( DEBUGlevel>=2 )
printf("(%2d) Recv'd block %d, tag %2d\n", iam, k, status.MPI_TAG);
#endif
switch ( status.MPI_TAG ) {
case Xk:
--nfrecvx;
lk = LBj( k, grid ); /* Local block number, column-wise. */
lsub = Lrowind_bc_ptr[lk];
lusup = Lnzval_bc_ptr[lk];
if ( lsub ) {
nb = lsub[0];
lptr = BC_HEADER;
luptr = 0;
knsupc = SuperSize( k );
/*
* Perform local block modifications: lsum[i] -= L_i,k * X[k]
*/
zlsum_fmod(lsum, x, &recvbuf[XK_H], rtemp, nrhs, knsupc, k,
fmod, nb, lptr, luptr, xsup, grid, Llu,
send_req, stat);
} /* if lsub */
break;
case LSUM: /* Receiver must be a diagonal process */
--nfrecvmod;
lk = LBi( k, grid ); /* Local block number, row-wise. */
ii = X_BLK( lk );
knsupc = SuperSize( k );
tempv = &recvbuf[LSUM_H];
RHS_ITERATE(j) {
for (i = 0; i < knsupc; ++i)
z_add(&x[i + ii + j*knsupc],
&x[i + ii + j*knsupc],
&tempv[i + j*knsupc]);
}
if ( (--frecv[lk])==0 && fmod[lk]==0 ) {
fmod[lk] = -1; /* Do not solve X[k] in the future. */
lk = LBj( k, grid ); /* Local block number, column-wise. */
lsub = Lrowind_bc_ptr[lk];
lusup = Lnzval_bc_ptr[lk];
nsupr = lsub[1];
#ifdef _CRAY
CTRSM(ftcs1, ftcs1, ftcs2, ftcs3, &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc);
#elif defined (USE_VENDOR_BLAS)
ztrsm_("L", "L", "N", "U", &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc, 1, 1, 1, 1);
#else
ztrsm_("L", "L", "N", "U", &knsupc, &nrhs, &alpha,
lusup, &nsupr, &x[ii], &knsupc);
#endif
stat->ops[SOLVE] += 4 * knsupc * (knsupc - 1) * nrhs
+ 10 * knsupc * nrhs; /* complex division */
#if ( DEBUGlevel>=2 )
printf("(%2d) Solve X[%2d]\n", iam, k);
#endif
/*
* Send Xk to process column Pc[k].
*/
kcol = PCOL( k, grid );
for (p = 0; p < Pr; ++p) {
if ( fsendx_plist[lk][p] != EMPTY ) {
pi = PNUM( p, kcol, grid );
MPI_Isend( &x[ii-XK_H], knsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm,
&send_req[Llu->SolveMsgSent++]);
#if 0
MPI_Send( &x[ii - XK_H], knsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm );
#endif
#if ( DEBUGlevel>=2 )
printf("(%2d) Sent X[%2.0f] to P %2d\n",
iam, x[ii-XK_H], pi);
#endif
}
}
/*
* Perform local block modifications.
*/
nb = lsub[0] - 1;
lptr = BC_HEADER + LB_DESCRIPTOR + knsupc;
luptr = knsupc; /* Skip diagonal block L(k,k). */
zlsum_fmod(lsum, x, &x[ii], rtemp, nrhs, knsupc, k,
fmod, nb, lptr, luptr, xsup, grid, Llu,
send_req, stat);
} /* if */
break;
#if ( DEBUGlevel>=2 )
default:
printf("(%2d) Recv'd wrong message tag %4d\n", status.MPI_TAG);
break;
#endif
} /* switch */
} /* while not finished ... */
#if ( PRNTlevel>=2 )
t = SuperLU_timer_() - t;
if ( !iam ) printf(".. L-solve time\t%8.2f\n", t);
t = SuperLU_timer_();
#endif
#if ( DEBUGlevel==2 )
{
printf("(%d) .. After L-solve: y =\n", iam);
for (i = 0, k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
kcol = PCOL( k, grid );
if ( myrow == krow && mycol == kcol ) { /* Diagonal process */
knsupc = SuperSize( k );
lk = LBi( k, grid );
ii = X_BLK( lk );
for (j = 0; j < knsupc; ++j)
printf("\t(%d)\t%4d\t%.10f\n", iam, xsup[k]+j, x[ii+j]);
fflush(stdout);
}
MPI_Barrier( grid->comm );
}
}
#endif
SUPERLU_FREE(fmod);
SUPERLU_FREE(frecv);
SUPERLU_FREE(rtemp);
/*for (i = 0; i < Llu->SolveMsgSent; ++i) MPI_Request_free(&send_req[i]);*/
for (i = 0; i < Llu->SolveMsgSent; ++i) MPI_Wait(&send_req[i], &status);
Llu->SolveMsgSent = 0;
MPI_Barrier( grid->comm );
/*---------------------------------------------------
* Back solve Ux = y.
*
* The Y components from the forward solve is already
* on the diagonal processes.
*---------------------------------------------------*/
/* Save the count to be altered so it can be used by
subsequent call to PZGSTRS. */
if ( !(bmod = intMalloc_dist(nlb)) )
ABORT("Calloc fails for bmod[].");
for (i = 0; i < nlb; ++i) bmod[i] = Llu->bmod[i];
if ( !(brecv = intMalloc_dist(nlb)) )
ABORT("Malloc fails for brecv[].");
Llu->brecv = brecv;
/*
* Compute brecv[] and nbrecvmod counts on the diagonal processes.
*/
{
superlu_scope_t *scp = &grid->rscp;
#if 1
for (k = 0; k < nlb; ++k) mod_bit[k] = 0;
for (k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* local block number */
kcol = PCOL( k, grid ); /* root process in this row scope */
if ( mycol != kcol && bmod[lk] )
mod_bit[lk] = 1; /* Contribution from off-diagonal */
}
}
/* Every process receives the count, but it is only useful on the
diagonal processes. */
MPI_Allreduce( mod_bit, brecv, nlb, mpi_int_t, MPI_SUM, scp->comm );
for (k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* local block number */
kcol = PCOL( k, grid ); /* root process in this row scope. */
if ( mycol == kcol ) { /* diagonal process */
nbrecvmod += brecv[lk];
if ( !brecv[lk] && !bmod[lk] ) ++nroot;
#if ( DEBUGlevel>=2 )
printf("(%2d) brecv[%4d] %2d\n", iam, k, brecv[lk]);
assert( brecv[lk] < Pc );
#endif
}
}
}
#else /* old */
for (k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
if ( myrow == krow ) {
lk = LBi( k, grid ); /* Local block number. */
kcol = PCOL( k, grid ); /* Root process in this row scope. */
if ( mycol != kcol && bmod[lk] )
i = 1; /* Contribution from non-diagonal process. */
else i = 0;
MPI_Reduce( &i, &brecv[lk], 1, mpi_int_t,
MPI_SUM, kcol, scp->comm );
if ( mycol == kcol ) { /* Diagonal process. */
nbrecvmod += brecv[lk];
if ( !brecv[lk] && !bmod[lk] ) ++nroot;
#if ( DEBUGlevel>=2 )
printf("(%2d) brecv[%4d] %2d\n", iam, k, brecv[lk]);
assert( brecv[lk] < Pc );
#endif
}
}
}
#endif
}
/* Re-initialize lsum to zero. Each block header is already in place. */
for (k = 0; k < nsupers; ++k) {
krow = PROW( k, grid );
if ( myrow == krow ) {
knsupc = SuperSize( k );
lk = LBi( k, grid );
il = LSUM_BLK( lk );
dest = &lsum[il];
RHS_ITERATE(j) {
for (i = 0; i < knsupc; ++i) dest[i + j*knsupc] = zero;
}
}
}
void pzgstrf
/************************************************************************/
(
superlu_options_t_Distributed *options, int m, int n, double anorm,
LUstruct_t *LUstruct, gridinfo_t *grid, SuperLUStat_t *stat, int *info
)
/*
* Purpose
* =======
*
* pzgstrf performs the LU factorization in parallel.
*
* Arguments
* =========
*
* options (input) superlu_options_t_Distributed*
* The structure defines the input parameters to control
* how the LU decomposition will be performed.
* The following field should be defined:
* o ReplaceTinyPivot (yes_no_t)
* Specifies whether to replace the tiny diagonals by
* sqrt(epsilon)*norm(A) during LU factorization.
*
* m (input) int
* Number of rows in the matrix.
*
* n (input) int
* Number of columns in the matrix.
*
* anorm (input) double
* The norm of the original matrix A, or the scaled A if
* equilibration was done.
*
* LUstruct (input/output) LUstruct_t*
* The data structures to store the distributed L and U factors.
* The following fields should be defined:
*
* o Glu_persist (input) Glu_persist_t*
* Global data structure (xsup, supno) replicated on all processes,
* describing the supernode partition in the factored matrices
* L and U:
* xsup[s] is the leading column of the s-th supernode,
* supno[i] is the supernode number to which column i belongs.
*
* o Llu (input/output) LocalLU_t*
* The distributed data structures to store L and U factors.
* See superlu_zdefs.h for the definition of 'LocalLU_t'.
*
* grid (input) gridinfo_t*
* The 2D process mesh. It contains the MPI communicator, the number
* of process rows (NPROW), the number of process columns (NPCOL),
* and my process rank. It is an input argument to all the
* parallel routines.
* Grid can be initialized by subroutine SUPERLU_GRIDINIT.
* See superlu_zdefs.h for the definition of 'gridinfo_t'.
*
* stat (output) SuperLUStat_t*
* Record the statistics on runtime and floating-point operation count.
* See util.h for the definition of 'SuperLUStat_t'.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
* > 0: if info = i, U(i,i) is exactly zero. The factorization has
* been completed, but the factor U is exactly singular,
* and division by zero will occur if it is used to solve a
* system of equations.
*
*/
{
#ifdef _CRAY
_fcd ftcs = _cptofcd("N", strlen("N"));
_fcd ftcs1 = _cptofcd("L", strlen("L"));
_fcd ftcs2 = _cptofcd("N", strlen("N"));
_fcd ftcs3 = _cptofcd("U", strlen("U"));
#endif
doublecomplex zero = {0.0, 0.0};
doublecomplex alpha = {1.0, 0.0}, beta = {0.0, 0.0};
int_t *xsup;
int_t *lsub, *lsub1, *usub, *Usub_buf,
*Lsub_buf_2[2]; /* Need 2 buffers to implement Irecv. */
doublecomplex *lusup, *lusup1, *uval, *Uval_buf,
*Lval_buf_2[2]; /* Need 2 buffers to implement Irecv. */
int_t fnz, i, ib, ijb, ilst, it, iukp, jb, jj, klst, knsupc,
lb, lib, ldv, ljb, lptr, lptr0, lptrj, luptr, luptr0, luptrj,
nlb, nub, nsupc, rel, rukp;
int_t Pc, Pr;
int iam, kcol, krow, mycol, myrow, pi, pj;
int j, k, lk, nsupers;
int nsupr, nbrow, segsize;
int msgcnt[4]; /* Count the size of the message xfer'd in each buffer:
* 0 : transferred in Lsub_buf[]
* 1 : transferred in Lval_buf[]
* 2 : transferred in Usub_buf[]
* 3 : transferred in Uval_buf[]
*/
int_t msg0, msg2;
int_t **Ufstnz_br_ptr, **Lrowind_bc_ptr;
doublecomplex **Unzval_br_ptr, **Lnzval_bc_ptr;
int_t *index;
doublecomplex *nzval;
int_t *iuip, *ruip;/* Pointers to U index/nzval; size ceil(NSUPERS/Pr). */
doublecomplex *ucol;
int_t *indirect;
doublecomplex *tempv, *tempv2d;
int_t iinfo;
int_t *ToRecv, *ToSendD, **ToSendR;
Glu_persist_t *Glu_persist = LUstruct->Glu_persist;
LocalLU_t *Llu = LUstruct->Llu;
superlu_scope_t *scp;
double s_eps, thresh;
doublecomplex *tempU2d, *tempu;
int full, ldt, ldu, lead_zero, ncols;
MPI_Request recv_req[4], *send_req;
MPI_Status status;
#if ( DEBUGlevel>=1 )
int_t num_copy=0, num_update=0;
#endif
#if ( PRNTlevel==3 )
int_t zero_msg = 0, total_msg = 0;
#endif
#if ( PROFlevel>=1 )
double t1, t2;
float msg_vol = 0, msg_cnt = 0;
int_t iword = sizeof(int_t), zword = sizeof(doublecomplex);
#endif
/* Test the input parameters. */
*info = 0;
if ( m < 0 ) *info = -2;
else if ( n < 0 ) *info = -3;
if ( *info ) {
pxerbla("pzgstrf", grid, -*info);
return;
}
/* Quick return if possible. */
if ( m == 0 || n == 0 ) return;
/*
* Initialization.
*/
iam = grid->iam;
Pc = grid->npcol;
Pr = grid->nprow;
myrow = MYROW( iam, grid );
mycol = MYCOL( iam, grid );
nsupers = Glu_persist->supno[n-1] + 1;
xsup = Glu_persist->xsup;
s_eps = slamch_("Epsilon");
thresh = s_eps * anorm / 256.;
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Enter pzgstrf()");
#endif
stat->ops[FACT] = 0.0;
if ( Pr*Pc > 1) {
i = Llu->bufmax[0];
if ( !(Llu->Lsub_buf_2[0] = intMalloc_dist(2 * i)) )
ABORT("Malloc fails for Lsub_buf.");
Llu->Lsub_buf_2[1] = Llu->Lsub_buf_2[0] + i;
i = Llu->bufmax[1];
if ( !(Llu->Lval_buf_2[0] = doublecomplexMalloc_dist(2 * i)) )
ABORT("Malloc fails for Lval_buf[].");
Llu->Lval_buf_2[1] = Llu->Lval_buf_2[0] + i;
if ( Llu->bufmax[2] != 0 )
if ( !(Llu->Usub_buf = intMalloc_dist(Llu->bufmax[2])) )
ABORT("Malloc fails for Usub_buf[].");
if ( Llu->bufmax[3] != 0 )
if ( !(Llu->Uval_buf = doublecomplexMalloc_dist(Llu->bufmax[3])) )
ABORT("Malloc fails for Uval_buf[].");
if ( !(send_req =
(MPI_Request *) SUPERLU_MALLOC(2*Pc*sizeof(MPI_Request))))
ABORT("Malloc fails for send_req[].");
}
if ( !(Llu->ujrow = doublecomplexMalloc_dist(sp_ienv_dist(3))) )
ABORT("Malloc fails for ujrow[].");
#if ( PRNTlevel>=1 )
if ( !iam ) {
printf(".. thresh = s_eps %e * anorm %e / 256. = %e\n", s_eps, anorm, thresh);
printf(".. Buffer size: Lsub %d\tLval %d\tUsub %d\tUval %d\tLDA %d\n",
Llu->bufmax[0], Llu->bufmax[1],
Llu->bufmax[2], Llu->bufmax[3], Llu->bufmax[4]);
}
#endif
Lsub_buf_2[0] = Llu->Lsub_buf_2[0];
Lsub_buf_2[1] = Llu->Lsub_buf_2[1];
Lval_buf_2[0] = Llu->Lval_buf_2[0];
Lval_buf_2[1] = Llu->Lval_buf_2[1];
Usub_buf = Llu->Usub_buf;
Uval_buf = Llu->Uval_buf;
Lrowind_bc_ptr = Llu->Lrowind_bc_ptr;
Lnzval_bc_ptr = Llu->Lnzval_bc_ptr;
Ufstnz_br_ptr = Llu->Ufstnz_br_ptr;
Unzval_br_ptr = Llu->Unzval_br_ptr;
ToRecv = Llu->ToRecv;
ToSendD = Llu->ToSendD;
ToSendR = Llu->ToSendR;
ldt = sp_ienv_dist(3); /* Size of maximum supernode */
if ( !(tempv2d = doublecomplexCalloc_dist(2*ldt*ldt)) )
ABORT("Calloc fails for tempv2d[].");
tempU2d = tempv2d + ldt*ldt;
if ( !(indirect = intMalloc_dist(ldt)) )
ABORT("Malloc fails for indirect[].");
k = CEILING( nsupers, Pr ); /* Number of local block rows */
if ( !(iuip = intMalloc_dist(k)) )
ABORT("Malloc fails for iuip[].");
if ( !(ruip = intMalloc_dist(k)) )
ABORT("Malloc fails for ruip[].");
/* ---------------------------------------------------------------
Handle the first block column separately to start the pipeline.
--------------------------------------------------------------- */
if ( mycol == 0 ) {
pzgstrf2(options, 0, thresh, Glu_persist, grid, Llu, stat, info);
scp = &grid->rscp; /* The scope of process row. */
/* Process column *kcol* multicasts numeric values of L(:,k)
to process rows. */
lsub = Lrowind_bc_ptr[0];
lusup = Lnzval_bc_ptr[0];
if ( lsub ) {
msgcnt[0] = lsub[1] + BC_HEADER + lsub[0]*LB_DESCRIPTOR;
msgcnt[1] = lsub[1] * SuperSize( 0 );
} else {
msgcnt[0] = msgcnt[1] = 0;
}
for (pj = 0; pj < Pc; ++pj) {
if ( ToSendR[0][pj] != EMPTY ) {
#if ( PROFlevel>=1 )
TIC(t1);
#endif
MPI_Isend( lsub, msgcnt[0], mpi_int_t, pj, 0, scp->comm,
&send_req[pj] );
MPI_Isend( lusup, msgcnt[1], SuperLU_MPI_DOUBLE_COMPLEX,
pj, 1, scp->comm, &send_req[pj+Pc] );
#if ( DEBUGlevel>=2 )
printf("(%d) Send L(:,%4d): lsub %4d, lusup %4d to Pc %2d\n",
iam, 0, msgcnt[0], msgcnt[1], pj);
#endif
#if ( PROFlevel>=1 )
TOC(t2, t1);
stat->utime[COMM] += t2;
msg_cnt += 2;
msg_vol += msgcnt[0]*iword + msgcnt[1]*zword;
#endif
}
} /* for pj ... */
} else { /* Post immediate receives. */
if ( ToRecv[0] >= 1 ) { /* Recv block column L(:,0). */
scp = &grid->rscp; /* The scope of process row. */
MPI_Irecv( Lsub_buf_2[0], Llu->bufmax[0], mpi_int_t, 0,
0, scp->comm, &recv_req[0] );
MPI_Irecv( Lval_buf_2[0], Llu->bufmax[1],
SuperLU_MPI_DOUBLE_COMPLEX, 0,
1, scp->comm, &recv_req[1] );
#if ( DEBUGlevel>=2 )
printf("(%d) Post Irecv L(:,%4d)\n", iam, 0);
#endif
}
} /* if mycol == 0 */
/* ------------------------------------------
MAIN LOOP: Loop through all block columns.
------------------------------------------ */
for (k = 0; k < nsupers; ++k) {
knsupc = SuperSize( k );
krow = PROW( k, grid );
kcol = PCOL( k, grid );
if ( mycol == kcol ) {
lk = LBj( k, grid ); /* Local block number. */
for (pj = 0; pj < Pc; ++pj) {
/* Wait for Isend to complete before using lsub/lusup. */
if ( ToSendR[lk][pj] != EMPTY ) {
MPI_Wait( &send_req[pj], &status );
MPI_Wait( &send_req[pj+Pc], &status );
}
}
lsub = Lrowind_bc_ptr[lk];
lusup = Lnzval_bc_ptr[lk];
} else {
if ( ToRecv[k] >= 1 ) { /* Recv block column L(:,k). */
scp = &grid->rscp; /* The scope of process row. */
#if ( PROFlevel>=1 )
TIC(t1);
#endif
/*probe_recv(iam, kcol, (4*k)%NTAGS, mpi_int_t, scp->comm,
Llu->bufmax[0]);*/
/*MPI_Recv( Lsub_buf, Llu->bufmax[0], mpi_int_t, kcol,
(4*k)%NTAGS, scp->comm, &status );*/
MPI_Wait( &recv_req[0], &status );
MPI_Get_count( &status, mpi_int_t, &msgcnt[0] );
/*probe_recv(iam, kcol, (4*k+1)%NTAGS, MPI_DOUBLE, scp->comm,
Llu->bufmax[1]);*/
/*MPI_Recv( Lval_buf, Llu->bufmax[1], SuperLU_MPI_DOUBLE_COMPLEX,
kcol, (4*k+1)%NTAGS, scp->comm, &status );*/
MPI_Wait( &recv_req[1], &status );
MPI_Get_count(&status, SuperLU_MPI_DOUBLE_COMPLEX, &msgcnt[1]);
#if ( PROFlevel>=1 )
TOC(t2, t1);
stat->utime[COMM] += t2;
#endif
#if ( DEBUGlevel>=2 )
printf("(%d) Recv L(:,%4d): lsub %4d, lusup %4d from Pc %2d\n",
iam, k, msgcnt[0], msgcnt[1], kcol);
#endif
lsub = Lsub_buf_2[k%2];
lusup = Lval_buf_2[k%2];
#if ( PRNTlevel==3 )
++total_msg;
if ( !msgcnt[0] ) ++zero_msg;
#endif
} else msgcnt[0] = 0;
} /* if mycol = Pc(k) */
scp = &grid->cscp; /* The scope of process column. */
if ( myrow == krow ) {
/* Parallel triangular solve across process row *krow* --
U(k,j) = L(k,k) \ A(k,j). */
#ifdef _CRAY
pzgstrs2(n, k, Glu_persist, grid, Llu, stat, ftcs1, ftcs2, ftcs3);
#else
pzgstrs2(n, k, Glu_persist, grid, Llu, stat);
#endif
/* Multicasts U(k,:) to process columns. */
lk = LBi( k, grid );
usub = Ufstnz_br_ptr[lk];
uval = Unzval_br_ptr[lk];
if ( usub ) {
msgcnt[2] = usub[2];
msgcnt[3] = usub[1];
} else {
msgcnt[2] = msgcnt[3] = 0;
}
if ( ToSendD[lk] == YES ) {
for (pi = 0; pi < Pr; ++pi)
if ( pi != myrow ) {
#if ( PROFlevel>=1 )
TIC(t1);
#endif
MPI_Send( usub, msgcnt[2], mpi_int_t, pi,
(4*k+2)%NTAGS, scp->comm);
MPI_Send( uval, msgcnt[3], SuperLU_MPI_DOUBLE_COMPLEX,
pi, (4*k+3)%NTAGS, scp->comm);
#if ( PROFlevel>=1 )
TOC(t2, t1);
stat->utime[COMM] += t2;
msg_cnt += 2;
msg_vol += msgcnt[2]*iword + msgcnt[3]*zword;
#endif
#if ( DEBUGlevel>=2 )
printf("(%d) Send U(%4d,:) to Pr %2d\n", iam, k, pi);
#endif
} /* if pi ... */
} /* if ToSendD ... */
} else { /* myrow != krow */
if ( ToRecv[k] == 2 ) { /* Recv block row U(k,:). */
#if ( PROFlevel>=1 )
TIC(t1);
#endif
/*probe_recv(iam, krow, (4*k+2)%NTAGS, mpi_int_t, scp->comm,
Llu->bufmax[2]);*/
MPI_Recv( Usub_buf, Llu->bufmax[2], mpi_int_t, krow,
(4*k+2)%NTAGS, scp->comm, &status );
MPI_Get_count( &status, mpi_int_t, &msgcnt[2] );
/*probe_recv(iam, krow, (4*k+3)%NTAGS,
SuperLU_MPI_DOUBLE_COMPLEX, scp->comm,
Llu->bufmax[3]);*/
MPI_Recv( Uval_buf, Llu->bufmax[3], SuperLU_MPI_DOUBLE_COMPLEX,
krow, (4*k+3)%NTAGS, scp->comm, &status );
MPI_Get_count(&status, SuperLU_MPI_DOUBLE_COMPLEX, &msgcnt[3]);
#if ( PROFlevel>=1 )
TOC(t2, t1);
stat->utime[COMM] += t2;
#endif
usub = Usub_buf;
uval = Uval_buf;
#if ( DEBUGlevel>=2 )
printf("(%d) Recv U(%4d,:) from Pr %2d\n", iam, k, krow);
#endif
#if ( PRNTlevel==3 )
++total_msg;
if ( !msgcnt[2] ) ++zero_msg;
#endif
} else msgcnt[2] = 0;
} /* if myrow == Pr(k) */
/*
* Parallel rank-k update; pair up blocks L(i,k) and U(k,j).
* for (j = k+1; k < N; ++k) {
* for (i = k+1; i < N; ++i)
* if ( myrow == PROW( i, grid ) && mycol == PCOL( j, grid )
* && L(i,k) != 0 && U(k,j) != 0 )
* A(i,j) = A(i,j) - L(i,k) * U(k,j);
*/
msg0 = msgcnt[0];
msg2 = msgcnt[2];
if ( msg0 && msg2 ) { /* L(:,k) and U(k,:) are not empty. */
nsupr = lsub[1]; /* LDA of lusup. */
if ( myrow == krow ) { /* Skip diagonal block L(k,k). */
lptr0 = BC_HEADER + LB_DESCRIPTOR + lsub[BC_HEADER+1];
luptr0 = knsupc;
nlb = lsub[0] - 1;
} else {
lptr0 = BC_HEADER;
luptr0 = 0;
nlb = lsub[0];
}
lptr = lptr0;
for (lb = 0; lb < nlb; ++lb) { /* Initialize block row pointers. */
ib = lsub[lptr];
lib = LBi( ib, grid );
iuip[lib] = BR_HEADER;
ruip[lib] = 0;
lptr += LB_DESCRIPTOR + lsub[lptr+1];
}
nub = usub[0]; /* Number of blocks in the block row U(k,:) */
iukp = BR_HEADER; /* Skip header; Pointer to index[] of U(k,:) */
rukp = 0; /* Pointer to nzval[] of U(k,:) */
klst = FstBlockC( k+1 );
/*
* Update the first block column A(:,k+1).
*/
jb = usub[iukp]; /* Global block number of block U(k,j). */
if ( jb == k+1 ) { /* First update (k+1)-th block. */
--nub;
lptr = lptr0;
luptr = luptr0;
ljb = LBj( jb, grid ); /* Local block number of U(k,j). */
nsupc = SuperSize( jb );
iukp += UB_DESCRIPTOR; /* Start fstnz of block U(k,j). */
/* Prepare to call DGEMM. */
jj = iukp;
while ( usub[jj] == klst ) ++jj;
ldu = klst - usub[jj++];
ncols = 1;
full = 1;
for (; jj < iukp+nsupc; ++jj) {
segsize = klst - usub[jj];
if ( segsize ) {
++ncols;
if ( segsize != ldu ) full = 0;
if ( segsize > ldu ) ldu = segsize;
}
}
#if ( DEBUGlevel>=1 )
++num_update;
#endif
if ( full ) {
tempu = &uval[rukp];
} else { /* Copy block U(k,j) into tempU2d. */
#if ( DEBUGlevel>=1 )
printf("(%d) full=%d,k=%d,jb=%d,ldu=%d,ncols=%d,nsupc=%d\n",
iam, full, k, jb, ldu, ncols, nsupc);
++num_copy;
#endif
tempu = tempU2d;
for (jj = iukp; jj < iukp+nsupc; ++jj) {
segsize = klst - usub[jj];
if ( segsize ) {
lead_zero = ldu - segsize;
for (i = 0; i < lead_zero; ++i) tempu[i] = zero;
tempu += lead_zero;
for (i = 0; i < segsize; ++i)
tempu[i] = uval[rukp+i];
rukp += segsize;
tempu += segsize;
}
}
tempu = tempU2d;
rukp -= usub[iukp - 1]; /* Return to start of U(k,j). */
} /* if full ... */
for (lb = 0; lb < nlb; ++lb) {
ib = lsub[lptr]; /* Row block L(i,k). */
nbrow = lsub[lptr+1]; /* Number of full rows. */
lptr += LB_DESCRIPTOR; /* Skip descriptor. */
tempv = tempv2d;
#ifdef _CRAY
CGEMM(ftcs, ftcs, &nbrow, &ncols, &ldu, &alpha,
&lusup[luptr+(knsupc-ldu)*nsupr], &nsupr,
tempu, &ldu, &beta, tempv, &ldt);
#else
zgemm_("N", "N", &nbrow, &ncols, &ldu, &alpha,
&lusup[luptr+(knsupc-ldu)*nsupr], &nsupr,
tempu, &ldu, &beta, tempv, &ldt);
#endif
stat->ops[FACT] += 8 * nbrow * ldu * ncols;
/* Now gather the result into the destination block. */
if ( ib < jb ) { /* A(i,j) is in U. */
ilst = FstBlockC( ib+1 );
lib = LBi( ib, grid );
index = Ufstnz_br_ptr[lib];
ijb = index[iuip[lib]];
while ( ijb < jb ) { /* Search for dest block. */
ruip[lib] += index[iuip[lib]+1];
iuip[lib] += UB_DESCRIPTOR + SuperSize( ijb );
ijb = index[iuip[lib]];
}
iuip[lib] += UB_DESCRIPTOR; /* Skip descriptor. */
tempv = tempv2d;
for (jj = 0; jj < nsupc; ++jj) {
segsize = klst - usub[iukp + jj];
fnz = index[iuip[lib]++];
if ( segsize ) { /* Nonzero segment in U(k.j). */
ucol = &Unzval_br_ptr[lib][ruip[lib]];
for (i = 0, it = 0; i < nbrow; ++i) {
rel = lsub[lptr + i] - fnz;
z_sub(&ucol[rel], &ucol[rel], &tempv[it]);
++it;
}
tempv += ldt;
}
ruip[lib] += ilst - fnz;
}
} else { /* A(i,j) is in L. */
index = Lrowind_bc_ptr[ljb];
ldv = index[1]; /* LDA of the dest lusup. */
lptrj = BC_HEADER;
luptrj = 0;
ijb = index[lptrj];
while ( ijb != ib ) { /* Search for dest block --
blocks are not ordered! */
luptrj += index[lptrj+1];
lptrj += LB_DESCRIPTOR + index[lptrj+1];
ijb = index[lptrj];
}
/*
* Build indirect table. This is needed because the
* indices are not sorted.
*/
fnz = FstBlockC( ib );
lptrj += LB_DESCRIPTOR;
for (i = 0; i < index[lptrj-1]; ++i) {
rel = index[lptrj + i] - fnz;
indirect[rel] = i;
}
nzval = Lnzval_bc_ptr[ljb] + luptrj;
tempv = tempv2d;
for (jj = 0; jj < nsupc; ++jj) {
segsize = klst - usub[iukp + jj];
if ( segsize ) {
/*#pragma _CRI cache_bypass nzval,tempv*/
for (it = 0, i = 0; i < nbrow; ++i) {
rel = lsub[lptr + i] - fnz;
z_sub(&nzval[indirect[rel]],
&nzval[indirect[rel]],
&tempv[it]);
++it;
}
tempv += ldt;
}
nzval += ldv;
}
} /* if ib < jb ... */
lptr += nbrow;
luptr += nbrow;
} /* for lb ... */
rukp += usub[iukp - 1]; /* Move to block U(k,j+1) */
iukp += nsupc;
} /* if jb == k+1 */
} /* if L(:,k) and U(k,:) not empty */
if ( k+1 < nsupers ) {
kcol = PCOL( k+1, grid );
if ( mycol == kcol ) {
/* Factor diagonal and subdiagonal blocks and test for exact
singularity. */
pzgstrf2(options, k+1, thresh, Glu_persist, grid, Llu, stat, info);
/* Process column *kcol+1* multicasts numeric values of L(:,k+1)
to process rows. */
lk = LBj( k+1, grid ); /* Local block number. */
lsub1 = Lrowind_bc_ptr[lk];
if ( lsub1 ) {
msgcnt[0] = lsub1[1] + BC_HEADER + lsub1[0]*LB_DESCRIPTOR;
msgcnt[1] = lsub1[1] * SuperSize( k+1 );
} else {
msgcnt[0] = 0;
msgcnt[1] = 0;
}
scp = &grid->rscp; /* The scope of process row. */
for (pj = 0; pj < Pc; ++pj) {
if ( ToSendR[lk][pj] != EMPTY ) {
lusup1 = Lnzval_bc_ptr[lk];
#if ( PROFlevel>=1 )
TIC(t1);
#endif
MPI_Isend( lsub1, msgcnt[0], mpi_int_t, pj,
(4*(k+1))%NTAGS, scp->comm, &send_req[pj] );
MPI_Isend( lusup1, msgcnt[1], SuperLU_MPI_DOUBLE_COMPLEX,
pj, (4*(k+1)+1)%NTAGS, scp->comm,
&send_req[pj+Pc] );
#if ( PROFlevel>=1 )
TOC(t2, t1);
stat->utime[COMM] += t2;
msg_cnt += 2;
msg_vol += msgcnt[0]*iword + msgcnt[1]*zword;
#endif
#if ( DEBUGlevel>=2 )
printf("(%d) Send L(:,%4d): lsub %4d, lusup %4d to Pc %2d\n",
iam, k+1, msgcnt[0], msgcnt[1], pj);
#endif
}
} /* for pj ... */
} else { /* Post Recv of block column L(:,k+1). */
if ( ToRecv[k+1] >= 1 ) {
scp = &grid->rscp; /* The scope of process row. */
MPI_Irecv(Lsub_buf_2[(k+1)%2], Llu->bufmax[0], mpi_int_t, kcol,
(4*(k+1))%NTAGS, scp->comm, &recv_req[0]);
MPI_Irecv(Lval_buf_2[(k+1)%2], Llu->bufmax[1],
SuperLU_MPI_DOUBLE_COMPLEX, kcol,
(4*(k+1)+1)%NTAGS, scp->comm, &recv_req[1]);
}
} /* if mycol == Pc(k+1) */
} /* if k+1 < nsupers */
if ( msg0 && msg2 ) { /* L(:,k) and U(k,:) are not empty. */
/*
* Update all other blocks using block row U(k,:)
*/
for (j = 0; j < nub; ++j) {
lptr = lptr0;
luptr = luptr0;
jb = usub[iukp]; /* Global block number of block U(k,j). */
ljb = LBj( jb, grid ); /* Local block number of U(k,j). */
nsupc = SuperSize( jb );
iukp += UB_DESCRIPTOR; /* Start fstnz of block U(k,j). */
/* Prepare to call DGEMM. */
jj = iukp;
while ( usub[jj] == klst ) ++jj;
ldu = klst - usub[jj++];
ncols = 1;
full = 1;
for (; jj < iukp+nsupc; ++jj) {
segsize = klst - usub[jj];
if ( segsize ) {
++ncols;
if ( segsize != ldu ) full = 0;
if ( segsize > ldu ) ldu = segsize;
}
}
#if ( DEBUGlevel>=2 )
printf("(%d) full=%d,k=%d,jb=%d,ldu=%d,ncols=%d,nsupc=%d\n",
iam, full, k, jb, ldu, ncols, nsupc);
++num_update;
#endif
if ( full ) {
tempu = &uval[rukp];
} else { /* Copy block U(k,j) into tempU2d. */
#if ( DEBUGlevel>=1 )
++num_copy;
#endif
tempu = tempU2d;
for (jj = iukp; jj < iukp+nsupc; ++jj) {
segsize = klst - usub[jj];
if ( segsize ) {
lead_zero = ldu - segsize;
for (i = 0; i < lead_zero; ++i) tempu[i] = zero;
tempu += lead_zero;
for (i = 0; i < segsize; ++i)
tempu[i] = uval[rukp+i];
rukp += segsize;
tempu += segsize;
}
}
tempu = tempU2d;
rukp -= usub[iukp - 1]; /* Return to start of U(k,j). */
} /* if full ... */
for (lb = 0; lb < nlb; ++lb) {
ib = lsub[lptr]; /* Row block L(i,k). */
nbrow = lsub[lptr+1]; /* Number of full rows. */
lptr += LB_DESCRIPTOR; /* Skip descriptor. */
tempv = tempv2d;
#ifdef _CRAY
CGEMM(ftcs, ftcs, &nbrow, &ncols, &ldu, &alpha,
&lusup[luptr+(knsupc-ldu)*nsupr], &nsupr,
tempu, &ldu, &beta, tempv, &ldt);
#else
zgemm_("N", "N", &nbrow, &ncols, &ldu, &alpha,
&lusup[luptr+(knsupc-ldu)*nsupr], &nsupr,
tempu, &ldu, &beta, tempv, &ldt);
#endif
stat->ops[FACT] += 8 * nbrow * ldu * ncols;
/* Now gather the result into the destination block. */
if ( ib < jb ) { /* A(i,j) is in U. */
ilst = FstBlockC( ib+1 );
lib = LBi( ib, grid );
index = Ufstnz_br_ptr[lib];
ijb = index[iuip[lib]];
while ( ijb < jb ) { /* Search for dest block. */
ruip[lib] += index[iuip[lib]+1];
iuip[lib] += UB_DESCRIPTOR + SuperSize( ijb );
ijb = index[iuip[lib]];
}
iuip[lib] += UB_DESCRIPTOR; /* Skip descriptor. */
tempv = tempv2d;
for (jj = 0; jj < nsupc; ++jj) {
segsize = klst - usub[iukp + jj];
fnz = index[iuip[lib]++];
if ( segsize ) { /* Nonzero segment in U(k.j). */
ucol = &Unzval_br_ptr[lib][ruip[lib]];
for (i = 0, it = 0; i < nbrow; ++i) {
rel = lsub[lptr + i] - fnz;
z_sub(&ucol[rel], &ucol[rel], &tempv[it]);
++it;
}
tempv += ldt;
}
ruip[lib] += ilst - fnz;
}
} else { /* A(i,j) is in L. */
index = Lrowind_bc_ptr[ljb];
ldv = index[1]; /* LDA of the dest lusup. */
lptrj = BC_HEADER;
luptrj = 0;
ijb = index[lptrj];
while ( ijb != ib ) { /* Search for dest block --
blocks are not ordered! */
luptrj += index[lptrj+1];
lptrj += LB_DESCRIPTOR + index[lptrj+1];
ijb = index[lptrj];
}
/*
* Build indirect table. This is needed because the
* indices are not sorted.
*/
fnz = FstBlockC( ib );
lptrj += LB_DESCRIPTOR;
for (i = 0; i < index[lptrj-1]; ++i) {
rel = index[lptrj + i] - fnz;
indirect[rel] = i;
}
nzval = Lnzval_bc_ptr[ljb] + luptrj;
tempv = tempv2d;
for (jj = 0; jj < nsupc; ++jj) {
segsize = klst - usub[iukp + jj];
if ( segsize ) {
/*#pragma _CRI cache_bypass nzval,tempv*/
for (it = 0, i = 0; i < nbrow; ++i) {
rel = lsub[lptr + i] - fnz;
z_sub(&nzval[indirect[rel]],
&nzval[indirect[rel]],
&tempv[it]);
++it;
}
tempv += ldt;
}
nzval += ldv;
}
} /* if ib < jb ... */
lptr += nbrow;
luptr += nbrow;
} /* for lb ... */
rukp += usub[iukp - 1]; /* Move to block U(k,j+1) */
iukp += nsupc;
} /* for j ... */
} /* if k L(:,k) and U(k,:) are not empty */
}
/* ------------------------------------------
END MAIN LOOP: for k = ...
------------------------------------------ */
if ( Pr*Pc > 1 ) {
SUPERLU_FREE(Lsub_buf_2[0]); /* also free Lsub_buf_2[1] */
SUPERLU_FREE(Lval_buf_2[0]); /* also free Lval_buf_2[1] */
if ( Llu->bufmax[2] != 0 ) SUPERLU_FREE(Usub_buf);
if ( Llu->bufmax[3] != 0 ) SUPERLU_FREE(Uval_buf);
SUPERLU_FREE(send_req);
}
SUPERLU_FREE(Llu->ujrow);
SUPERLU_FREE(tempv2d);
SUPERLU_FREE(indirect);
SUPERLU_FREE(iuip);
SUPERLU_FREE(ruip);
/* Prepare error message. */
if ( *info == 0 ) *info = n + 1;
#if ( PROFlevel>=1 )
TIC(t1);
#endif
MPI_Allreduce( info, &iinfo, 1, mpi_int_t, MPI_MIN, grid->comm );
#if ( PROFlevel>=1 )
TOC(t2, t1);
stat->utime[COMM] += t2;
{
float msg_vol_max, msg_vol_sum, msg_cnt_max, msg_cnt_sum;
MPI_Reduce( &msg_cnt, &msg_cnt_sum,
1, MPI_FLOAT, MPI_SUM, 0, grid->comm );
MPI_Reduce( &msg_cnt, &msg_cnt_max,
1, MPI_FLOAT, MPI_MAX, 0, grid->comm );
MPI_Reduce( &msg_vol, &msg_vol_sum,
1, MPI_FLOAT, MPI_SUM, 0, grid->comm );
MPI_Reduce( &msg_vol, &msg_vol_max,
1, MPI_FLOAT, MPI_MAX, 0, grid->comm );
if ( !iam ) {
printf("\tPZGSTRF comm stat:"
"\tAvg\tMax\t\tAvg\tMax\n"
"\t\t\tCount:\t%.0f\t%.0f\tVol(MB)\t%.2f\t%.2f\n",
msg_cnt_sum/Pr/Pc, msg_cnt_max,
msg_vol_sum/Pr/Pc*1e-6, msg_vol_max*1e-6);
}
}
#endif
if ( iinfo == n + 1 ) *info = 0;
else *info = iinfo;
#if ( PRNTlevel==3 )
MPI_Allreduce( &zero_msg, &iinfo, 1, mpi_int_t, MPI_SUM, grid->comm );
if ( !iam ) printf(".. # msg of zero size\t%d\n", iinfo);
MPI_Allreduce( &total_msg, &iinfo, 1, mpi_int_t, MPI_SUM, grid->comm );
if ( !iam ) printf(".. # total msg\t%d\n", iinfo);
#endif
#if ( PRNTlevel==2 )
for (i = 0; i < Pr * Pc; ++i) {
if ( iam == i ) {
PrintLblocks(iam, nsupers, grid, Glu_persist, Llu);
PrintUblocks(iam, nsupers, grid, Glu_persist, Llu);
printf("(%d)\n", iam);
PrintInt10("Recv", nsupers, Llu->ToRecv);
}
MPI_Barrier( grid->comm );
}
#endif
#if ( DEBUGlevel>=1 )
printf("(%d) num_copy=%d, num_update=%d\n", iam, num_copy, num_update);
CHECK_MALLOC(iam, "Exit pzgstrf()");
#endif
} /* PZGSTRF_AGLOBAL */
int
sp_ztrsv_dist(char *uplo, char *trans, char *diag, SuperMatrix *L,
SuperMatrix *U, doublecomplex *x, int *info)
{
/*
* Purpose
* =======
*
* sp_ztrsv() solves one of the systems of equations
* A*x = b, or A'*x = b,
* where b and x are n element vectors and A is a sparse unit , or
* non-unit, upper or lower triangular matrix.
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* uplo - (input) char*
* On entry, uplo specifies whether the matrix is an upper or
* lower triangular matrix as follows:
* uplo = 'U' or 'u' A is an upper triangular matrix.
* uplo = 'L' or 'l' A is a lower triangular matrix.
*
* trans - (input) char*
* On entry, trans specifies the equations to be solved as
* follows:
* trans = 'N' or 'n' A*x = b.
* trans = 'T' or 't' A'*x = b.
* trans = 'C' or 'c' A'*x = b.
*
* diag - (input) char*
* On entry, diag specifies whether or not A is unit
* triangular as follows:
* diag = 'U' or 'u' A is assumed to be unit triangular.
* diag = 'N' or 'n' A is not assumed to be unit
* triangular.
*
* L - (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U. Use
* compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SC, Dtype = Z, Mtype = TRLU.
*
* U - (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U.
* U has types: Stype = NC, Dtype = Z, Mtype = TRU.
*
* x - (input/output) doublecomplex*
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* info - (output) int*
* If *info = -i, the i-th argument had an illegal value.
*
*/
#ifdef _CRAY
_fcd ftcs1 = _cptofcd("L", strlen("L")),
ftcs2 = _cptofcd("N", strlen("N")),
ftcs3 = _cptofcd("U", strlen("U"));
#endif
SCformat *Lstore;
NCformat *Ustore;
doublecomplex *Lval, *Uval;
int incx = 1, incy = 1;
doublecomplex alpha = {1.0, 0.0}, beta = {1.0, 0.0};
doublecomplex comp_zero = {0.0, 0.0};
int nrow;
int fsupc, nsupr, nsupc, luptr, istart, irow;
int i, k, iptr, jcol;
doublecomplex *work;
flops_t solve_ops;
/*extern SuperLUStat_t SuperLUStat;*/
/* Test the input parameters */
*info = 0;
if ( !lsame_(uplo,"L") && !lsame_(uplo, "U") ) *info = -1;
else if ( !lsame_(trans, "N") && !lsame_(trans, "T") ) *info = -2;
else if ( !lsame_(diag, "U") && !lsame_(diag, "N") ) *info = -3;
else if ( L->nrow != L->ncol || L->nrow < 0 ) *info = -4;
else if ( U->nrow != U->ncol || U->nrow < 0 ) *info = -5;
if ( *info ) {
i = -(*info);
xerbla_("sp_ztrsv", &i);
return 0;
}
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
solve_ops = 0;
if ( !(work = doublecomplexCalloc_dist(L->nrow)) )
ABORT("Malloc fails for work in sp_ztrsv().");
if ( lsame_(trans, "N") ) { /* Form x := inv(A)*x. */
if ( lsame_(uplo, "L") ) {
/* Form x := inv(L)*x */
if ( L->nrow == 0 ) return 0; /* Quick return */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
nrow = nsupr - nsupc;
solve_ops += 4 * nsupc * (nsupc - 1);
solve_ops += 8 * nrow * nsupc;
if ( nsupc == 1 ) {
for (iptr=istart+1; iptr < L_SUB_START(fsupc+1); ++iptr) {
irow = L_SUB(iptr);
++luptr;
zz_mult(&comp_zero, &x[fsupc], &Lval[luptr]);
z_sub(&x[irow], &x[irow], &comp_zero);
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
CGEMV(ftcs2, &nrow, &nsupc, &alpha, &Lval[luptr+nsupc],
&nsupr, &x[fsupc], &incx, &beta, &work[0], &incy);
#else
ztrsv_("L", "N", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx, 1, 1, 1);
zgemv_("N", &nrow, &nsupc, &alpha, &Lval[luptr+nsupc],
&nsupr, &x[fsupc], &incx, &beta, &work[0], &incy, 1);
#endif
#else
zlsolve ( nsupr, nsupc, &Lval[luptr], &x[fsupc]);
zmatvec ( nsupr, nsupr-nsupc, nsupc, &Lval[luptr+nsupc],
&x[fsupc], &work[0] );
#endif
iptr = istart + nsupc;
for (i = 0; i < nrow; ++i, ++iptr) {
irow = L_SUB(iptr);
z_sub(&x[irow], &x[irow], &work[i]); /* Scatter */
work[i] = comp_zero;
}
}
} /* for k ... */
} else {
/* Form x := inv(U)*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = Lstore->nsuper; k >= 0; k--) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 4 * nsupc * (nsupc + 1);
if ( nsupc == 1 ) {
z_div(&x[fsupc], &x[fsupc], &Lval[luptr]);
for (i = U_NZ_START(fsupc); i < U_NZ_START(fsupc+1); ++i) {
irow = U_SUB(i);
zz_mult(&comp_zero, &x[fsupc], &Uval[i]);
z_sub(&x[irow], &x[irow], &comp_zero);
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV(ftcs3, ftcs2, ftcs2, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ztrsv_("U", "N", "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx, 1, 1, 1);
#endif
#else
zusolve ( nsupr, nsupc, &Lval[luptr], &x[fsupc] );
#endif
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1);
i++) {
irow = U_SUB(i);
zz_mult(&comp_zero, &x[jcol], &Uval[i]);
z_sub(&x[irow], &x[irow], &comp_zero);
}
}
}
} /* for k ... */
}
} else { /* Form x := inv(A')*x */
if ( lsame_(uplo, "L") ) {
/* Form x := inv(L')*x */
if ( L->nrow == 0 ) return 0; /* Quick return */
for (k = Lstore->nsuper; k >= 0; --k) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 8 * (nsupr - nsupc) * nsupc;
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
iptr = istart + nsupc;
for (i = L_NZ_START(jcol) + nsupc;
i < L_NZ_START(jcol+1); i++) {
irow = L_SUB(iptr);
zz_mult(&comp_zero, &x[irow], &Lval[i]);
z_sub(&x[jcol], &x[jcol], &comp_zero);
iptr++;
}
}
if ( nsupc > 1 ) {
solve_ops += 4 * nsupc * (nsupc - 1);
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("T", strlen("T"));
ftcs3 = _cptofcd("U", strlen("U"));
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ztrsv_("L", "T", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx, 1, 1, 1);
#endif
#else
ztrsv_("L", "T", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
}
} else {
/* Form x := inv(U')*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++) {
irow = U_SUB(i);
zz_mult(&comp_zero, &x[irow], &Uval[i]);
z_sub(&x[jcol], &x[jcol], &comp_zero);
}
}
solve_ops += 4 * nsupc * (nsupc + 1);
if ( nsupc == 1 ) {
z_div(&x[fsupc], &x[fsupc], &Lval[luptr]);
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("U", strlen("U"));
ftcs2 = _cptofcd("T", strlen("T"));
ftcs3 = _cptofcd("N", strlen("N"));
CTRSV( ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ztrsv_("U", "T", "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx, 1, 1, 1);
#endif
#else
ztrsv_("U", "T", "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
} /* for k ... */
}
}
/*SuperLUStat.ops[SOLVE] += solve_ops;*/
SUPERLU_FREE(work);
return 0;
}
