void zmat_plus_eq(Zmatrix *thism, Zmatrix *addm) {
int i, j;
if (!(thism->nrows == addm->nrows && thism->ncols == addm->ncols))
die("ERROR zmat_plus_eq: bad dimensions\n");
for (i = 0; i < thism->nrows; i++)
for (j = 0; j < thism->ncols; j++)
thism->data[i][j] = z_add(thism->data[i][j], addm->data[i][j]);
}
void zmat_mult(Zmatrix *prod, Zmatrix *m1, Zmatrix *m2) {
int i, j, k;
if (!(m1->ncols == m2->nrows && m1->nrows == m2->ncols &&
prod->nrows == m1->nrows && prod->ncols == m2->ncols))
die("ERROR zmat_mult: bad dimensions\n");
zmat_zero(prod);
for (i = 0; i < prod->nrows; i++)
for (j = 0; j < prod->ncols; j++)
for (k = 0; k < m1->ncols; k++)
prod->data[i][j] = z_add(prod->data[i][j],
z_mul(m1->data[i][k], m2->data[k][j]));
}
void zmat_vec_mult(Zvector *prod, Zmatrix *m, Zvector *v) {
int i, j;
if (!(m->nrows == prod->size && v->size == m->ncols))
die("ERROR zmat_vec_mult: bad dimensions\n");
for (i = 0; i < m->nrows; i++) {
prod->data[i] = z_set(0, 0);
for (j = 0; j < m->ncols; j++) {
prod->data[i] = z_add(prod->data[i],
z_mul(m->data[i][j], v->data[j]));
}
}
}
/*
* Performs sparse matrix-vector multiplication.
* - val/bindx stores the distributed MSR matrix A
* - X is global
* - ax product is distributed the same way as A
*/
int
pzgsmv_AXglobal(int_t m, int_t update[], doublecomplex val[], int_t bindx[],
doublecomplex X[], doublecomplex ax[])
{
int_t i, j, k;
doublecomplex zero = {0.0, 0.0};
doublecomplex temp;
if ( m <= 0 ) return; /* number of rows (local) */
for (i = 0; i < m; ++i) {
ax[i] = zero;
for (k = bindx[i]; k < bindx[i+1]; ++k) {
j = bindx[k]; /* column index */
zz_mult(&temp, &val[k], &X[j]);
z_add(&ax[i], &ax[i], &temp);
}
zz_mult(&temp, &val[i], &X[update[i]]); /* diagonal */
z_add(&ax[i], &ax[i], &temp);
}
} /* PZGSMV_AXglobal */
/* multiply two complex matrices whose product is expected to be real */
void zmat_mult_real(Matrix *prod, Zmatrix *m1, Zmatrix *m2) {
int i, j, k;
if (!(m1->ncols == m2->nrows && m1->nrows == m2->ncols &&
prod->nrows == m1->nrows && prod->ncols == m2->ncols))
die("ERROR zmat_mult_real: bad dimensions\n");
mat_zero(prod);
for (i = 0; i < prod->nrows; i++) {
for (j = 0; j < prod->ncols; j++) {
Complex z = z_set(0, 0);
for (k = 0; k < m1->ncols; k++)
z = z_add(z, z_mul(m1->data[i][k], m2->data[k][j]));
if (z.y > 1e-6)
die("ERROR in zmat_mult_real: product of complex matrices not real.\n");
mat_set(prod, i, j, z.x);
}
}
}
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;
}
}
}
int
pzgstrf_column_bmod(
const int pnum, /* process number */
const int jcol, /* current column in the panel */
const int fpanelc,/* first column in the panel */
const int nseg, /* number of s-nodes to update jcol */
int *segrep,/* in */
int *repfnz,/* in */
doublecomplex *dense, /* modified */
doublecomplex *tempv, /* working array */
pxgstrf_shared_t *pxgstrf_shared, /* modified */
Gstat_t *Gstat /* modified */
)
{
/*
* -- SuperLU MT routine (version 2.0) --
* Lawrence Berkeley National Lab, Univ. of California Berkeley,
* and Xerox Palo Alto Research Center.
* September 10, 2007
*
* Purpose:
* ========
* Performs numeric block updates (sup-col) in topological order.
* It features: col-col, 2cols-col, 3cols-col, and sup-col updates.
* Special processing on the supernodal portion of L\U[*,j].
*
* Return value:
* =============
* 0 - successful return
* > 0 - number of bytes allocated when run out of space
*
*/
#if ( MACH==CRAY_PVP )
_fcd ftcs1 = _cptofcd("L", strlen("L")),
ftcs2 = _cptofcd("N", strlen("N")),
ftcs3 = _cptofcd("U", strlen("U"));
#endif
#ifdef USE_VENDOR_BLAS
int incx = 1, incy = 1;
doublecomplex alpha, beta;
#endif
GlobalLU_t *Glu = pxgstrf_shared->Glu; /* modified */
/* krep = representative of current k-th supernode
* fsupc = first supernodal column
* nsupc = no of columns in supernode
* nsupr = no of rows in supernode (used as leading dimension)
* luptr = location of supernodal LU-block in storage
* kfnz = first nonz in the k-th supernodal segment
* no_zeros = no of leading zeros in a supernodal U-segment
*/
doublecomplex ukj, ukj1, ukj2;
register int lptr, kfnz, isub, irow, i, no_zeros;
register int luptr, luptr1, luptr2;
int fsupc, nsupc, nsupr, segsze;
int nrow; /* No of rows in the matrix of matrix-vector */
int jsupno, k, ksub, krep, krep_ind, ksupno;
int ufirst, nextlu;
int fst_col; /* First column within small LU update */
int d_fsupc; /* Distance between the first column of the current
panel and the first column of the current snode.*/
int *xsup, *supno;
int *lsub, *xlsub, *xlsub_end;
doublecomplex *lusup;
int *xlusup, *xlusup_end;
doublecomplex *tempv1;
int mem_error;
register float flopcnt;
doublecomplex zero = {0.0, 0.0};
doublecomplex one = {1.0, 0.0};
doublecomplex none = {-1.0, 0.0};
doublecomplex comp_temp, comp_temp1;
xsup = Glu->xsup;
supno = Glu->supno;
lsub = Glu->lsub;
xlsub = Glu->xlsub;
xlsub_end = Glu->xlsub_end;
lusup = Glu->lusup;
xlusup = Glu->xlusup;
xlusup_end = Glu->xlusup_end;
jsupno = supno[jcol];
/*
* For each nonz supernode segment of U[*,j] in topological order
*/
k = nseg - 1;
for (ksub = 0; ksub < nseg; ksub++) {
krep = segrep[k];
k--;
ksupno = supno[krep];
#if ( DEBUGlvel>=2 )
if (jcol==BADCOL)
printf("(%d) pzgstrf_column_bmod[1]: %d, nseg %d, krep %d, jsupno %d, ksupno %d\n",
pnum, jcol, nseg, krep, jsupno, ksupno);
#endif
if ( jsupno != ksupno ) { /* Outside the rectangular supernode */
fsupc = xsup[ksupno];
fst_col = SUPERLU_MAX ( fsupc, fpanelc );
/* Distance from the current supernode to the current panel;
d_fsupc=0 if fsupc >= fpanelc. */
d_fsupc = fst_col - fsupc;
luptr = xlusup[fst_col] + d_fsupc;
lptr = xlsub[fsupc] + d_fsupc;
kfnz = repfnz[krep];
kfnz = SUPERLU_MAX ( kfnz, fpanelc );
segsze = krep - kfnz + 1;
nsupc = krep - fst_col + 1;
nsupr = xlsub_end[fsupc] - xlsub[fsupc]; /* Leading dimension */
nrow = nsupr - d_fsupc - nsupc;
krep_ind = lptr + nsupc - 1;
flopcnt = 4 * segsze * (segsze - 1) + 8 * nrow * segsze;
Gstat->procstat[pnum].fcops += flopcnt;
#if ( DEBUGlevel>=2 )
if (jcol==BADCOL)
printf("(%d) pzgstrf_column_bmod[2]: %d, krep %d, kfnz %d, segsze %d, d_fsupc %d,\
fsupc %d, nsupr %d, nsupc %d\n",
pnum, jcol, krep, kfnz, segsze, d_fsupc, fsupc, nsupr, nsupc);
#endif
/*
* Case 1: Update U-segment of size 1 -- col-col update
*/
if ( segsze == 1 ) {
ukj = dense[lsub[krep_ind]];
luptr += nsupr*(nsupc-1) + nsupc;
for (i = lptr + nsupc; i < xlsub_end[fsupc]; ++i) {
irow = lsub[i];
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
z_sub(&dense[irow], &dense[irow], &comp_temp);
luptr++;
}
} else if ( segsze <= 3 ) {
ukj = dense[lsub[krep_ind]];
luptr += nsupr*(nsupc-1) + nsupc-1;
ukj1 = dense[lsub[krep_ind - 1]];
luptr1 = luptr - nsupr;
if ( segsze == 2 ) { /* Case 2: 2cols-col update */
zz_mult(&comp_temp, &ukj1, &lusup[luptr1]);
z_sub(&ukj, &ukj, &comp_temp);
dense[lsub[krep_ind]] = ukj;
for (i = lptr + nsupc; i < xlsub_end[fsupc]; ++i) {
irow = lsub[i];
luptr++;
luptr1++;
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
zz_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&dense[irow], &dense[irow], &comp_temp);
}
} else { /* Case 3: 3cols-col update */
ukj2 = dense[lsub[krep_ind - 2]];
luptr2 = luptr1 - nsupr;
zz_mult(&comp_temp, &ukj2, &lusup[luptr2-1]);
z_sub(&ukj1, &ukj1, &comp_temp);
zz_mult(&comp_temp, &ukj1, &lusup[luptr1]);
zz_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&ukj, &ukj, &comp_temp);
dense[lsub[krep_ind]] = ukj;
dense[lsub[krep_ind-1]] = ukj1;
for (i = lptr + nsupc; i < xlsub_end[fsupc]; ++i) {
irow = lsub[i];
luptr++;
luptr1++;
luptr2++;
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
zz_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
zz_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&dense[irow], &dense[irow], &comp_temp);
}
}
} else {
/*
* Case: sup-col update
* Perform a triangular solve and block update,
* then scatter the result of sup-col update to dense
*/
no_zeros = kfnz - fst_col;
/* Copy U[*,j] segment from dense[*] to tempv[*] */
isub = lptr + no_zeros;
for (i = 0; i < segsze; i++) {
irow = lsub[isub];
tempv[i] = dense[irow];
++isub;
}
/* Dense triangular solve -- start effective triangle */
luptr += nsupr * no_zeros + no_zeros;
#ifdef USE_VENDOR_BLAS
#if ( MACH==CRAY_PVP )
CTRSV( ftcs1, ftcs2, ftcs3, &segsze, &lusup[luptr],
&nsupr, tempv, &incx );
#else
ztrsv_( "L", "N", "U", &segsze, &lusup[luptr],
&nsupr, tempv, &incx );
#endif
luptr += segsze; /* Dense matrix-vector */
tempv1 = &tempv[segsze];
alpha = one;
beta = zero;
#if ( MACH==CRAY_PVP )
CGEMV( ftcs2, &nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, tempv, &incx, &beta, tempv1, &incy );
#else
zgemv_( "N", &nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, tempv, &incx, &beta, tempv1, &incy );
#endif
#else
zlsolve ( nsupr, segsze, &lusup[luptr], tempv );
luptr += segsze; /* Dense matrix-vector */
tempv1 = &tempv[segsze];
zmatvec (nsupr, nrow , segsze, &lusup[luptr], tempv, tempv1);
#endif
/* Scatter tempv[] into SPA dense[*] */
isub = lptr + no_zeros;
for (i = 0; i < segsze; i++) {
irow = lsub[isub];
dense[irow] = tempv[i]; /* Scatter */
tempv[i] = zero;
isub++;
}
/* Scatter tempv1[] into SPA dense[*] */
for (i = 0; i < nrow; i++) {
irow = lsub[isub];
z_sub(&dense[irow], &dense[irow], &tempv1[i]);
tempv1[i] = zero;
++isub;
}
} /* else segsze >= 4 */
} /* if jsupno ... */
} /* for each segment... */
/* ------------------------------------------
Process the supernodal portion of L\U[*,j]
------------------------------------------ */
fsupc = SUPER_FSUPC (jsupno);
nsupr = xlsub_end[fsupc] - xlsub[fsupc];
if ( (mem_error = Glu_alloc(pnum, jcol, nsupr, LUSUP, &nextlu,
pxgstrf_shared)) )
return mem_error;
xlusup[jcol] = nextlu;
lusup = Glu->lusup;
/* Gather the nonzeros from SPA dense[*,j] into L\U[*,j] */
for (isub = xlsub[fsupc]; isub < xlsub_end[fsupc]; ++isub) {
irow = lsub[isub];
lusup[nextlu] = dense[irow];
dense[irow] = zero;
#ifdef DEBUG
if (jcol == -1)
printf("(%d) pzgstrf_column_bmod[lusup] jcol %d, irow %d, lusup %.10e\n",
pnum, jcol, irow, lusup[nextlu]);
#endif
++nextlu;
}
xlusup_end[jcol] = nextlu; /* close L\U[*,jcol] */
#if ( DEBUGlevel>=2 )
if (jcol == -1) {
nrow = xlusup_end[jcol] - xlusup[jcol];
print_double_vec("before sup-col update", nrow, &lsub[xlsub[fsupc]],
&lusup[xlusup[jcol]]);
}
#endif
/*
* For more updates within the panel (also within the current supernode),
* should start from the first column of the panel, or the first column
* of the supernode, whichever is bigger. There are 2 cases:
* (1) fsupc < fpanelc, then fst_col := fpanelc
* (2) fsupc >= fpanelc, then fst_col := fsupc
*/
fst_col = SUPERLU_MAX ( fsupc, fpanelc );
if ( fst_col < jcol ) {
/* distance between the current supernode and the current panel;
d_fsupc=0 if fsupc >= fpanelc. */
d_fsupc = fst_col - fsupc;
lptr = xlsub[fsupc] + d_fsupc;
luptr = xlusup[fst_col] + d_fsupc;
nsupr = xlsub_end[fsupc] - xlsub[fsupc]; /* Leading dimension */
nsupc = jcol - fst_col; /* Excluding jcol */
nrow = nsupr - d_fsupc - nsupc;
/* points to the beginning of jcol in supernode L\U[*,jsupno] */
ufirst = xlusup[jcol] + d_fsupc;
#if ( DEBUGlevel>=2 )
if (jcol==BADCOL)
printf("(%d) pzgstrf_column_bmod[3] jcol %d, fsupc %d, nsupr %d, nsupc %d, nrow %d\n",
pnum, jcol, fsupc, nsupr, nsupc, nrow);
#endif
flopcnt = 4 * nsupc * (nsupc - 1) + 8 * nrow * nsupc;
Gstat->procstat[pnum].fcops += flopcnt;
/* ops[TRSV] += nsupc * (nsupc - 1);
ops[GEMV] += 2 * nrow * nsupc; */
#ifdef USE_VENDOR_BLAS
alpha = none; beta = one; /* y := beta*y + alpha*A*x */
#if ( MACH==CRAY_PVP )
CTRSV( ftcs1, ftcs2, ftcs3, &nsupc, &lusup[luptr],
&nsupr, &lusup[ufirst], &incx );
CGEMV( ftcs2, &nrow, &nsupc, &alpha, &lusup[luptr+nsupc], &nsupr,
&lusup[ufirst], &incx, &beta, &lusup[ufirst+nsupc], &incy );
#else
ztrsv_( "L", "N", "U", &nsupc, &lusup[luptr],
&nsupr, &lusup[ufirst], &incx );
zgemv_( "N", &nrow, &nsupc, &alpha, &lusup[luptr+nsupc], &nsupr,
&lusup[ufirst], &incx, &beta, &lusup[ufirst+nsupc], &incy );
#endif
#else
zlsolve ( nsupr, nsupc, &lusup[luptr], &lusup[ufirst] );
zmatvec ( nsupr, nrow, nsupc, &lusup[luptr+nsupc],
&lusup[ufirst], tempv );
/* Copy updates from tempv[*] into lusup[*] */
isub = ufirst + nsupc;
for (i = 0; i < nrow; i++) {
z_sub(&lusup[isub], &lusup[isub], &tempv[i]);
tempv[i] = zero;
++isub;
}
#endif
} /* if fst_col < jcol ... */
return 0;
}
int
ilu_zpivotL(
const int jcol, /* in */
const double u, /* in - diagonal pivoting threshold */
int *usepr, /* re-use the pivot sequence given by
* perm_r/iperm_r */
int *perm_r, /* may be modified */
int diagind, /* diagonal of Pc*A*Pc' */
int *swap, /* in/out record the row permutation */
int *iswap, /* in/out inverse of swap, it is the same as
perm_r after the factorization */
int *marker, /* in */
int *pivrow, /* in/out, as an input if *usepr!=0 */
double fill_tol, /* in - fill tolerance of current column
* used for a singular column */
milu_t milu, /* in */
doublecomplex drop_sum, /* in - computed in ilu_zcopy_to_ucol()
(MILU only) */
GlobalLU_t *Glu, /* modified - global LU data structures */
SuperLUStat_t *stat /* output */
)
{
int n; /* number of columns */
int fsupc; /* first column in the supernode */
int nsupc; /* no of columns in the supernode */
int nsupr; /* no of rows in the supernode */
int lptr; /* points to the starting subscript of the supernode */
register int pivptr;
int old_pivptr, diag, ptr0;
register double pivmax, rtemp;
double thresh;
doublecomplex temp;
doublecomplex *lu_sup_ptr;
doublecomplex *lu_col_ptr;
int *lsub_ptr;
register int isub, icol, k, itemp;
int *lsub, *xlsub;
doublecomplex *lusup;
int *xlusup;
flops_t *ops = stat->ops;
int info;
doublecomplex one = {1.0, 0.0};
/* Initialize pointers */
n = Glu->n;
lsub = Glu->lsub;
xlsub = Glu->xlsub;
lusup = Glu->lusup;
xlusup = Glu->xlusup;
fsupc = (Glu->xsup)[(Glu->supno)[jcol]];
nsupc = jcol - fsupc; /* excluding jcol; nsupc >= 0 */
lptr = xlsub[fsupc];
nsupr = xlsub[fsupc+1] - lptr;
lu_sup_ptr = &lusup[xlusup[fsupc]]; /* start of the current supernode */
lu_col_ptr = &lusup[xlusup[jcol]]; /* start of jcol in the supernode */
lsub_ptr = &lsub[lptr]; /* start of row indices of the supernode */
/* Determine the largest abs numerical value for partial pivoting;
Also search for user-specified pivot, and diagonal element. */
pivmax = -1.0;
pivptr = nsupc;
diag = EMPTY;
old_pivptr = nsupc;
ptr0 = EMPTY;
for (isub = nsupc; isub < nsupr; ++isub) {
if (marker[lsub_ptr[isub]] > jcol)
continue; /* do not overlap with a later relaxed supernode */
switch (milu) {
case SMILU_1:
z_add(&temp, &lu_col_ptr[isub], &drop_sum);
rtemp = z_abs1(&temp);
break;
case SMILU_2:
case SMILU_3:
/* In this case, drop_sum contains the sum of the abs. value */
rtemp = z_abs1(&lu_col_ptr[isub]);
break;
case SILU:
default:
rtemp = z_abs1(&lu_col_ptr[isub]);
break;
}
if (rtemp > pivmax) { pivmax = rtemp; pivptr = isub; }
if (*usepr && lsub_ptr[isub] == *pivrow) old_pivptr = isub;
if (lsub_ptr[isub] == diagind) diag = isub;
if (ptr0 == EMPTY) ptr0 = isub;
}
if (milu == SMILU_2 || milu == SMILU_3) pivmax += drop_sum.r;
/* Test for singularity */
if (pivmax < 0.0) {
fprintf(stderr, "[0]: jcol=%d, SINGULAR!!!\n", jcol);
fflush(stderr);
exit(1);
}
if ( pivmax == 0.0 ) {
if (diag != EMPTY)
*pivrow = lsub_ptr[pivptr = diag];
else if (ptr0 != EMPTY)
*pivrow = lsub_ptr[pivptr = ptr0];
else {
/* look for the first row which does not
belong to any later supernodes */
for (icol = jcol; icol < n; icol++)
if (marker[swap[icol]] <= jcol) break;
if (icol >= n) {
fprintf(stderr, "[1]: jcol=%d, SINGULAR!!!\n", jcol);
fflush(stderr);
exit(1);
}
*pivrow = swap[icol];
/* pick up the pivot row */
for (isub = nsupc; isub < nsupr; ++isub)
if ( lsub_ptr[isub] == *pivrow ) { pivptr = isub; break; }
}
pivmax = fill_tol;
lu_col_ptr[pivptr].r = pivmax;
lu_col_ptr[pivptr].i = 0.0;
*usepr = 0;
#ifdef DEBUG
printf("[0] ZERO PIVOT: FILL (%d, %d).\n", *pivrow, jcol);
fflush(stdout);
#endif
info =jcol + 1;
} /* if (*pivrow == 0.0) */
else {
thresh = u * pivmax;
/* Choose appropriate pivotal element by our policy. */
if ( *usepr ) {
switch (milu) {
case SMILU_1:
z_add(&temp, &lu_col_ptr[old_pivptr], &drop_sum);
rtemp = z_abs1(&temp);
break;
case SMILU_2:
case SMILU_3:
rtemp = z_abs1(&lu_col_ptr[old_pivptr]) + drop_sum.r;
break;
case SILU:
default:
rtemp = z_abs1(&lu_col_ptr[old_pivptr]);
break;
}
if ( rtemp != 0.0 && rtemp >= thresh ) pivptr = old_pivptr;
else *usepr = 0;
}
if ( *usepr == 0 ) {
/* Use diagonal pivot? */
if ( diag >= 0 ) { /* diagonal exists */
switch (milu) {
case SMILU_1:
z_add(&temp, &lu_col_ptr[diag], &drop_sum);
rtemp = z_abs1(&temp);
break;
case SMILU_2:
case SMILU_3:
rtemp = z_abs1(&lu_col_ptr[diag]) + drop_sum.r;
break;
case SILU:
default:
rtemp = z_abs1(&lu_col_ptr[diag]);
break;
}
if ( rtemp != 0.0 && rtemp >= thresh ) pivptr = diag;
}
*pivrow = lsub_ptr[pivptr];
}
info = 0;
/* Reset the diagonal */
switch (milu) {
case SMILU_1:
z_add(&lu_col_ptr[pivptr], &lu_col_ptr[pivptr], &drop_sum);
break;
case SMILU_2:
case SMILU_3:
temp = z_sgn(&lu_col_ptr[pivptr]);
zz_mult(&temp, &temp, &drop_sum);
z_add(&lu_col_ptr[pivptr], &lu_col_ptr[pivptr], &drop_sum);
break;
case SILU:
default:
break;
}
} /* else */
/* Record pivot row */
perm_r[*pivrow] = jcol;
if (jcol < n - 1) {
register int t1, t2, t;
t1 = iswap[*pivrow]; t2 = jcol;
if (t1 != t2) {
t = swap[t1]; swap[t1] = swap[t2]; swap[t2] = t;
t1 = swap[t1]; t2 = t;
t = iswap[t1]; iswap[t1] = iswap[t2]; iswap[t2] = t;
}
} /* if (jcol < n - 1) */
/* Interchange row subscripts */
if ( pivptr != nsupc ) {
itemp = lsub_ptr[pivptr];
lsub_ptr[pivptr] = lsub_ptr[nsupc];
lsub_ptr[nsupc] = itemp;
/* Interchange numerical values as well, for the whole snode, such
* that L is indexed the same way as A.
*/
for (icol = 0; icol <= nsupc; icol++) {
itemp = pivptr + icol * nsupr;
temp = lu_sup_ptr[itemp];
lu_sup_ptr[itemp] = lu_sup_ptr[nsupc + icol*nsupr];
lu_sup_ptr[nsupc + icol*nsupr] = temp;
}
} /* if */
/* cdiv operation */
ops[FACT] += 10 * (nsupr - nsupc);
z_div(&temp, &one, &lu_col_ptr[nsupc]);
for (k = nsupc+1; k < nsupr; k++)
zz_mult(&lu_col_ptr[k], &lu_col_ptr[k], &temp);
return info;
}
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;
}
}
}
/*
* Performs sparse matrix-vector multiplication.
*/
void
pzgsmv
(
int_t abs, /* Input. Do abs(A)*abs(x). */
SuperMatrix *A_internal, /* Input. Matrix A permuted by columns.
The column indices are translated into
the relative positions in the gathered x-vector.
The type of A can be:
Stype = NR_loc; Dtype = SLU_Z; Mtype = GE. */
gridinfo_t *grid, /* Input */
pzgsmv_comm_t *gsmv_comm, /* Input. The data structure for communication. */
doublecomplex x[], /* Input. The distributed source vector */
doublecomplex ax[] /* Output. The distributed destination vector */
)
{
NRformat_loc *Astore;
int iam, procs;
int_t i, j, p, m, m_loc, n, fst_row, jcol;
int_t *colind, *rowptr;
int *SendCounts, *RecvCounts;
int_t *ind_tosend, *ind_torecv, *ptr_ind_tosend, *ptr_ind_torecv;
int_t *extern_start, TotalValSend;
doublecomplex *nzval, *val_tosend, *val_torecv;
doublecomplex zero = {0.0, 0.0}, temp;
double *ax_abs = (double *) ax;
MPI_Request *send_req, *recv_req;
MPI_Status status;
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(grid->iam, "Enter pzgsmv()");
#endif
/* ------------------------------------------------------------
INITIALIZATION.
------------------------------------------------------------*/
iam = grid->iam;
procs = grid->nprow * grid->npcol;
Astore = (NRformat_loc *) A_internal->Store;
m = A_internal->nrow;
n = A_internal->ncol;
m_loc = Astore->m_loc;
fst_row = Astore->fst_row;
colind = Astore->colind;
rowptr = Astore->rowptr;
nzval = (doublecomplex *) Astore->nzval;
extern_start = gsmv_comm->extern_start;
ind_torecv = gsmv_comm->ind_torecv;
ptr_ind_tosend = gsmv_comm->ptr_ind_tosend;
ptr_ind_torecv = gsmv_comm->ptr_ind_torecv;
SendCounts = gsmv_comm->SendCounts;
RecvCounts = gsmv_comm->RecvCounts;
val_tosend = (doublecomplex *) gsmv_comm->val_tosend;
val_torecv = (doublecomplex *) gsmv_comm->val_torecv;
TotalValSend = gsmv_comm->TotalValSend;
/* ------------------------------------------------------------
COPY THE X VALUES INTO THE SEND BUFFER.
------------------------------------------------------------*/
for (i = 0; i < TotalValSend; ++i) {
j = ind_torecv[i] - fst_row; /* Relative index in x[] */
val_tosend[i] = x[j];
}
/* ------------------------------------------------------------
COMMUNICATE THE X VALUES.
------------------------------------------------------------*/
if ( !(send_req = (MPI_Request *)
SUPERLU_MALLOC(2*procs *sizeof(MPI_Request))))
ABORT("Malloc fails for recv_req[].");
recv_req = send_req + procs;
for (p = 0; p < procs; ++p) {
if ( RecvCounts[p] ) {
MPI_Isend(&val_tosend[ptr_ind_torecv[p]], RecvCounts[p],
SuperLU_MPI_DOUBLE_COMPLEX, p, iam,
grid->comm, &send_req[p]);
}
if ( SendCounts[p] ) {
MPI_Irecv(&val_torecv[ptr_ind_tosend[p]], SendCounts[p],
SuperLU_MPI_DOUBLE_COMPLEX, p, p,
grid->comm, &recv_req[p]);
}
}
/* ------------------------------------------------------------
PERFORM THE ACTUAL MULTIPLICATION.
------------------------------------------------------------*/
if ( abs ) { /* Perform abs(A)*abs(x) */
/* Multiply the local part. */
for (i = 0; i < m_loc; ++i) { /* Loop through each row */
ax_abs[i] = 0.0;
for (j = rowptr[i]; j < extern_start[i]; ++j) {
jcol = colind[j];
ax_abs[i] += slud_z_abs1(&nzval[j]) * slud_z_abs1(&x[jcol]);
}
}
for (p = 0; p < procs; ++p) {
if ( RecvCounts[p] ) MPI_Wait(&send_req[p], &status);
if ( SendCounts[p] ) MPI_Wait(&recv_req[p], &status);
}
/* Multiply the external part. */
for (i = 0; i < m_loc; ++i) { /* Loop through each row */
for (j = extern_start[i]; j < rowptr[i+1]; ++j) {
jcol = colind[j];
ax_abs[i] += slud_z_abs1(&nzval[j]) * slud_z_abs(&val_torecv[jcol]);
}
}
} else {
/* Multiply the local part. */
for (i = 0; i < m_loc; ++i) { /* Loop through each row */
ax[i] = zero;
for (j = rowptr[i]; j < extern_start[i]; ++j) {
jcol = colind[j];
zz_mult(&temp, &nzval[j], &x[jcol]);
z_add(&ax[i], &ax[i], &temp);
}
}
for (p = 0; p < procs; ++p) {
if ( RecvCounts[p] ) MPI_Wait(&send_req[p], &status);
if ( SendCounts[p] ) MPI_Wait(&recv_req[p], &status);
}
/* Multiply the external part. */
for (i = 0; i < m_loc; ++i) { /* Loop through each row */
for (j = extern_start[i]; j < rowptr[i+1]; ++j) {
jcol = colind[j];
zz_mult(&temp, &nzval[j], &val_torecv[jcol]);
z_add(&ax[i], &ax[i], &temp);
}
}
}
SUPERLU_FREE(send_req);
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Exit pzgsmv()");
#endif
} /* PZGSMV */
/*! \brief Performs one of the matrix-vector operations y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y
*
* <pre>
* Purpose
* =======
*
* sp_zgemv() performs one of the matrix-vector operations
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
* where alpha and beta are scalars, x and y are vectors and A is a
* sparse A->nrow by A->ncol matrix.
*
* Parameters
* ==========
*
* TRANS - (input) char*
* On entry, TRANS specifies the operation to be performed as
* follows:
* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
* TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
*
* ALPHA - (input) doublecomplex
* On entry, ALPHA specifies the scalar alpha.
*
* A - (input) SuperMatrix*
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients.
*
* X - (input) doublecomplex*, array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
* and at least
* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
* Before entry, the incremented array X must contain the
* vector x.
*
* INCX - (input) int
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
*
* BETA - (input) doublecomplex
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
*
* Y - (output) doublecomplex*, array of DIMENSION at least
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
* and at least
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
* Before entry with BETA non-zero, the incremented array Y
* must contain the vector y. On exit, Y is overwritten by the
* updated vector y.
*
* INCY - (input) int
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
*
* ==== Sparse Level 2 Blas routine.
* </pre>
*/
int
sp_zgemv(char *trans, doublecomplex alpha, SuperMatrix *A, doublecomplex *x,
int incx, doublecomplex beta, doublecomplex *y, int incy)
{
/* Local variables */
NCformat *Astore;
doublecomplex *Aval;
int info;
doublecomplex temp, temp1;
int lenx, leny, i, j, irow;
int iy, jx, jy, kx, ky;
int notran;
doublecomplex comp_zero = {0.0, 0.0};
doublecomplex comp_one = {1.0, 0.0};
notran = lsame_(trans, "N");
Astore = A->Store;
Aval = Astore->nzval;
/* Test the input parameters */
info = 0;
if ( !notran && !lsame_(trans, "T") && !lsame_(trans, "C")) info = 1;
else if ( A->nrow < 0 || A->ncol < 0 ) info = 3;
else if (incx == 0) info = 5;
else if (incy == 0) info = 8;
if (info != 0) {
xerbla_("sp_zgemv ", &info);
return 0;
}
/* Quick return if possible. */
if (A->nrow == 0 || A->ncol == 0 ||
z_eq(&alpha, &comp_zero) &&
z_eq(&beta, &comp_one))
return 0;
/* Set LENX and LENY, the lengths of the vectors x and y, and set
up the start points in X and Y. */
if (lsame_(trans, "N")) {
lenx = A->ncol;
leny = A->nrow;
} else {
lenx = A->nrow;
leny = A->ncol;
}
if (incx > 0) kx = 0;
else kx = - (lenx - 1) * incx;
if (incy > 0) ky = 0;
else ky = - (leny - 1) * incy;
/* Start the operations. In this version the elements of A are
accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if ( !z_eq(&beta, &comp_one) ) {
if (incy == 1) {
if ( z_eq(&beta, &comp_zero) )
for (i = 0; i < leny; ++i) y[i] = comp_zero;
else
for (i = 0; i < leny; ++i)
zz_mult(&y[i], &beta, &y[i]);
} else {
iy = ky;
if ( z_eq(&beta, &comp_zero) )
for (i = 0; i < leny; ++i) {
y[iy] = comp_zero;
iy += incy;
}
else
for (i = 0; i < leny; ++i) {
zz_mult(&y[iy], &beta, &y[iy]);
iy += incy;
}
}
}
if ( z_eq(&alpha, &comp_zero) ) return 0;
if ( notran ) {
/* Form y := alpha*A*x + y. */
jx = kx;
if (incy == 1) {
for (j = 0; j < A->ncol; ++j) {
if ( !z_eq(&x[jx], &comp_zero) ) {
zz_mult(&temp, &alpha, &x[jx]);
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
zz_mult(&temp1, &temp, &Aval[i]);
z_add(&y[irow], &y[irow], &temp1);
}
}
jx += incx;
}
} else {
ABORT("Not implemented.");
}
} else {
/* Form y := alpha*A'*x + y. */
jy = ky;
if (incx == 1) {
for (j = 0; j < A->ncol; ++j) {
temp = comp_zero;
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
zz_mult(&temp1, &Aval[i], &x[irow]);
z_add(&temp, &temp, &temp1);
}
zz_mult(&temp1, &alpha, &temp);
z_add(&y[jy], &y[jy], &temp1);
jy += incy;
}
} else {
ABORT("Not implemented.");
}
}
return 0;
} /* sp_zgemv */
void
pzgsrfs_ABXglobal(int_t n, SuperMatrix *A, double anorm, LUstruct_t *LUstruct,
gridinfo_t *grid, doublecomplex *B, int_t ldb, doublecomplex *X, int_t ldx,
int nrhs, double *berr, SuperLUStat_t *stat, int *info)
{
#define ITMAX 20
Glu_persist_t *Glu_persist = LUstruct->Glu_persist;
LocalLU_t *Llu = LUstruct->Llu;
/*
* Data structures used by matrix-vector multiply routine.
*/
int_t N_update; /* Number of variables updated on this process */
int_t *update; /* vector elements (global index) updated
on this processor. */
int_t *bindx;
doublecomplex *val;
int_t *mv_sup_to_proc; /* Supernode to process mapping in
matrix-vector multiply. */
/*-- end data structures for matrix-vector multiply --*/
doublecomplex *b, *ax, *R, *B_col, *temp, *work, *X_col,
*x_trs, *dx_trs;
double *rwork;
int_t notran;
int_t count, ii, j, jj, k, knsupc, lk, lwork,
nprow, nsupers, nz, p;
int i, iam, pkk;
int_t *ilsum, *xsup;
double eps, lstres;
double s, safmin, safe1, safe2;
/* NEW STUFF */
int_t num_diag_procs, *diag_procs; /* Record diagonal process numbers. */
int_t *diag_len; /* Length of the X vector on diagonal processes. */
/*-- Function prototypes --*/
extern void pzgstrs1(int_t, LUstruct_t *, gridinfo_t *,
doublecomplex *, int, SuperLUStat_t *, int *);
/*extern double dlamch_(char *);*/
/* Test the input parameters. */
*info = 0;
if ( n < 0 ) *info = -1;
else if ( A->nrow != A->ncol || A->nrow < 0 ||
A->Stype != SLU_NCP || A->Dtype != SLU_Z || A->Mtype != SLU_GE )
*info = -2;
else if ( ldb < SUPERLU_MAX(0, n) ) *info = -10;
else if ( ldx < SUPERLU_MAX(0, n) ) *info = -12;
else if ( nrhs < 0 ) *info = -13;
if (*info != 0) {
i = -(*info);
xerbla_("pzgsrfs_ABXglobal", &i);
return;
}
/* Quick return if possible. */
if ( n == 0 || nrhs == 0 ) {
return;
}
/* Initialization. */
iam = grid->iam;
nprow = grid->nprow;
nsupers = Glu_persist->supno[n-1] + 1;
xsup = Glu_persist->xsup;
ilsum = Llu->ilsum;
notran = 1;
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Enter pzgsrfs_ABXglobal()");
#endif
get_diag_procs(n, Glu_persist, grid, &num_diag_procs,
&diag_procs, &diag_len);
#if ( PRNTlevel>=1 )
if ( !iam ) {
printf(".. number of diag processes = %d\n", num_diag_procs);
PrintInt10("diag_procs", num_diag_procs, diag_procs);
PrintInt10("diag_len", num_diag_procs, diag_len);
}
#endif
if ( !(mv_sup_to_proc = intCalloc_dist(nsupers)) )
ABORT("Calloc fails for mv_sup_to_proc[]");
pzgsmv_AXglobal_setup(A, Glu_persist, grid, &N_update, &update,
&val, &bindx, mv_sup_to_proc);
i = CEILING( nsupers, nprow ); /* Number of local block rows */
ii = Llu->ldalsum + i * XK_H;
k = SUPERLU_MAX(N_update, sp_ienv_dist(3));
jj = diag_len[0];
for (j = 1; j < num_diag_procs; ++j) jj = SUPERLU_MAX( jj, diag_len[j] );
jj = SUPERLU_MAX( jj, N_update );
lwork = N_update /* For ax and R */
+ ii /* For dx_trs */
+ ii /* For x_trs */
+ k /* For b */
+ jj; /* for temp */
if ( !(work = doublecomplexMalloc_dist(lwork)) )
ABORT("Malloc fails for work[]");
ax = R = work;
dx_trs = work + N_update;
x_trs = dx_trs + ii;
b = x_trs + ii;
temp = b + k;
if ( !(rwork = SUPERLU_MALLOC(N_update * sizeof(double))) )
ABORT("Malloc fails for rwork[]");
#if ( DEBUGlevel>=2 )
{
doublecomplex *dwork = doublecomplexMalloc_dist(n);
for (i = 0; i < n; ++i) {
if ( i & 1 ) dwork[i].r = 1.;
else dwork[i].r = 2.;
dwork[i].i = 0.;
}
/* Check correctness of matrix-vector multiply. */
pzgsmv_AXglobal(N_update, update, val, bindx, dwork, ax);
PrintDouble5("Mult A*x", N_update, ax);
SUPERLU_FREE(dwork);
}
#endif
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = A->ncol + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
/* Set SAFE1 essentially to be the underflow threshold times the
number of additions in each row. */
safe1 = nz * safmin;
safe2 = safe1 / eps;
#if ( DEBUGlevel>=1 )
if ( !iam ) printf(".. eps = %e\tanorm = %e\tsafe1 = %e\tsafe2 = %e\n",
eps, anorm, safe1, safe2);
#endif
/* Do for each right-hand side ... */
for (j = 0; j < nrhs; ++j) {
count = 0;
lstres = 3.;
/* Copy X into x on the diagonal processes. */
B_col = &B[j*ldb];
X_col = &X[j*ldx];
for (p = 0; p < num_diag_procs; ++p) {
pkk = diag_procs[p];
if ( iam == pkk ) {
for (k = p; k < nsupers; k += num_diag_procs) {
knsupc = SuperSize( k );
lk = LBi( k, grid );
ii = ilsum[lk] + (lk+1)*XK_H;
jj = FstBlockC( k );
for (i = 0; i < knsupc; ++i) x_trs[i+ii] = X_col[i+jj];
dx_trs[ii-XK_H].r = k;/* Block number prepended in header. */
}
}
}
/* Copy B into b distributed the same way as matrix-vector product. */
if ( N_update ) ii = update[0];
for (i = 0; i < N_update; ++i) b[i] = B_col[i + ii];
while (1) { /* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
/* Matrix-vector multiply. */
pzgsmv_AXglobal(N_update, update, val, bindx, X_col, ax);
/* Compute residual. */
for (i = 0; i < N_update; ++i) z_sub(&R[i], &b[i], &ax[i]);
/* Compute abs(op(A))*abs(X) + abs(B). */
pzgsmv_AXglobal_abs(N_update, update, val, bindx, X_col, rwork);
for (i = 0; i < N_update; ++i) rwork[i] += slud_z_abs1(&b[i]);
s = 0.0;
for (i = 0; i < N_update; ++i) {
if ( rwork[i] > safe2 ) {
s = SUPERLU_MAX(s, slud_z_abs1(&R[i]) / rwork[i]);
} else if ( rwork[i] != 0.0 ) {
s = SUPERLU_MAX(s, (safe1 + slud_z_abs1(&R[i])) / rwork[i]);
}
/* If temp[i] is exactly 0.0 (computed by PxGSMV), then
we know the true residual also must be exactly 0.0. */
}
MPI_Allreduce( &s, &berr[j], 1, MPI_DOUBLE, MPI_MAX, grid->comm );
#if ( PRNTlevel>= 1 )
if ( !iam )
printf("(%2d) .. Step %2d: berr[j] = %e\n", iam, count, berr[j]);
#endif
if ( berr[j] > eps && berr[j] * 2 <= lstres && count < ITMAX ) {
/* Compute new dx. */
redist_all_to_diag(n, R, Glu_persist, Llu, grid,
mv_sup_to_proc, dx_trs);
pzgstrs1(n, LUstruct, grid, dx_trs, 1, stat, info);
/* Update solution. */
for (p = 0; p < num_diag_procs; ++p)
if ( iam == diag_procs[p] )
for (k = p; k < nsupers; k += num_diag_procs) {
lk = LBi( k, grid );
ii = ilsum[lk] + (lk+1)*XK_H;
knsupc = SuperSize( k );
for (i = 0; i < knsupc; ++i)
z_add(&x_trs[i + ii], &x_trs[i + ii],
&dx_trs[i + ii]);
}
lstres = berr[j];
++count;
/* Transfer x_trs (on diagonal processes) into X
(on all processes). */
gather_1rhs_diag_to_all(n, x_trs, Glu_persist, Llu, grid,
num_diag_procs, diag_procs, diag_len,
X_col, temp);
} else {
break;
}
} /* end while */
stat->RefineSteps = count;
} /* for j ... */
/* Deallocate storage used by matrix-vector multiplication. */
SUPERLU_FREE(diag_procs);
SUPERLU_FREE(diag_len);
if ( N_update ) {
SUPERLU_FREE(update);
SUPERLU_FREE(bindx);
SUPERLU_FREE(val);
}
SUPERLU_FREE(mv_sup_to_proc);
SUPERLU_FREE(work);
SUPERLU_FREE(rwork);
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Exit pzgsrfs_ABXglobal()");
#endif
} /* PZGSRFS_ABXGLOBAL */
void
pzgstrf_bmod2D(
const int pnum, /* process number */
const int m, /* number of columns in the matrix */
const int w, /* current panel width */
const int jcol, /* leading column of the current panel */
const int fsupc, /* leading column of the updating supernode */
const int krep, /* last column of the updating supernode */
const int nsupc, /* number of columns in the updating s-node */
int nsupr, /* number of rows in the updating s-node */
int nrow, /* number of rows below the diagonal block of
the updating supernode */
int *repfnz, /* in */
int *panel_lsub, /* modified */
int *w_lsub_end, /* modified */
int *spa_marker, /* modified; size n-by-w */
doublecomplex *dense, /* modified */
doublecomplex *tempv, /* working array - zeros on entry/exit */
GlobalLU_t *Glu, /* modified */
Gstat_t *Gstat /* modified */
)
{
/*
* -- SuperLU MT routine (version 2.0) --
* Lawrence Berkeley National Lab, Univ. of California Berkeley,
* and Xerox Palo Alto Research Center.
* September 10, 2007
*
* Purpose
* =======
*
* Performs numeric 2-D block updates (sup-panel) in topological order.
* Results are returned in SPA dense[*,w].
*
*/
#if ( MACH==CRAY_PVP )
_fcd ftcs1 = _cptofcd("L", strlen("L")),
ftcs2 = _cptofcd("N", strlen("N")),
ftcs3 = _cptofcd("U", strlen("U"));
#endif
#ifdef USE_VENDOR_BLAS
int incx = 1, incy = 1;
doublecomplex alpha, beta;
#endif
doublecomplex zero = {0.0, 0.0};
doublecomplex one = {1.0, 0.0};
doublecomplex comp_temp, comp_temp1;
doublecomplex ukj, ukj1, ukj2;
int luptr, luptr1, luptr2;
int segsze;
int block_nrow; /* no of rows in a block row */
register int lptr; /* points to the row subscripts of a supernode */
int kfnz, irow, no_zeros;
register int isub, isub1, i;
register int jj; /* index through each column in the panel */
int krep_ind;
int *repfnz_col; /* repfnz[] for a column in the panel */
int *col_marker; /* each column of the spa_marker[*,w] */
int *col_lsub; /* each column of the panel_lsub[*,w] */
doublecomplex *dense_col; /* dense[] for a column in the panel */
doublecomplex *TriTmp, *MatvecTmp;
register int ldaTmp;
register int r_ind, r_hi;
static int first = 1, maxsuper, rowblk;
int *lsub, *xlsub_end;
doublecomplex *lusup;
int *xlusup;
register float flopcnt;
#ifdef TIMING
double *utime = Gstat->utime;
double f_time;
#endif
if ( first ) {
maxsuper = sp_ienv(3);
rowblk = sp_ienv(4);
first = 0;
}
ldaTmp = maxsuper + rowblk;
lsub = Glu->lsub;
xlsub_end = Glu->xlsub_end;
lusup = Glu->lusup;
xlusup = Glu->xlusup;
lptr = Glu->xlsub[fsupc];
krep_ind = lptr + nsupc - 1;
repfnz_col= repfnz;
dense_col = dense;
TriTmp = tempv;
col_marker= spa_marker;
col_lsub = panel_lsub;
/* ---------------------------------------------------------------
* Sequence through each column in the panel -- triangular solves.
* The results of the triangular solves of all columns in the
* panel are temporaroly stored in TriTemp array.
* For the unrolled small supernodes of size <= 3, we also perform
* matrix-vector updates from below the diagonal block.
* ---------------------------------------------------------------
*/
for (jj = jcol; jj < jcol + w; ++jj, col_marker += m, col_lsub += m,
repfnz_col += m, dense_col += m, TriTmp += ldaTmp ) {
kfnz = repfnz_col[krep];
if ( kfnz == EMPTY ) continue; /* Skip any zero segment */
segsze = krep - kfnz + 1;
luptr = xlusup[fsupc];
flopcnt = 4 * segsze * (segsze - 1) + 8 * nrow * segsze;
Gstat->procstat[pnum].fcops += flopcnt;
/* ops[TRSV] += segsze * (segsze - 1);
ops[GEMV] += 2 * nrow * segsze; */
#ifdef TIMING
f_time = SuperLU_timer_();
#endif
/* Case 1: Update U-segment of size 1 -- col-col update */
if ( segsze == 1 ) {
ukj = dense_col[lsub[krep_ind]];
luptr += nsupr*(nsupc-1) + nsupc;
for (i = lptr + nsupc; i < xlsub_end[fsupc]; i++) {
irow = lsub[i];
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
z_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
++luptr;
#ifdef SCATTER_FOUND
if ( col_marker[irow] != jj ) {
col_marker[irow] = jj;
col_lsub[w_lsub_end[jj-jcol]++] = irow;
}
#endif
}
#ifdef TIMING
utime[FLOAT] += SuperLU_timer_() - f_time;
#endif
} else if ( segsze <= 3 ) {
ukj = dense_col[lsub[krep_ind]];
ukj1 = dense_col[lsub[krep_ind - 1]];
luptr += nsupr*(nsupc-1) + nsupc-1;
luptr1 = luptr - nsupr;
if ( segsze == 2 ) {
zz_mult(&comp_temp, &ukj1, &lusup[luptr1]);
z_sub(&ukj, &ukj, &comp_temp);
dense_col[lsub[krep_ind]] = ukj;
for (i = lptr + nsupc; i < xlsub_end[fsupc]; ++i) {
irow = lsub[i];
luptr++; luptr1++;
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
zz_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
#ifdef SCATTER_FOUND
if ( col_marker[irow] != jj ) {
col_marker[irow] = jj;
col_lsub[w_lsub_end[jj-jcol]++] = irow;
}
#endif
}
#ifdef TIMING
utime[FLOAT] += SuperLU_timer_() - f_time;
#endif
} else {
ukj2 = dense_col[lsub[krep_ind - 2]];
luptr2 = luptr1 - nsupr;
zz_mult(&comp_temp, &ukj2, &lusup[luptr2-1]);
z_sub(&ukj1, &ukj1, &comp_temp);
zz_mult(&comp_temp, &ukj1, &lusup[luptr1]);
zz_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&ukj, &ukj, &comp_temp);
dense_col[lsub[krep_ind]] = ukj;
dense_col[lsub[krep_ind-1]] = ukj1;
for (i = lptr + nsupc; i < xlsub_end[fsupc]; ++i) {
irow = lsub[i];
luptr++; luptr1++; luptr2++;
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
zz_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
zz_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
#ifdef SCATTER_FOUND
if ( col_marker[irow] != jj ) {
col_marker[irow] = jj;
col_lsub[w_lsub_end[jj-jcol]++] = irow;
}
#endif
}
}
#ifdef TIMING
utime[FLOAT] += SuperLU_timer_() - f_time;
#endif
} else { /* segsze >= 4 */
/* Copy A[*,j] segment from dense[*] to TriTmp[*], which
holds the result of triangular solve. */
no_zeros = kfnz - fsupc;
isub = lptr + no_zeros;
for (i = 0; i < segsze; ++i) {
irow = lsub[isub];
TriTmp[i] = dense_col[irow]; /* Gather */
++isub;
}
/* start effective triangle */
luptr += nsupr * no_zeros + no_zeros;
#ifdef TIMING
f_time = SuperLU_timer_();
#endif
#ifdef USE_VENDOR_BLAS
#if ( MACH==CRAY_PVP )
CTRSV( ftcs1, ftcs2, ftcs3, &segsze, &lusup[luptr],
&nsupr, TriTmp, &incx );
#else
ztrsv_( "L", "N", "U", &segsze, &lusup[luptr],
&nsupr, TriTmp, &incx );
#endif
#else
zlsolve ( nsupr, segsze, &lusup[luptr], TriTmp );
#endif
#ifdef TIMING
utime[FLOAT] += SuperLU_timer_() - f_time;
#endif
} /* else ... */
} /* for jj ... end tri-solves */
/* --------------------------------------------------------
* Perform block row updates from below the diagonal block.
* Push each block all the way into SPA dense[*].
* --------------------------------------------------------
*/
for ( r_ind = 0; r_ind < nrow; r_ind += rowblk ) {
r_hi = SUPERLU_MIN(nrow, r_ind + rowblk);
block_nrow = SUPERLU_MIN(rowblk, r_hi - r_ind);
luptr = xlusup[fsupc] + nsupc + r_ind;
isub1 = lptr + nsupc + r_ind;
repfnz_col = repfnz;
TriTmp = tempv;
dense_col = dense;
col_marker= spa_marker;
col_lsub = panel_lsub;
/* Sequence through each column in the panel -- matrix-vector */
for (jj = jcol; jj < jcol + w; ++jj, col_marker += m, col_lsub += m,
repfnz_col += m, dense_col += m, TriTmp += ldaTmp) {
kfnz = repfnz_col[krep];
if ( kfnz == EMPTY ) continue; /* skip any zero segment */
segsze = krep - kfnz + 1;
if ( segsze <= 3 ) continue; /* skip unrolled cases */
/* Perform a block update, and scatter the result of
matrix-vector into SPA dense[*]. */
no_zeros = kfnz - fsupc;
luptr1 = luptr + nsupr * no_zeros;
MatvecTmp = &TriTmp[maxsuper];
#ifdef TIMING
f_time = SuperLU_timer_();
#endif
#ifdef USE_VENDOR_BLAS
alpha = one;
beta = zero;
#if ( MACH==CRAY_PVP )
CGEMV( ftcs2, &block_nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, TriTmp, &incx, &beta, MatvecTmp, &incy );
#else
zgemv_( "N", &block_nrow, &segsze, &alpha, &lusup[luptr1],
&nsupr, TriTmp, &incx, &beta, MatvecTmp, &incy );
#endif /* _CRAY_PVP */
#else
zmatvec(nsupr, block_nrow, segsze, &lusup[luptr1],
TriTmp, MatvecTmp);
#endif
#ifdef TIMING
utime[FLOAT] += SuperLU_timer_() - f_time;
#endif
/* Scatter MatvecTmp[*] into SPA dense[*] temporarily,
* such that MatvecTmp[*] can be re-used for the
* the next block row update. dense[] will be copied into
* global store after the whole panel has been finished.
*/
isub = isub1;
for (i = 0; i < block_nrow; i++) {
irow = lsub[isub];
z_sub(&dense_col[irow], &dense_col[irow],
&MatvecTmp[i]); /* Scatter-add */
#ifdef SCATTER_FOUND
if ( col_marker[irow] != jj ) {
col_marker[irow] = jj;
col_lsub[w_lsub_end[jj-jcol]++] = irow;
}
#endif
MatvecTmp[i] = zero;
++isub;
}
} /* for jj ... */
} /* for each block row ... */
/* ------------------------------------------------
Scatter the triangular solves into SPA dense[*].
------------------------------------------------ */
repfnz_col = repfnz;
TriTmp = tempv;
dense_col = dense;
for (jj = 0; jj < w; ++jj, repfnz_col += m, dense_col += m,
TriTmp += ldaTmp) {
kfnz = repfnz_col[krep];
if ( kfnz == EMPTY ) continue; /* skip any zero segment */
segsze = krep - kfnz + 1;
if ( segsze <= 3 ) continue; /* skip unrolled cases */
no_zeros = kfnz - fsupc;
isub = lptr + no_zeros;
for (i = 0; i < segsze; i++) {
irow = lsub[isub];
dense_col[irow] = TriTmp[i]; /* Scatter */
TriTmp[i] = zero;
++isub;
}
} /* for jj ... */
}
/*! \brief
* <pre>
* Purpose
* =======
* ilu_zdrop_row() - Drop some small rows from the previous
* supernode (L-part only).
* </pre>
*/
int ilu_zdrop_row(
superlu_options_t *options, /* options */
int first, /* index of the first column in the supernode */
int last, /* index of the last column in the supernode */
double drop_tol, /* dropping parameter */
int quota, /* maximum nonzero entries allowed */
int *nnzLj, /* in/out number of nonzeros in L(:, 1:last) */
double *fill_tol, /* in/out - on exit, fill_tol=-num_zero_pivots,
* does not change if options->ILU_MILU != SMILU1 */
GlobalLU_t *Glu, /* modified */
double dwork[], /* working space
* the length of dwork[] should be no less than
* the number of rows in the supernode */
double dwork2[], /* working space with the same size as dwork[],
* used only by the second dropping rule */
int lastc /* if lastc == 0, there is nothing after the
* working supernode [first:last];
* if lastc == 1, there is one more column after
* the working supernode. */ )
{
register int i, j, k, m1;
register int nzlc; /* number of nonzeros in column last+1 */
register int xlusup_first, xlsub_first;
int m, n; /* m x n is the size of the supernode */
int r = 0; /* number of dropped rows */
register double *temp;
register doublecomplex *lusup = Glu->lusup;
register int *lsub = Glu->lsub;
register int *xlsub = Glu->xlsub;
register int *xlusup = Glu->xlusup;
register double d_max = 0.0, d_min = 1.0;
int drop_rule = options->ILU_DropRule;
milu_t milu = options->ILU_MILU;
norm_t nrm = options->ILU_Norm;
doublecomplex zero = {0.0, 0.0};
doublecomplex one = {1.0, 0.0};
doublecomplex none = {-1.0, 0.0};
int i_1 = 1;
int inc_diag; /* inc_diag = m + 1 */
int nzp = 0; /* number of zero pivots */
double alpha = pow((double)(Glu->n), -1.0 / options->ILU_MILU_Dim);
xlusup_first = xlusup[first];
xlsub_first = xlsub[first];
m = xlusup[first + 1] - xlusup_first;
n = last - first + 1;
m1 = m - 1;
inc_diag = m + 1;
nzlc = lastc ? (xlusup[last + 2] - xlusup[last + 1]) : 0;
temp = dwork - n;
/* Quick return if nothing to do. */
if (m == 0 || m == n || drop_rule == NODROP)
{
*nnzLj += m * n;
return 0;
}
/* basic dropping: ILU(tau) */
for (i = n; i <= m1; )
{
/* the average abs value of ith row */
switch (nrm)
{
case ONE_NORM:
temp[i] = dzasum_(&n, &lusup[xlusup_first + i], &m) / (double)n;
break;
case TWO_NORM:
temp[i] = dznrm2_(&n, &lusup[xlusup_first + i], &m)
/ sqrt((double)n);
break;
case INF_NORM:
default:
k = izamax_(&n, &lusup[xlusup_first + i], &m) - 1;
temp[i] = z_abs1(&lusup[xlusup_first + i + m * k]);
break;
}
/* drop small entries due to drop_tol */
if (drop_rule & DROP_BASIC && temp[i] < drop_tol)
{
r++;
/* drop the current row and move the last undropped row here */
if (r > 1) /* add to last row */
{
/* accumulate the sum (for MILU) */
switch (milu)
{
case SMILU_1:
case SMILU_2:
zaxpy_(&n, &one, &lusup[xlusup_first + i], &m,
&lusup[xlusup_first + m - 1], &m);
break;
case SMILU_3:
for (j = 0; j < n; j++)
lusup[xlusup_first + (m - 1) + j * m].r +=
z_abs1(&lusup[xlusup_first + i + j * m]);
break;
case SILU:
default:
break;
}
zcopy_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
} /* if (r > 1) */
else /* move to last row */
{
zswap_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
if (milu == SMILU_3)
for (j = 0; j < n; j++) {
lusup[xlusup_first + m1 + j * m].r =
z_abs1(&lusup[xlusup_first + m1 + j * m]);
lusup[xlusup_first + m1 + j * m].i = 0.0;
}
}
lsub[xlsub_first + i] = lsub[xlsub_first + m1];
m1--;
continue;
} /* if dropping */
else
{
if (temp[i] > d_max) d_max = temp[i];
if (temp[i] < d_min) d_min = temp[i];
}
i++;
} /* for */
/* Secondary dropping: drop more rows according to the quota. */
quota = ceil((double)quota / (double)n);
if (drop_rule & DROP_SECONDARY && m - r > quota)
{
register double tol = d_max;
/* Calculate the second dropping tolerance */
if (quota > n)
{
if (drop_rule & DROP_INTERP) /* by interpolation */
{
d_max = 1.0 / d_max; d_min = 1.0 / d_min;
tol = 1.0 / (d_max + (d_min - d_max) * quota / (m - n - r));
}
else /* by quick select */
{
int len = m1 - n + 1;
dcopy_(&len, dwork, &i_1, dwork2, &i_1);
tol = dqselect(len, dwork2, quota - n);
#if 0
register int *itemp = iwork - n;
A = temp;
for (i = n; i <= m1; i++) itemp[i] = i;
qsort(iwork, m1 - n + 1, sizeof(int), _compare_);
tol = temp[itemp[quota]];
#endif
}
}
for (i = n; i <= m1; )
{
if (temp[i] <= tol)
{
register int j;
r++;
/* drop the current row and move the last undropped row here */
if (r > 1) /* add to last row */
{
/* accumulate the sum (for MILU) */
switch (milu)
{
case SMILU_1:
case SMILU_2:
zaxpy_(&n, &one, &lusup[xlusup_first + i], &m,
&lusup[xlusup_first + m - 1], &m);
break;
case SMILU_3:
for (j = 0; j < n; j++)
lusup[xlusup_first + (m - 1) + j * m].r +=
z_abs1(&lusup[xlusup_first + i + j * m]);
break;
case SILU:
default:
break;
}
zcopy_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
} /* if (r > 1) */
else /* move to last row */
{
zswap_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
if (milu == SMILU_3)
for (j = 0; j < n; j++) {
lusup[xlusup_first + m1 + j * m].r =
z_abs1(&lusup[xlusup_first + m1 + j * m]);
lusup[xlusup_first + m1 + j * m].i = 0.0;
}
}
lsub[xlsub_first + i] = lsub[xlsub_first + m1];
m1--;
temp[i] = temp[m1];
continue;
}
i++;
} /* for */
} /* if secondary dropping */
for (i = n; i < m; i++) temp[i] = 0.0;
if (r == 0)
{
*nnzLj += m * n;
return 0;
}
/* add dropped entries to the diagnal */
if (milu != SILU)
{
register int j;
doublecomplex t;
double omega;
for (j = 0; j < n; j++)
{
t = lusup[xlusup_first + (m - 1) + j * m];
if (t.r == 0.0 && t.i == 0.0) continue;
omega = SUPERLU_MIN(2.0 * (1.0 - alpha) / z_abs1(&t), 1.0);
zd_mult(&t, &t, omega);
switch (milu)
{
case SMILU_1:
if ( !(z_eq(&t, &none)) ) {
z_add(&t, &t, &one);
zz_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
&t);
}
else
{
zd_mult(
&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
*fill_tol);
#ifdef DEBUG
printf("[1] ZERO PIVOT: FILL col %d.\n", first + j);
fflush(stdout);
#endif
nzp++;
}
break;
case SMILU_2:
zd_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
1.0 + z_abs1(&t));
break;
case SMILU_3:
z_add(&t, &t, &one);
zz_mult(&lusup[xlusup_first + j * inc_diag],
&lusup[xlusup_first + j * inc_diag],
&t);
break;
case SILU:
default:
break;
}
}
if (nzp > 0) *fill_tol = -nzp;
}
/* Remove dropped entries from the memory and fix the pointers. */
m1 = m - r;
for (j = 1; j < n; j++)
{
register int tmp1, tmp2;
tmp1 = xlusup_first + j * m1;
tmp2 = xlusup_first + j * m;
for (i = 0; i < m1; i++)
lusup[i + tmp1] = lusup[i + tmp2];
}
for (i = 0; i < nzlc; i++)
lusup[xlusup_first + i + n * m1] = lusup[xlusup_first + i + n * m];
for (i = 0; i < nzlc; i++)
lsub[xlsub[last + 1] - r + i] = lsub[xlsub[last + 1] + i];
for (i = first + 1; i <= last + 1; i++)
{
xlusup[i] -= r * (i - first);
xlsub[i] -= r;
}
if (lastc)
{
xlusup[last + 2] -= r * n;
xlsub[last + 2] -= r;
}
*nnzLj += (m - r) * n;
return r;
}
int
sp_zgemv(char *trans, doublecomplex alpha, SuperMatrix *A, doublecomplex *x,
int incx, doublecomplex beta, doublecomplex *y, int incy)
{
/* Purpose
=======
sp_zgemv() performs one of the matrix-vector operations
y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
where alpha and beta are scalars, x and y are vectors and A is a
sparse A->nrow by A->ncol matrix.
Parameters
==========
TRANS - (input) char*
On entry, TRANS specifies the operation to be performed as
follows:
TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
ALPHA - (input) doublecomplex
On entry, ALPHA specifies the scalar alpha.
A - (input) SuperMatrix*
Before entry, the leading m by n part of the array A must
contain the matrix of coefficients.
X - (input) doublecomplex*, array of DIMENSION at least
( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
and at least
( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
Before entry, the incremented array X must contain the
vector x.
INCX - (input) int
On entry, INCX specifies the increment for the elements of
X. INCX must not be zero.
BETA - (input) doublecomplex
On entry, BETA specifies the scalar beta. When BETA is
supplied as zero then Y need not be set on input.
Y - (output) doublecomplex*, array of DIMENSION at least
( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
and at least
( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
Before entry with BETA non-zero, the incremented array Y
must contain the vector y. On exit, Y is overwritten by the
updated vector y.
INCY - (input) int
On entry, INCY specifies the increment for the elements of
Y. INCY must not be zero.
==== Sparse Level 2 Blas routine.
*/
/* Local variables */
NCformat *Astore;
doublecomplex *Aval;
int info;
doublecomplex temp, temp1;
int lenx, leny, i, j, irow;
int iy, jx, jy, kx, ky;
int notran;
doublecomplex comp_zero = {0.0, 0.0};
doublecomplex comp_one = {1.0, 0.0};
notran = lsame_(trans, "N");
Astore = A->Store;
Aval = Astore->nzval;
/* Test the input parameters */
info = 0;
if ( !notran && !lsame_(trans, "T") && !lsame_(trans, "C")) info = 1;
else if ( A->nrow < 0 || A->ncol < 0 ) info = 3;
else if (incx == 0) info = 5;
else if (incy == 0) info = 8;
if (info != 0) {
xerbla_("sp_zgemv ", &info);
return 0;
}
/* Quick return if possible. */
if (A->nrow == 0 || A->ncol == 0 ||
z_eq(&alpha, &comp_zero) &&
z_eq(&beta, &comp_one))
return 0;
/* Set LENX and LENY, the lengths of the vectors x and y, and set
up the start points in X and Y. */
if (lsame_(trans, "N")) {
lenx = A->ncol;
leny = A->nrow;
} else {
lenx = A->nrow;
leny = A->ncol;
}
if (incx > 0) kx = 0;
else kx = - (lenx - 1) * incx;
if (incy > 0) ky = 0;
else ky = - (leny - 1) * incy;
/* Start the operations. In this version the elements of A are
accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if ( !z_eq(&beta, &comp_one) ) {
if (incy == 1) {
if ( z_eq(&beta, &comp_zero) )
for (i = 0; i < leny; ++i) y[i] = comp_zero;
else
for (i = 0; i < leny; ++i)
zz_mult(&y[i], &beta, &y[i]);
} else {
iy = ky;
if ( z_eq(&beta, &comp_zero) )
for (i = 0; i < leny; ++i) {
y[iy] = comp_zero;
iy += incy;
}
else
for (i = 0; i < leny; ++i) {
zz_mult(&y[iy], &beta, &y[iy]);
iy += incy;
}
}
}
if ( z_eq(&alpha, &comp_zero) ) return 0;
if ( notran ) {
/* Form y := alpha*A*x + y. */
jx = kx;
if (incy == 1) {
for (j = 0; j < A->ncol; ++j) {
if ( !z_eq(&x[jx], &comp_zero) ) {
zz_mult(&temp, &alpha, &x[jx]);
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
zz_mult(&temp1, &temp, &Aval[i]);
z_add(&y[irow], &y[irow], &temp1);
}
}
jx += incx;
}
} else {
ABORT("Not implemented.");
}
} else {
/* Form y := alpha*A'*x + y. */
jy = ky;
if (incx == 1) {
for (j = 0; j < A->ncol; ++j) {
temp = comp_zero;
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
zz_mult(&temp1, &Aval[i], &x[irow]);
z_add(&temp, &temp, &temp1);
}
zz_mult(&temp1, &alpha, &temp);
z_add(&y[jy], &y[jy], &temp1);
jy += incy;
}
} else {
ABORT("Not implemented.");
}
}
return 0;
} /* sp_zgemv */
void
zpanel_bmod (
const int m, /* in - number of rows in the matrix */
const int w, /* in */
const int jcol, /* in */
const int nseg, /* in */
doublecomplex *dense, /* out, of size n by w */
doublecomplex *tempv, /* working array */
int *segrep, /* in */
int *repfnz, /* in, of size n by w */
GlobalLU_t *Glu, /* modified */
SuperLUStat_t *stat /* output */
)
{
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
_fcd ftcs1 = _cptofcd("L", strlen("L")),
ftcs2 = _cptofcd("N", strlen("N")),
ftcs3 = _cptofcd("U", strlen("U"));
#endif
int incx = 1, incy = 1;
doublecomplex alpha, beta;
#endif
register int k, ksub;
int fsupc, nsupc, nsupr, nrow;
int krep, krep_ind;
doublecomplex ukj, ukj1, ukj2;
int luptr, luptr1, luptr2;
int segsze;
int block_nrow; /* no of rows in a block row */
register int lptr; /* Points to the row subscripts of a supernode */
int kfnz, irow, no_zeros;
register int isub, isub1, i;
register int jj; /* Index through each column in the panel */
int *xsup, *supno;
int *lsub, *xlsub;
doublecomplex *lusup;
int *xlusup;
int *repfnz_col; /* repfnz[] for a column in the panel */
doublecomplex *dense_col; /* dense[] for a column in the panel */
doublecomplex *tempv1; /* Used in 1-D update */
doublecomplex *TriTmp, *MatvecTmp; /* used in 2-D update */
doublecomplex zero = {0.0, 0.0};
doublecomplex one = {1.0, 0.0};
doublecomplex comp_temp, comp_temp1;
register int ldaTmp;
register int r_ind, r_hi;
static int first = 1, maxsuper, rowblk, colblk;
flops_t *ops = stat->ops;
xsup = Glu->xsup;
supno = Glu->supno;
lsub = Glu->lsub;
xlsub = Glu->xlsub;
lusup = Glu->lusup;
xlusup = Glu->xlusup;
if ( first ) {
maxsuper = SUPERLU_MAX( sp_ienv(3), sp_ienv(7) );
rowblk = sp_ienv(4);
colblk = sp_ienv(5);
first = 0;
}
ldaTmp = maxsuper + rowblk;
/*
* For each nonz supernode segment of U[*,j] in topological order
*/
k = nseg - 1;
for (ksub = 0; ksub < nseg; ksub++) { /* for each updating supernode */
/* krep = representative of current k-th supernode
* fsupc = first supernodal column
* nsupc = no of columns in a supernode
* nsupr = no of rows in a supernode
*/
krep = segrep[k--];
fsupc = xsup[supno[krep]];
nsupc = krep - fsupc + 1;
nsupr = xlsub[fsupc+1] - xlsub[fsupc];
nrow = nsupr - nsupc;
lptr = xlsub[fsupc];
krep_ind = lptr + nsupc - 1;
repfnz_col = repfnz;
dense_col = dense;
if ( nsupc >= colblk && nrow > rowblk ) { /* 2-D block update */
TriTmp = tempv;
/* Sequence through each column in panel -- triangular solves */
for (jj = jcol; jj < jcol + w; jj++,
repfnz_col += m, dense_col += m, TriTmp += ldaTmp ) {
kfnz = repfnz_col[krep];
if ( kfnz == EMPTY ) continue; /* Skip any zero segment */
segsze = krep - kfnz + 1;
luptr = xlusup[fsupc];
ops[TRSV] += 4 * segsze * (segsze - 1);
ops[GEMV] += 8 * nrow * segsze;
/* Case 1: Update U-segment of size 1 -- col-col update */
if ( segsze == 1 ) {
ukj = dense_col[lsub[krep_ind]];
luptr += nsupr*(nsupc-1) + nsupc;
for (i = lptr + nsupc; i < xlsub[fsupc+1]; i++) {
irow = lsub[i];
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
z_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
++luptr;
}
} else if ( segsze <= 3 ) {
ukj = dense_col[lsub[krep_ind]];
ukj1 = dense_col[lsub[krep_ind - 1]];
luptr += nsupr*(nsupc-1) + nsupc-1;
luptr1 = luptr - nsupr;
if ( segsze == 2 ) {
zz_mult(&comp_temp, &ukj1, &lusup[luptr1]);
z_sub(&ukj, &ukj, &comp_temp);
dense_col[lsub[krep_ind]] = ukj;
for (i = lptr + nsupc; i < xlsub[fsupc+1]; ++i) {
irow = lsub[i];
luptr++; luptr1++;
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
zz_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
}
} else {
ukj2 = dense_col[lsub[krep_ind - 2]];
luptr2 = luptr1 - nsupr;
zz_mult(&comp_temp, &ukj2, &lusup[luptr2-1]);
z_sub(&ukj1, &ukj1, &comp_temp);
zz_mult(&comp_temp, &ukj1, &lusup[luptr1]);
zz_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&ukj, &ukj, &comp_temp);
dense_col[lsub[krep_ind]] = ukj;
dense_col[lsub[krep_ind-1]] = ukj1;
for (i = lptr + nsupc; i < xlsub[fsupc+1]; ++i) {
irow = lsub[i];
luptr++; luptr1++; luptr2++;
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
zz_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
zz_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
}
}
} else { /* segsze >= 4 */
/* Copy U[*,j] segment from dense[*] to TriTmp[*], which
holds the result of triangular solves. */
no_zeros = kfnz - fsupc;
isub = lptr + no_zeros;
for (i = 0; i < segsze; ++i) {
irow = lsub[isub];
TriTmp[i] = dense_col[irow]; /* Gather */
++isub;
}
/* start effective triangle */
luptr += nsupr * no_zeros + no_zeros;
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV( ftcs1, ftcs2, ftcs3, &segsze, &lusup[luptr],
&nsupr, TriTmp, &incx );
#else
ztrsv_( "L", "N", "U", &segsze, &lusup[luptr],
&nsupr, TriTmp, &incx );
#endif
#else
zlsolve ( nsupr, segsze, &lusup[luptr], TriTmp );
#endif
} /* else ... */
} /* for jj ... end tri-solves */
/* Block row updates; push all the way into dense[*] block */
for ( r_ind = 0; r_ind < nrow; r_ind += rowblk ) {
r_hi = SUPERLU_MIN(nrow, r_ind + rowblk);
block_nrow = SUPERLU_MIN(rowblk, r_hi - r_ind);
luptr = xlusup[fsupc] + nsupc + r_ind;
isub1 = lptr + nsupc + r_ind;
repfnz_col = repfnz;
TriTmp = tempv;
dense_col = dense;
/* Sequence through each column in panel -- matrix-vector */
for (jj = jcol; jj < jcol + w; jj++,
repfnz_col += m, dense_col += m, TriTmp += ldaTmp) {
kfnz = repfnz_col[krep];
if ( kfnz == EMPTY ) continue; /* Skip any zero segment */
segsze = krep - kfnz + 1;
if ( segsze <= 3 ) continue; /* skip unrolled cases */
/* Perform a block update, and scatter the result of
matrix-vector to dense[]. */
no_zeros = kfnz - fsupc;
luptr1 = luptr + nsupr * no_zeros;
MatvecTmp = &TriTmp[maxsuper];
#ifdef USE_VENDOR_BLAS
alpha = one;
beta = zero;
#ifdef _CRAY
CGEMV(ftcs2, &block_nrow, &segsze, &alpha, &lusup[luptr1],
&nsupr, TriTmp, &incx, &beta, MatvecTmp, &incy);
#else
zgemv_("N", &block_nrow, &segsze, &alpha, &lusup[luptr1],
&nsupr, TriTmp, &incx, &beta, MatvecTmp, &incy);
#endif
#else
zmatvec(nsupr, block_nrow, segsze, &lusup[luptr1],
TriTmp, MatvecTmp);
#endif
/* Scatter MatvecTmp[*] into SPA dense[*] temporarily
* such that MatvecTmp[*] can be re-used for the
* the next blok row update. dense[] will be copied into
* global store after the whole panel has been finished.
*/
isub = isub1;
for (i = 0; i < block_nrow; i++) {
irow = lsub[isub];
z_sub(&dense_col[irow], &dense_col[irow],
&MatvecTmp[i]);
MatvecTmp[i] = zero;
++isub;
}
} /* for jj ... */
} /* for each block row ... */
/* Scatter the triangular solves into SPA dense[*] */
repfnz_col = repfnz;
TriTmp = tempv;
dense_col = dense;
for (jj = jcol; jj < jcol + w; jj++,
repfnz_col += m, dense_col += m, TriTmp += ldaTmp) {
kfnz = repfnz_col[krep];
if ( kfnz == EMPTY ) continue; /* Skip any zero segment */
segsze = krep - kfnz + 1;
if ( segsze <= 3 ) continue; /* skip unrolled cases */
no_zeros = kfnz - fsupc;
isub = lptr + no_zeros;
for (i = 0; i < segsze; i++) {
irow = lsub[isub];
dense_col[irow] = TriTmp[i];
TriTmp[i] = zero;
++isub;
}
} /* for jj ... */
} else { /* 1-D block modification */
/* Sequence through each column in the panel */
for (jj = jcol; jj < jcol + w; jj++,
repfnz_col += m, dense_col += m) {
kfnz = repfnz_col[krep];
if ( kfnz == EMPTY ) continue; /* Skip any zero segment */
segsze = krep - kfnz + 1;
luptr = xlusup[fsupc];
ops[TRSV] += 4 * segsze * (segsze - 1);
ops[GEMV] += 8 * nrow * segsze;
/* Case 1: Update U-segment of size 1 -- col-col update */
if ( segsze == 1 ) {
ukj = dense_col[lsub[krep_ind]];
luptr += nsupr*(nsupc-1) + nsupc;
for (i = lptr + nsupc; i < xlsub[fsupc+1]; i++) {
irow = lsub[i];
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
z_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
++luptr;
}
} else if ( segsze <= 3 ) {
ukj = dense_col[lsub[krep_ind]];
luptr += nsupr*(nsupc-1) + nsupc-1;
ukj1 = dense_col[lsub[krep_ind - 1]];
luptr1 = luptr - nsupr;
if ( segsze == 2 ) {
zz_mult(&comp_temp, &ukj1, &lusup[luptr1]);
z_sub(&ukj, &ukj, &comp_temp);
dense_col[lsub[krep_ind]] = ukj;
for (i = lptr + nsupc; i < xlsub[fsupc+1]; ++i) {
irow = lsub[i];
++luptr; ++luptr1;
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
zz_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
}
} else {
ukj2 = dense_col[lsub[krep_ind - 2]];
luptr2 = luptr1 - nsupr;
zz_mult(&comp_temp, &ukj2, &lusup[luptr2-1]);
z_sub(&ukj1, &ukj1, &comp_temp);
zz_mult(&comp_temp, &ukj1, &lusup[luptr1]);
zz_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&ukj, &ukj, &comp_temp);
dense_col[lsub[krep_ind]] = ukj;
dense_col[lsub[krep_ind-1]] = ukj1;
for (i = lptr + nsupc; i < xlsub[fsupc+1]; ++i) {
irow = lsub[i];
++luptr; ++luptr1; ++luptr2;
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
zz_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
zz_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
}
}
} else { /* segsze >= 4 */
/*
* Perform a triangular solve and block update,
* then scatter the result of sup-col update to dense[].
*/
no_zeros = kfnz - fsupc;
/* Copy U[*,j] segment from dense[*] to tempv[*]:
* The result of triangular solve is in tempv[*];
* The result of matrix vector update is in dense_col[*]
*/
isub = lptr + no_zeros;
for (i = 0; i < segsze; ++i) {
irow = lsub[isub];
tempv[i] = dense_col[irow]; /* Gather */
++isub;
}
/* start effective triangle */
luptr += nsupr * no_zeros + no_zeros;
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV( ftcs1, ftcs2, ftcs3, &segsze, &lusup[luptr],
&nsupr, tempv, &incx );
#else
ztrsv_( "L", "N", "U", &segsze, &lusup[luptr],
&nsupr, tempv, &incx );
#endif
luptr += segsze; /* Dense matrix-vector */
tempv1 = &tempv[segsze];
alpha = one;
beta = zero;
#ifdef _CRAY
CGEMV( ftcs2, &nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, tempv, &incx, &beta, tempv1, &incy );
#else
zgemv_( "N", &nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, tempv, &incx, &beta, tempv1, &incy );
#endif
#else
zlsolve ( nsupr, segsze, &lusup[luptr], tempv );
luptr += segsze; /* Dense matrix-vector */
tempv1 = &tempv[segsze];
zmatvec (nsupr, nrow, segsze, &lusup[luptr], tempv, tempv1);
#endif
/* Scatter tempv[*] into SPA dense[*] temporarily, such
* that tempv[*] can be used for the triangular solve of
* the next column of the panel. They will be copied into
* ucol[*] after the whole panel has been finished.
*/
isub = lptr + no_zeros;
for (i = 0; i < segsze; i++) {
irow = lsub[isub];
dense_col[irow] = tempv[i];
tempv[i] = zero;
isub++;
}
/* Scatter the update from tempv1[*] into SPA dense[*] */
/* Start dense rectangular L */
for (i = 0; i < nrow; i++) {
irow = lsub[isub];
z_sub(&dense_col[irow], &dense_col[irow], &tempv1[i]);
tempv1[i] = zero;
++isub;
}
} /* else segsze>=4 ... */
} /* for each column in the panel... */
} /* else 1-D update ... */
} /* for each updating supernode ... */
}
void
pzgsrfs_ABXglobal(int_t n, SuperMatrix *A, double anorm, LUstruct_t *LUstruct,
gridinfo_t *grid, doublecomplex *B, int_t ldb,
doublecomplex *X, int_t ldx, int nrhs, double *berr,
SuperLUStat_t *stat, int *info)
{
/*
* Purpose
* =======
*
* pzgsrfs_ABXglobal improves the computed solution to a system of linear
* equations and provides error bounds and backward error estimates
* for the solution.
*
* Arguments
* =========
*
* n (input) int (global)
* The order of the system of linear equations.
*
* A (input) SuperMatrix*
* The original matrix A, or the scaled A if equilibration was done.
* A is also permuted into the form Pc*Pr*A*Pc', where Pr and Pc
* are permutation matrices. The type of A can be:
* Stype = NCP; Dtype = Z; Mtype = GE.
*
* NOTE: Currently, A must reside in all processes when calling
* this routine.
*
* anorm (input) double
* The norm of the original matrix A, or the scaled A if
* equilibration was done.
*
* 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_ddefs.h for the definition of 'LUstruct_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_ddefs.h for the definition of 'gridinfo_t'.
*
* B (input) doublecomplex* (global)
* The N-by-NRHS right-hand side matrix of the possibly equilibrated
* and row permuted system.
*
* NOTE: Currently, B must reside on all processes when calling
* this routine.
*
* ldb (input) int (global)
* Leading dimension of matrix B.
*
* X (input/output) doublecomplex* (global)
* On entry, the solution matrix X, as computed by pzgstrs.
* On exit, the improved solution matrix X.
* If DiagScale = COL or BOTH, X should be premultiplied by diag(C)
* in order to obtain the solution to the original system.
*
* NOTE: Currently, X must reside on all processes when calling
* this routine.
*
* ldx (input) int (global)
* Leading dimension of matrix X.
*
* nrhs (input) int
* Number of right-hand sides.
*
* berr (output) double*, dimension (nrhs)
* The componentwise relative backward error of each solution
* vector X(j) (i.e., the smallest relative change in
* any element of A or B that makes X(j) an exact solution).
*
* stat (output) SuperLUStat_t*
* Record the statistics about the refinement steps.
* 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
*
* Internal Parameters
* ===================
*
* ITMAX is the maximum number of steps of iterative refinement.
*
*/
#define ITMAX 20
Glu_persist_t *Glu_persist = LUstruct->Glu_persist;
LocalLU_t *Llu = LUstruct->Llu;
/*
* Data structures used by matrix-vector multiply routine.
*/
int_t N_update; /* Number of variables updated on this process */
int_t *update; /* vector elements (global index) updated
on this processor. */
int_t *bindx;
doublecomplex *val;
int_t *mv_sup_to_proc; /* Supernode to process mapping in
matrix-vector multiply. */
/*-- end data structures for matrix-vector multiply --*/
doublecomplex *b, *ax, *R, *B_col, *temp, *work, *X_col,
*x_trs, *dx_trs;
double *rwork;
int_t count, ii, j, jj, k, knsupc, lk, lwork,
nprow, nsupers, notran, nz, p;
int i, iam, pkk;
int_t *ilsum, *xsup;
double eps, lstres;
double s, safmin, safe1, safe2;
/* NEW STUFF */
int_t num_diag_procs, *diag_procs; /* Record diagonal process numbers. */
int_t *diag_len; /* Length of the X vector on diagonal processes. */
/*-- Function prototypes --*/
extern void pzgstrs1(int_t, LUstruct_t *, gridinfo_t *,
doublecomplex *, int, SuperLUStat_t *, int *);
extern double dlamch_(char *);
/* Test the input parameters. */
*info = 0;
if ( n < 0 ) *info = -1;
else if ( A->nrow != A->ncol || A->nrow < 0 ||
A->Stype != SLU_NCP || A->Dtype != SLU_Z || A->Mtype != SLU_GE )
*info = -2;
else if ( ldb < SUPERLU_MAX(0, n) ) *info = -10;
else if ( ldx < SUPERLU_MAX(0, n) ) *info = -12;
else if ( nrhs < 0 ) *info = -13;
if (*info != 0) {
i = -(*info);
xerbla_("pzgsrfs_ABXglobal", &i);
return;
}
/* Quick return if possible. */
if ( n == 0 || nrhs == 0 ) {
return;
}
/* Initialization. */
iam = grid->iam;
nprow = grid->nprow;
nsupers = Glu_persist->supno[n-1] + 1;
xsup = Glu_persist->xsup;
ilsum = Llu->ilsum;
notran = 1;
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Enter pzgsrfs_ABXglobal()");
#endif
get_diag_procs(n, Glu_persist, grid, &num_diag_procs,
&diag_procs, &diag_len);
#if ( PRNTlevel>=1 )
if ( !iam ) {
printf(".. number of diag processes = %d\n", num_diag_procs);
PrintInt10("diag_procs", num_diag_procs, diag_procs);
PrintInt10("diag_len", num_diag_procs, diag_len);
}
#endif
if ( !(mv_sup_to_proc = intCalloc_dist(nsupers)) )
ABORT("Calloc fails for mv_sup_to_proc[]");
pzgsmv_AXglobal_setup(A, Glu_persist, grid, &N_update, &update,
&val, &bindx, mv_sup_to_proc);
i = CEILING( nsupers, nprow ); /* Number of local block rows */
ii = Llu->ldalsum + i * XK_H;
k = SUPERLU_MAX(N_update, sp_ienv_dist(3));
jj = diag_len[0];
for (j = 1; j < num_diag_procs; ++j) jj = SUPERLU_MAX( jj, diag_len[j] );
jj = SUPERLU_MAX( jj, N_update );
lwork = N_update /* For ax and R */
+ ii /* For dx_trs */
+ ii /* For x_trs */
+ k /* For b */
+ jj; /* for temp */
if ( !(work = doublecomplexMalloc_dist(lwork)) )
ABORT("Malloc fails for work[]");
ax = R = work;
dx_trs = work + N_update;
x_trs = dx_trs + ii;
b = x_trs + ii;
temp = b + k;
if ( !(rwork = SUPERLU_MALLOC(N_update * sizeof(double))) )
ABORT("Malloc fails for rwork[]");
#if ( DEBUGlevel>=2 )
{
doublecomplex *dwork = doublecomplexMalloc_dist(n);
for (i = 0; i < n; ++i) {
if ( i & 1 ) dwork[i].r = 1.;
else dwork[i].r = 2.;
dwork[i].i = 0.;
}
/* Check correctness of matrix-vector multiply. */
pzgsmv_AXglobal(N_update, update, val, bindx, dwork, ax);
PrintDouble5("Mult A*x", N_update, ax);
SUPERLU_FREE(dwork);
}
#endif
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = A->ncol + 1;
eps = dlamch_("Epsilon");
safmin = dlamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
#if ( DEBUGlevel>=1 )
if ( !iam ) printf(".. eps = %e\tanorm = %e\tsafe1 = %e\tsafe2 = %e\n",
eps, anorm, safe1, safe2);
#endif
/* Do for each right-hand side ... */
for (j = 0; j < nrhs; ++j) {
count = 0;
lstres = 3.;
/* Copy X into x on the diagonal processes. */
B_col = &B[j*ldb];
X_col = &X[j*ldx];
for (p = 0; p < num_diag_procs; ++p) {
pkk = diag_procs[p];
if ( iam == pkk ) {
for (k = p; k < nsupers; k += num_diag_procs) {
knsupc = SuperSize( k );
lk = LBi( k, grid );
ii = ilsum[lk] + (lk+1)*XK_H;
jj = FstBlockC( k );
for (i = 0; i < knsupc; ++i) x_trs[i+ii] = X_col[i+jj];
dx_trs[ii-XK_H].r = k;/* Block number prepended in header. */
}
}
}
/* Copy B into b distributed the same way as matrix-vector product. */
ii = update[0];
for (i = 0; i < N_update; ++i) b[i] = B_col[i + ii];
while (1) { /* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
/* Matrix-vector multiply. */
pzgsmv_AXglobal(N_update, update, val, bindx, X_col, ax);
/* Compute residual. */
for (i = 0; i < N_update; ++i) z_sub(&R[i], &b[i], &ax[i]);
/* Compute abs(op(A))*abs(X) + abs(B). */
pzgsmv_AXglobal_abs(N_update, update, val, bindx, X_col, rwork);
for (i = 0; i < N_update; ++i) rwork[i] += z_abs1(&b[i]);
s = 0.0;
for (i = 0; i < N_update; ++i) {
if ( rwork[i] > safe2 )
s = SUPERLU_MAX(s, z_abs1(&R[i]) / rwork[i]);
else
s = SUPERLU_MAX(s, (z_abs1(&R[i])+safe1)/(rwork[i]+safe1));
}
MPI_Allreduce( &s, &berr[j], 1, MPI_DOUBLE, MPI_MAX, grid->comm );
#if ( PRNTlevel>= 1 )
if ( !iam )
printf("(%2d) .. Step %2d: berr[j] = %e\n", iam, count, berr[j]);
#endif
if ( berr[j] > eps && berr[j] * 2 <= lstres && count < ITMAX ) {
/* Compute new dx. */
redist_all_to_diag(n, R, Glu_persist, Llu, grid,
mv_sup_to_proc, dx_trs);
pzgstrs1(n, LUstruct, grid, dx_trs, 1, stat, info);
/* Update solution. */
for (p = 0; p < num_diag_procs; ++p)
if ( iam == diag_procs[p] )
for (k = p; k < nsupers; k += num_diag_procs) {
lk = LBi( k, grid );
ii = ilsum[lk] + (lk+1)*XK_H;
knsupc = SuperSize( k );
for (i = 0; i < knsupc; ++i)
z_add(&x_trs[i + ii], &x_trs[i + ii],
&dx_trs[i + ii]);
}
lstres = berr[j];
++count;
/* Transfer x_trs (on diagonal processes) into X
(on all processes). */
gather_1rhs_diag_to_all(n, x_trs, Glu_persist, Llu, grid,
num_diag_procs, diag_procs, diag_len,
X_col, temp);
} else {
break;
}
} /* end while */
stat->RefineSteps = count;
} /* for j ... */
/* Deallocate storage used by matrix-vector multiplication. */
SUPERLU_FREE(diag_procs);
SUPERLU_FREE(diag_len);
if ( N_update ) {
SUPERLU_FREE(update);
SUPERLU_FREE(bindx);
SUPERLU_FREE(val);
}
SUPERLU_FREE(mv_sup_to_proc);
SUPERLU_FREE(work);
SUPERLU_FREE(rwork);
#if ( DEBUGlevel>=1 )
CHECK_MALLOC(iam, "Exit pzgsrfs_ABXglobal()");
#endif
} /* PZGSRFS_ABXGLOBAL */
/* Return value: 0 - successful return
* > 0 - number of bytes allocated when run out of space
*/
int
zcolumn_bmod (
const int jcol, /* in */
const int nseg, /* in */
doublecomplex *dense, /* in */
doublecomplex *tempv, /* working array */
int *segrep, /* in */
int *repfnz, /* in */
int fpanelc, /* in -- first column in the current panel */
GlobalLU_t *Glu, /* modified */
SuperLUStat_t *stat /* output */
)
{
/*
* Purpose:
* ========
* Performs numeric block updates (sup-col) in topological order.
* It features: col-col, 2cols-col, 3cols-col, and sup-col updates.
* Special processing on the supernodal portion of L\U[*,j]
*
*/
#ifdef _CRAY
_fcd ftcs1 = _cptofcd("L", strlen("L")),
ftcs2 = _cptofcd("N", strlen("N")),
ftcs3 = _cptofcd("U", strlen("U"));
#endif
int incx = 1, incy = 1;
doublecomplex alpha, beta;
/* krep = representative of current k-th supernode
* fsupc = first supernodal column
* nsupc = no of columns in supernode
* nsupr = no of rows in supernode (used as leading dimension)
* luptr = location of supernodal LU-block in storage
* kfnz = first nonz in the k-th supernodal segment
* no_zeros = no of leading zeros in a supernodal U-segment
*/
doublecomplex ukj, ukj1, ukj2;
int luptr, luptr1, luptr2;
int fsupc, nsupc, nsupr, segsze;
int nrow; /* No of rows in the matrix of matrix-vector */
int jcolp1, jsupno, k, ksub, krep, krep_ind, ksupno;
register int lptr, kfnz, isub, irow, i;
register int no_zeros, new_next;
int ufirst, nextlu;
int fst_col; /* First column within small LU update */
int d_fsupc; /* Distance between the first column of the current
panel and the first column of the current snode. */
int *xsup, *supno;
int *lsub, *xlsub;
doublecomplex *lusup;
int *xlusup;
int nzlumax;
doublecomplex *tempv1;
doublecomplex zero = {0.0, 0.0};
doublecomplex one = {1.0, 0.0};
doublecomplex none = {-1.0, 0.0};
doublecomplex comp_temp, comp_temp1;
int mem_error;
flops_t *ops = stat->ops;
xsup = Glu->xsup;
supno = Glu->supno;
lsub = Glu->lsub;
xlsub = Glu->xlsub;
lusup = Glu->lusup;
xlusup = Glu->xlusup;
nzlumax = Glu->nzlumax;
jcolp1 = jcol + 1;
jsupno = supno[jcol];
/*
* For each nonz supernode segment of U[*,j] in topological order
*/
k = nseg - 1;
for (ksub = 0; ksub < nseg; ksub++) {
krep = segrep[k];
k--;
ksupno = supno[krep];
if ( jsupno != ksupno ) { /* Outside the rectangular supernode */
fsupc = xsup[ksupno];
fst_col = SUPERLU_MAX ( fsupc, fpanelc );
/* Distance from the current supernode to the current panel;
d_fsupc=0 if fsupc > fpanelc. */
d_fsupc = fst_col - fsupc;
luptr = xlusup[fst_col] + d_fsupc;
lptr = xlsub[fsupc] + d_fsupc;
kfnz = repfnz[krep];
kfnz = SUPERLU_MAX ( kfnz, fpanelc );
segsze = krep - kfnz + 1;
nsupc = krep - fst_col + 1;
nsupr = xlsub[fsupc+1] - xlsub[fsupc]; /* Leading dimension */
nrow = nsupr - d_fsupc - nsupc;
krep_ind = lptr + nsupc - 1;
ops[TRSV] += 4 * segsze * (segsze - 1);
ops[GEMV] += 8 * nrow * segsze;
/*
* Case 1: Update U-segment of size 1 -- col-col update
*/
if ( segsze == 1 ) {
ukj = dense[lsub[krep_ind]];
luptr += nsupr*(nsupc-1) + nsupc;
for (i = lptr + nsupc; i < xlsub[fsupc+1]; ++i) {
irow = lsub[i];
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
z_sub(&dense[irow], &dense[irow], &comp_temp);
luptr++;
}
} else if ( segsze <= 3 ) {
ukj = dense[lsub[krep_ind]];
luptr += nsupr*(nsupc-1) + nsupc-1;
ukj1 = dense[lsub[krep_ind - 1]];
luptr1 = luptr - nsupr;
if ( segsze == 2 ) { /* Case 2: 2cols-col update */
zz_mult(&comp_temp, &ukj1, &lusup[luptr1]);
z_sub(&ukj, &ukj, &comp_temp);
dense[lsub[krep_ind]] = ukj;
for (i = lptr + nsupc; i < xlsub[fsupc+1]; ++i) {
irow = lsub[i];
luptr++;
luptr1++;
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
zz_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&dense[irow], &dense[irow], &comp_temp);
}
} else { /* Case 3: 3cols-col update */
ukj2 = dense[lsub[krep_ind - 2]];
luptr2 = luptr1 - nsupr;
zz_mult(&comp_temp, &ukj2, &lusup[luptr2-1]);
z_sub(&ukj1, &ukj1, &comp_temp);
zz_mult(&comp_temp, &ukj1, &lusup[luptr1]);
zz_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&ukj, &ukj, &comp_temp);
dense[lsub[krep_ind]] = ukj;
dense[lsub[krep_ind-1]] = ukj1;
for (i = lptr + nsupc; i < xlsub[fsupc+1]; ++i) {
irow = lsub[i];
luptr++;
luptr1++;
luptr2++;
zz_mult(&comp_temp, &ukj, &lusup[luptr]);
zz_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
zz_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
z_add(&comp_temp, &comp_temp, &comp_temp1);
z_sub(&dense[irow], &dense[irow], &comp_temp);
}
}
} else {
/*
* Case: sup-col update
* Perform a triangular solve and block update,
* then scatter the result of sup-col update to dense
*/
no_zeros = kfnz - fst_col;
/* Copy U[*,j] segment from dense[*] to tempv[*] */
isub = lptr + no_zeros;
for (i = 0; i < segsze; i++) {
irow = lsub[isub];
tempv[i] = dense[irow];
++isub;
}
/* Dense triangular solve -- start effective triangle */
luptr += nsupr * no_zeros + no_zeros;
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV( ftcs1, ftcs2, ftcs3, &segsze, &lusup[luptr],
&nsupr, tempv, &incx );
#else
ztrsv_( "L", "N", "U", &segsze, &lusup[luptr],
&nsupr, tempv, &incx );
#endif
luptr += segsze; /* Dense matrix-vector */
tempv1 = &tempv[segsze];
alpha = one;
beta = zero;
#ifdef _CRAY
CGEMV( ftcs2, &nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, tempv, &incx, &beta, tempv1, &incy );
#else
zgemv_( "N", &nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, tempv, &incx, &beta, tempv1, &incy );
#endif
#else
zlsolve ( nsupr, segsze, &lusup[luptr], tempv );
luptr += segsze; /* Dense matrix-vector */
tempv1 = &tempv[segsze];
zmatvec (nsupr, nrow , segsze, &lusup[luptr], tempv, tempv1);
#endif
/* Scatter tempv[] into SPA dense[] as a temporary storage */
isub = lptr + no_zeros;
for (i = 0; i < segsze; i++) {
irow = lsub[isub];
dense[irow] = tempv[i];
tempv[i] = zero;
++isub;
}
/* Scatter tempv1[] into SPA dense[] */
for (i = 0; i < nrow; i++) {
irow = lsub[isub];
z_sub(&dense[irow], &dense[irow], &tempv1[i]);
tempv1[i] = zero;
++isub;
}
}
} /* if jsupno ... */
} /* for each segment... */
/*
* Process the supernodal portion of L\U[*,j]
*/
nextlu = xlusup[jcol];
fsupc = xsup[jsupno];
/* Copy the SPA dense into L\U[*,j] */
new_next = nextlu + xlsub[fsupc+1] - xlsub[fsupc];
while ( new_next > nzlumax ) {
if (mem_error = zLUMemXpand(jcol, nextlu, LUSUP, &nzlumax, Glu))
return (mem_error);
lusup = Glu->lusup;
lsub = Glu->lsub;
}
for (isub = xlsub[fsupc]; isub < xlsub[fsupc+1]; isub++) {
irow = lsub[isub];
lusup[nextlu] = dense[irow];
dense[irow] = zero;
++nextlu;
}
xlusup[jcolp1] = nextlu; /* Close L\U[*,jcol] */
/* For more updates within the panel (also within the current supernode),
* should start from the first column of the panel, or the first column
* of the supernode, whichever is bigger. There are 2 cases:
* 1) fsupc < fpanelc, then fst_col := fpanelc
* 2) fsupc >= fpanelc, then fst_col := fsupc
*/
fst_col = SUPERLU_MAX ( fsupc, fpanelc );
if ( fst_col < jcol ) {
/* Distance between the current supernode and the current panel.
d_fsupc=0 if fsupc >= fpanelc. */
d_fsupc = fst_col - fsupc;
lptr = xlsub[fsupc] + d_fsupc;
luptr = xlusup[fst_col] + d_fsupc;
nsupr = xlsub[fsupc+1] - xlsub[fsupc]; /* Leading dimension */
nsupc = jcol - fst_col; /* Excluding jcol */
nrow = nsupr - d_fsupc - nsupc;
/* Points to the beginning of jcol in snode L\U(jsupno) */
ufirst = xlusup[jcol] + d_fsupc;
ops[TRSV] += 4 * nsupc * (nsupc - 1);
ops[GEMV] += 8 * nrow * nsupc;
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV( ftcs1, ftcs2, ftcs3, &nsupc, &lusup[luptr],
&nsupr, &lusup[ufirst], &incx );
#else
ztrsv_( "L", "N", "U", &nsupc, &lusup[luptr],
&nsupr, &lusup[ufirst], &incx );
#endif
alpha = none; beta = one; /* y := beta*y + alpha*A*x */
#ifdef _CRAY
CGEMV( ftcs2, &nrow, &nsupc, &alpha, &lusup[luptr+nsupc], &nsupr,
&lusup[ufirst], &incx, &beta, &lusup[ufirst+nsupc], &incy );
#else
zgemv_( "N", &nrow, &nsupc, &alpha, &lusup[luptr+nsupc], &nsupr,
&lusup[ufirst], &incx, &beta, &lusup[ufirst+nsupc], &incy );
#endif
#else
zlsolve ( nsupr, nsupc, &lusup[luptr], &lusup[ufirst] );
zmatvec ( nsupr, nrow, nsupc, &lusup[luptr+nsupc],
&lusup[ufirst], tempv );
/* Copy updates from tempv[*] into lusup[*] */
isub = ufirst + nsupc;
for (i = 0; i < nrow; i++) {
z_sub(&lusup[isub], &lusup[isub], &tempv[i]);
tempv[i] = zero;
++isub;
}
#endif
} /* if fst_col < jcol ... */
return 0;
}
int
ilu_zcopy_to_ucol(
int jcol, /* in */
int nseg, /* in */
int *segrep, /* in */
int *repfnz, /* in */
int *perm_r, /* in */
doublecomplex *dense, /* modified - reset to zero on return */
int drop_rule,/* in */
milu_t milu, /* in */
double drop_tol, /* in */
int quota, /* maximum nonzero entries allowed */
doublecomplex *sum, /* out - the sum of dropped entries */
int *nnzUj, /* in - out */
GlobalLU_t *Glu, /* modified */
double *work /* working space with minimum size n,
* used by the second dropping rule */
)
{
/*
* Gather from SPA dense[*] to global ucol[*].
*/
int ksub, krep, ksupno;
int i, k, kfnz, segsze;
int fsupc, isub, irow;
int jsupno, nextu;
int new_next, mem_error;
int *xsup, *supno;
int *lsub, *xlsub;
doublecomplex *ucol;
int *usub, *xusub;
int nzumax;
int m; /* number of entries in the nonzero U-segments */
register double d_max = 0.0, d_min = 1.0 / dmach("Safe minimum");
register double tmp;
doublecomplex zero = {0.0, 0.0};
int i_1 = 1;
xsup = Glu->xsup;
supno = Glu->supno;
lsub = Glu->lsub;
xlsub = Glu->xlsub;
ucol = (doublecomplex *) Glu->ucol;
usub = Glu->usub;
xusub = Glu->xusub;
nzumax = Glu->nzumax;
*sum = zero;
if (drop_rule == NODROP) {
drop_tol = -1.0, quota = Glu->n;
}
jsupno = supno[jcol];
nextu = xusub[jcol];
k = nseg - 1;
for (ksub = 0; ksub < nseg; ksub++) {
krep = segrep[k--];
ksupno = supno[krep];
if ( ksupno != jsupno ) { /* Should go into ucol[] */
kfnz = repfnz[krep];
if ( kfnz != EMPTY ) { /* Nonzero U-segment */
fsupc = xsup[ksupno];
isub = xlsub[fsupc] + kfnz - fsupc;
segsze = krep - kfnz + 1;
new_next = nextu + segsze;
while ( new_next > nzumax ) {
if ((mem_error = zLUMemXpand(jcol, nextu, UCOL, &nzumax,
Glu)) != 0)
return (mem_error);
ucol = Glu->ucol;
if ((mem_error = zLUMemXpand(jcol, nextu, USUB, &nzumax,
Glu)) != 0)
return (mem_error);
usub = Glu->usub;
lsub = Glu->lsub;
}
for (i = 0; i < segsze; i++) {
irow = lsub[isub++];
tmp = z_abs1(&dense[irow]);
/* first dropping rule */
if (quota > 0 && tmp >= drop_tol) {
if (tmp > d_max) d_max = tmp;
if (tmp < d_min) d_min = tmp;
usub[nextu] = perm_r[irow];
ucol[nextu] = dense[irow];
nextu++;
} else {
switch (milu) {
case SMILU_1:
case SMILU_2:
z_add(sum, sum, &dense[irow]);
break;
case SMILU_3:
/* *sum += fabs(dense[irow]);*/
sum->r += tmp;
break;
case SILU:
default:
break;
}
#ifdef DEBUG
num_drop_U++;
#endif
}
dense[irow] = zero;
}
}
}
} /* for each segment... */
xusub[jcol + 1] = nextu; /* Close U[*,jcol] */
m = xusub[jcol + 1] - xusub[jcol];
/* second dropping rule */
if (drop_rule & DROP_SECONDARY && m > quota) {
register double tol = d_max;
register int m0 = xusub[jcol] + m - 1;
if (quota > 0) {
if (drop_rule & DROP_INTERP) {
d_max = 1.0 / d_max; d_min = 1.0 / d_min;
tol = 1.0 / (d_max + (d_min - d_max) * quota / m);
} else {
i_1 = xusub[jcol];
for (i = 0; i < m; ++i, ++i_1) work[i] = z_abs1(&ucol[i_1]);
tol = dqselect(m, work, quota);
#if 0
A = &ucol[xusub[jcol]];
for (i = 0; i < m; i++) work[i] = i;
qsort(work, m, sizeof(int), _compare_);
tol = fabs(usub[xusub[jcol] + work[quota]]);
#endif
}
}
for (i = xusub[jcol]; i <= m0; ) {
if (z_abs1(&ucol[i]) <= tol) {
switch (milu) {
case SMILU_1:
case SMILU_2:
z_add(sum, sum, &ucol[i]);
break;
case SMILU_3:
sum->r += tmp;
break;
case SILU:
default:
break;
}
ucol[i] = ucol[m0];
usub[i] = usub[m0];
m0--;
m--;
#ifdef DEBUG
num_drop_U++;
#endif
xusub[jcol + 1]--;
continue;
}
i++;
}
}
if (milu == SMILU_2) {
sum->r = z_abs1(sum); sum->i = 0.0;
}
if (milu == SMILU_3) sum->i = 0.0;
*nnzUj += m;
return 0;
}
void zlsum_fmod
/************************************************************************/
(
doublecomplex *lsum, /* Sum of local modifications. */
doublecomplex *x, /* X array (local) */
doublecomplex *xk, /* X[k]. */
doublecomplex *rtemp, /* Result of full matrix-vector multiply. */
int nrhs, /* Number of right-hand sides. */
int knsupc, /* Size of supernode k. */
int_t k, /* The k-th component of X. */
int_t *fmod, /* Modification count for L-solve. */
int_t nlb, /* Number of L blocks. */
int_t lptr, /* Starting position in lsub[*]. */
int_t luptr, /* Starting position in lusup[*]. */
int_t *xsup,
gridinfo_t *grid,
LocalLU_t *Llu,
MPI_Request send_req[],
SuperLUStat_t *stat
)
{
doublecomplex alpha = {1.0, 0.0}, beta = {0.0, 0.0};
doublecomplex *lusup, *lusup1;
doublecomplex *dest;
int iam, iknsupc, myrow, nbrow, nsupr, nsupr1, p, pi;
int_t i, ii, ik, il, ikcol, irow, j, lb, lk, rel;
int_t *lsub, *lsub1, nlb1, lptr1, luptr1;
int_t *ilsum = Llu->ilsum; /* Starting position of each supernode in lsum. */
int_t *frecv = Llu->frecv;
int_t **fsendx_plist = Llu->fsendx_plist;
MPI_Status status;
int test_flag;
iam = grid->iam;
myrow = MYROW( iam, grid );
lk = LBj( k, grid ); /* Local block number, column-wise. */
lsub = Llu->Lrowind_bc_ptr[lk];
lusup = Llu->Lnzval_bc_ptr[lk];
nsupr = lsub[1];
for (lb = 0; lb < nlb; ++lb) {
ik = lsub[lptr]; /* Global block number, row-wise. */
nbrow = lsub[lptr+1];
#ifdef _CRAY
CGEMM( ftcs2, ftcs2, &nbrow, &nrhs, &knsupc,
&alpha, &lusup[luptr], &nsupr, xk,
&knsupc, &beta, rtemp, &nbrow );
#else
zgemm_( "N", "N", &nbrow, &nrhs, &knsupc,
&alpha, &lusup[luptr], &nsupr, xk,
&knsupc, &beta, rtemp, &nbrow );
#endif
stat->ops[SOLVE] += 8 * nbrow * nrhs * knsupc + 2 * nbrow * nrhs;
lk = LBi( ik, grid ); /* Local block number, row-wise. */
iknsupc = SuperSize( ik );
il = LSUM_BLK( lk );
dest = &lsum[il];
lptr += LB_DESCRIPTOR;
rel = xsup[ik]; /* Global row index of block ik. */
for (i = 0; i < nbrow; ++i) {
irow = lsub[lptr++] - rel; /* Relative row. */
RHS_ITERATE(j)
z_sub(&dest[irow + j*iknsupc],
&dest[irow + j*iknsupc],
&rtemp[i + j*nbrow]);
}
luptr += nbrow;
if ( (--fmod[lk])==0 ) { /* Local accumulation done. */
ikcol = PCOL( ik, grid );
p = PNUM( myrow, ikcol, grid );
if ( iam != p ) {
#ifdef ISEND_IRECV
#if 1
MPI_Test( &send_req[myrow], &test_flag, &status );
#else
if ( send_req[myrow] != MPI_REQUEST_NULL )
MPI_Wait( &send_req[myrow], &status );
#endif
MPI_Isend( &lsum[il - LSUM_H], iknsupc * nrhs + LSUM_H,
SuperLU_MPI_DOUBLE_COMPLEX, p, LSUM, grid->comm, &send_req[myrow] );
#else
#ifdef BSEND
MPI_Bsend( &lsum[il - LSUM_H], iknsupc * nrhs + LSUM_H,
SuperLU_MPI_DOUBLE_COMPLEX, p, LSUM, grid->comm );
#else
MPI_Send( &lsum[il - LSUM_H], iknsupc * nrhs + LSUM_H,
SuperLU_MPI_DOUBLE_COMPLEX, p, LSUM, grid->comm );
#endif
#endif
#if ( DEBUGlevel>=2 )
printf("(%2d) Sent LSUM[%2.0f], size %2d, to P %2d\n",
iam, lsum[il-LSUM_H], iknsupc*nrhs+LSUM_H, p);
#endif
} else { /* Diagonal process: X[i] += lsum[i]. */
ii = X_BLK( lk );
RHS_ITERATE(j)
for (i = 0; i < iknsupc; ++i)
z_add(&x[i + ii + j*iknsupc],
&x[i + ii + j*iknsupc],
&lsum[i + il + j*iknsupc]);
if ( frecv[lk]==0 ) { /* Becomes a leaf node. */
fmod[lk] = -1; /* Do not solve X[k] in the future. */
lk = LBj( ik, grid );/* Local block number, column-wise. */
lsub1 = Llu->Lrowind_bc_ptr[lk];
lusup1 = Llu->Lnzval_bc_ptr[lk];
nsupr1 = lsub1[1];
#ifdef _CRAY
CTRSM(ftcs1, ftcs1, ftcs2, ftcs3, &iknsupc, &nrhs, &alpha,
lusup1, &nsupr1, &x[ii], &iknsupc);
#else
ztrsm_("L", "L", "N", "U", &iknsupc, &nrhs, &alpha,
lusup1, &nsupr1, &x[ii], &iknsupc);
#endif
stat->ops[SOLVE] += 4 * iknsupc * (iknsupc - 1) * nrhs
+ 10 * knsupc * nrhs; /* complex division */
#if ( DEBUGlevel>=2 )
printf("(%2d) Solve X[%2d]\n", iam, ik);
#endif
/*
* Send Xk to process column Pc[k].
*/
for (p = 0; p < grid->nprow; ++p)
if ( fsendx_plist[lk][p] != EMPTY ) {
pi = PNUM( p, ikcol, grid );
#ifdef ISEND_IRECV
#if 1
MPI_Test( &send_req[p], &test_flag, &status );
#else
if ( send_req[p] != MPI_REQUEST_NULL )
MPI_Wait( &send_req[p], &status );
#endif
MPI_Isend( &x[ii - XK_H], iknsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm,
&send_req[p] );
#else
#ifdef BSEND
MPI_Bsend( &x[ii - XK_H], iknsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm );
#else
MPI_Send( &x[ii - XK_H], iknsupc * nrhs + XK_H,
SuperLU_MPI_DOUBLE_COMPLEX, pi, Xk, grid->comm );
#endif
#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.
*/
nlb1 = lsub1[0] - 1;
lptr1 = BC_HEADER + LB_DESCRIPTOR + iknsupc;
luptr1 = iknsupc; /* Skip diagonal block L(I,I). */
zlsum_fmod(lsum, x, &x[ii], rtemp, nrhs, iknsupc, ik,
fmod, nlb1, lptr1, luptr1, xsup,
grid, Llu, send_req, stat);
#ifdef ISEND_IRECV
/* Wait for previous Isends to complete. */
for (p = 0; p < grid->nprow; ++p) {
if ( fsendx_plist[lk][p] != EMPTY )
/*MPI_Wait( &send_req[p], &status );*/
MPI_Test( &send_req[p], &test_flag, &status );
}
#endif
} /* if frecv[lk] == 0 */
} /* if iam == p */
} /* if fmod[lk] == 0 */
} /* for lb ... */
