void
dgstrs(trans_t trans, SuperMatrix *L, SuperMatrix *U,
int *perm_r, int *perm_c, SuperMatrix *B, Gstat_t *Gstat, int *info)
{
/*
* -- SuperLU MT routine (version 1.0) --
* Univ. of California Berkeley, Xerox Palo Alto Research Center,
* and Lawrence Berkeley National Lab.
* August 15, 1997
*
* Purpose
* =======
*
* dgstrs() solves a system of linear equations A*X=B or A'*X=B
* with A sparse and B dense, using the LU factorization computed by
* pdgstrf().
*
* Arguments
* =========
*
* trans (input) Specifies the form of the system of equations:
* = NOTRANS: A * X = B (No transpose)
* = TRANS: A'* X = B (Transpose)
*
* L (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U as computed by
* pdgstrf(). Use compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SCP, Dtype = _D, Mtype = TRLU.
*
* U (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U as computed by
* pdgstrf(). Use column-wise storage scheme, i.e., U has types:
* Stype = NCP, Dtype = _D, Mtype = TRU.
*
* perm_r (input) int*
* Row permutation vector of size L->nrow, which defines the
* permutation matrix Pr; perm_r[i] = j means row i of A is in
* position j in Pr*A.
*
* perm_c (int*) dimension A->ncol
* Column permutation vector, which defines the
* permutation matrix Pc; perm_c[i] = j means column i of A is
* in position j in A*Pc.
*
* B (input/output) SuperMatrix*
* B has types: Stype = DN, Dtype = _D, Mtype = GE.
* On entry, the right hand side matrix.
* On exit, the solution matrix if info = 0;
*
* Gstat (output) Gstat_t*
* Record all the statistics about the triangular solves;
* See Gstat_t structure defined in util.h.
*
* info (output) Diagnostics
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
*
*/
#if ( MACH==CRAY_PVP )
_fcd ftcs1, ftcs2, ftcs3, ftcs4;
#endif
#ifdef USE_VENDOR_BLAS
int incx = 1, incy = 1;
double alpha = 1.0, beta = 1.0;
#endif
register int j, k, jcol, iptr, luptr, ksupno, istart, irow, bptr;
register int fsupc, nsuper;
int i, n, nsupc, nsupr, nrow, nrhs, ldb;
int *supno;
DNformat *Bstore;
SCPformat *Lstore;
NCPformat *Ustore;
double *Lval, *Uval, *Bmat;
double *work, *work_col, *rhs_work, *soln;
flops_t solve_ops;
void dprint_soln();
/* Test input parameters ... */
*info = 0;
Bstore = B->Store;
ldb = Bstore->lda;
nrhs = B->ncol;
if ( trans != NOTRANS && trans != TRANS ) *info = -1;
else if ( L->nrow != L->ncol || L->nrow < 0 ) *info = -3;
else if ( U->nrow != U->ncol || U->nrow < 0 ) *info = -4;
else if ( ldb < MAX(0, L->nrow) ) *info = -6;
if ( *info ) {
i = -(*info);
xerbla_("dgstrs", &i);
return;
}
n = L->nrow;
work = doubleCalloc(n * nrhs);
if ( !work ) ABORT("Malloc fails for local work[].");
soln = doubleMalloc(n);
if ( !soln ) ABORT("Malloc fails for local soln[].");
Bmat = Bstore->nzval;
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
supno = Lstore->col_to_sup;
nsuper = Lstore->nsuper;
solve_ops = 0;
if ( trans == NOTRANS ) {
/* Permute right hand sides to form Pr*B */
for (i = 0, bptr = 0; i < nrhs; i++, bptr += ldb) {
rhs_work = &Bmat[bptr];
for (k = 0; k < n; k++) soln[perm_r[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
/* Forward solve PLy=Pb. */
/*>> for (k = 0; k < n; k += nsupc) {
ksupno = supno[k];
*/
for (ksupno = 0; ksupno <= nsuper; ++ksupno) {
fsupc = L_FST_SUPC(ksupno);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_END(fsupc) - istart;
nsupc = L_LAST_SUPC(ksupno) - fsupc;
nrow = nsupr - nsupc;
solve_ops += nsupc * (nsupc - 1) * nrhs;
solve_ops += 2 * nrow * nsupc * nrhs;
if ( nsupc == 1 ) {
for (j = 0, bptr = 0; j < nrhs; j++, bptr += ldb) {
rhs_work = &Bmat[bptr];
luptr = L_NZ_START(fsupc);
for (iptr=istart+1; iptr < L_SUB_END(fsupc); iptr++){
irow = L_SUB(iptr);
++luptr;
rhs_work[irow] -= rhs_work[fsupc] * Lval[luptr];
}
}
} else {
luptr = L_NZ_START(fsupc);
#ifdef USE_VENDOR_BLAS
#if ( MACH==CRAY_PVP )
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("N", strlen("N"));
ftcs3 = _cptofcd("U", strlen("U"));
STRSM(ftcs1, ftcs1, ftcs2, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
SGEMM(ftcs2, ftcs2, &nrow, &nrhs, &nsupc, &alpha,
&Lval[luptr+nsupc], &nsupr, &Bmat[fsupc], &ldb,
&beta, &work[0], &n );
#else
dtrsm_("L", "L", "N", "U", &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
dgemm_( "N", "N", &nrow, &nrhs, &nsupc, &alpha,
&Lval[luptr+nsupc], &nsupr, &Bmat[fsupc], &ldb,
&beta, &work[0], &n );
#endif
for (j = 0, bptr = 0; j < nrhs; j++, bptr += ldb) {
rhs_work = &Bmat[bptr];
work_col = &work[j*n];
iptr = istart + nsupc;
for (i = 0; i < nrow; i++) {
irow = L_SUB(iptr);
rhs_work[irow] -= work_col[i]; /* Scatter */
work_col[i] = 0.0;
iptr++;
}
}
#else
for (j = 0, bptr = 0; j < nrhs; j++, bptr += ldb) {
rhs_work = &Bmat[bptr];
dlsolve (nsupr, nsupc, &Lval[luptr], &rhs_work[fsupc]);
dmatvec (nsupr, nrow, nsupc, &Lval[luptr+nsupc],
&rhs_work[fsupc], &work[0] );
iptr = istart + nsupc;
for (i = 0; i < nrow; i++) {
irow = L_SUB(iptr);
rhs_work[irow] -= work[i];
work[i] = 0.0;
iptr++;
}
}
#endif
} /* if-else: nsupc == 1 ... */
} /* for L-solve */
#if ( DEBUGlevel>=2 )
printf("After L-solve: y=\n");
dprint_soln(n, nrhs, Bmat);
#endif
/*
* Back solve Ux=y.
*/
/*>> for (k = n-1; k >= 0; k -= nsupc) {
ksupno = supno[k];
*/
for (ksupno = nsuper; ksupno >= 0; --ksupno) {
fsupc = L_FST_SUPC(ksupno);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_END(fsupc) - istart;
nsupc = L_LAST_SUPC(ksupno) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += nsupc * (nsupc + 1) * nrhs;
/* dense triangular matrix */
if ( nsupc == 1 ) {
rhs_work = &Bmat[0];
for (j = 0; j < nrhs; j++) {
rhs_work[fsupc] /= Lval[luptr];
rhs_work += ldb;
}
} else {
#ifdef USE_VENDOR_BLAS
#if ( MACH==CRAY_PVP )
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("U", strlen("U"));
ftcs3 = _cptofcd("N", strlen("N"));
STRSM(ftcs1, ftcs2, ftcs3, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#else
dtrsm_("L", "U", "N", "N", &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#endif
#else
for (j = 0, bptr = fsupc; j < nrhs; j++, bptr += ldb) {
dusolve (nsupr, nsupc, &Lval[luptr], &Bmat[bptr]);
}
#endif
}
/* matrix-vector update */
for (j = 0, bptr = 0; j < nrhs; ++j, bptr += ldb) {
rhs_work = &Bmat[bptr];
for (jcol = fsupc; jcol < fsupc + nsupc; jcol++) {
solve_ops += 2*(U_NZ_END(jcol) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_END(jcol); i++ ){
irow = U_SUB(i);
rhs_work[irow] -= rhs_work[jcol] * Uval[i];
}
}
}
} /* for U-solve */
#if ( DEBUGlevel>=2 )
printf("After U-solve: x=\n");
dprint_soln(n, nrhs, Bmat);
#endif
/* Compute the final solution X <= Pc*X. */
for (i = 0, bptr = 0; i < nrhs; i++, bptr += ldb) {
rhs_work = &Bmat[bptr];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_c[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
} else { /* Solve A'*X=B */
/* Permute right hand sides to form Pc'*B. */
for (i = 0, bptr = 0; i < nrhs; i++, bptr += ldb) {
rhs_work = &Bmat[bptr];
for (k = 0; k < n; k++) soln[perm_c[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
for (k = 0; k < nrhs; ++k) {
/* Multiply by inv(U'). */
sp_dtrsv("U", "T", "N", L, U, &Bmat[k*ldb], info);
/* Multiply by inv(L'). */
sp_dtrsv("L", "T", "U", L, U, &Bmat[k*ldb], info);
}
/* Compute the final solution X <= Pr'*X (=inv(Pr)*X) */
for (i = 0, bptr = 0; i < nrhs; i++, bptr += ldb) {
rhs_work = &Bmat[bptr];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_r[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
} /* if-else trans */
Gstat->ops[TRISOLVE] = solve_ops;
SUPERLU_FREE(work);
SUPERLU_FREE(soln);
}
void
dgscon(char *norm, SuperMatrix *L, SuperMatrix *U,
double anorm, double *rcond, int *info)
{
/*
Purpose
=======
DGSCON estimates the reciprocal of the condition number of a general
real matrix A, in either the 1-norm or the infinity-norm, using
the LU factorization computed by DGETRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
See supermatrix.h for the definition of 'SuperMatrix' structure.
Arguments
=========
NORM (input) char*
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
L (input) SuperMatrix*
The factor L from the factorization Pr*A*Pc=L*U as computed by
dgstrf(). Use compressed row subscripts storage for supernodes,
i.e., L has types: Stype = SC, Dtype = D_, Mtype = TRLU.
U (input) SuperMatrix*
The factor U from the factorization Pr*A*Pc=L*U as computed by
dgstrf(). Use column-wise storage scheme, i.e., U has types:
Stype = NC, Dtype = D_, Mtype = TRU.
ANORM (input) double
If NORM = '1' or 'O', the 1-norm of the original matrix A.
If NORM = 'I', the infinity-norm of the original matrix A.
RCOND (output) double*
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
INFO (output) int*
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
*/
/* Local variables */
int kase, kase1, onenrm, i;
double ainvnm;
double *work;
int *iwork;
extern int drscl_(int *, double *, double *, int *);
extern int dlacon_(int *, double *, double *, int *, double *, int *);
/* Test the input parameters. */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) *info = -1;
else if (L->nrow < 0 || L->nrow != L->ncol ||
L->Stype != SC || L->Dtype != D_ || L->Mtype != TRLU)
*info = -2;
else if (U->nrow < 0 || U->nrow != U->ncol ||
U->Stype != NC || U->Dtype != D_ || U->Mtype != TRU)
*info = -3;
if (*info != 0) {
i = -(*info);
xerbla_("dgscon", &i);
return;
}
/* Quick return if possible */
*rcond = 0.;
if ( L->nrow == 0 || U->nrow == 0) {
*rcond = 1.;
return;
}
work = doubleCalloc( 3*L->nrow );
iwork = intMalloc( L->nrow );
if ( !work || !iwork )
ABORT("Malloc fails for work arrays in dgscon.");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
if ( onenrm ) kase1 = 1;
else kase1 = 2;
kase = 0;
do {
dlacon_(&L->nrow, &work[L->nrow], &work[0], &iwork[0], &ainvnm, &kase);
if (kase == 0) break;
if (kase == kase1) {
/* Multiply by inv(L). */
sp_dtrsv("Lower", "No transpose", "Unit", L, U, &work[0], info);
/* Multiply by inv(U). */
sp_dtrsv("Upper", "No transpose", "Non-unit", L, U, &work[0],info);
} else {
/* Multiply by inv(U'). */
sp_dtrsv("Upper", "Transpose", "Non-unit", L, U, &work[0], info);
/* Multiply by inv(L'). */
sp_dtrsv("Lower", "Transpose", "Unit", L, U, &work[0], info);
}
} while ( kase != 0 );
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) *rcond = (1. / ainvnm) / anorm;
SUPERLU_FREE (work);
SUPERLU_FREE (iwork);
return;
} /* dgscon */
void
dgscon(char *norm, SuperMatrix *L, SuperMatrix *U,
double anorm, double *rcond, SuperLUStat_t *stat, int *info)
{
/* Local variables */
int kase, kase1, onenrm, i;
double ainvnm;
double *work;
int *iwork;
int isave[3];
extern int drscl_(int *, double *, double *, int *);
extern int dlacon2_(int *, double *, double *, int *, double *, int *, int []);
/* Test the input parameters. */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) *info = -1;
else if (L->nrow < 0 || L->nrow != L->ncol ||
L->Stype != SLU_SC || L->Dtype != SLU_D || L->Mtype != SLU_TRLU)
*info = -2;
else if (U->nrow < 0 || U->nrow != U->ncol ||
U->Stype != SLU_NC || U->Dtype != SLU_D || U->Mtype != SLU_TRU)
*info = -3;
if (*info != 0) {
i = -(*info);
input_error("dgscon", &i);
return;
}
/* Quick return if possible */
*rcond = 0.;
if ( L->nrow == 0 || U->nrow == 0) {
*rcond = 1.;
return;
}
work = doubleCalloc( 3*L->nrow );
iwork = intMalloc( L->nrow );
if ( !work || !iwork )
ABORT("Malloc fails for work arrays in dgscon.");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
if ( onenrm ) kase1 = 1;
else kase1 = 2;
kase = 0;
do {
dlacon2_(&L->nrow, &work[L->nrow], &work[0], &iwork[0], &ainvnm, &kase, isave);
if (kase == 0) break;
if (kase == kase1) {
/* Multiply by inv(L). */
sp_dtrsv("L", "No trans", "Unit", L, U, &work[0], stat, info);
/* Multiply by inv(U). */
sp_dtrsv("U", "No trans", "Non-unit", L, U, &work[0], stat, info);
} else {
/* Multiply by inv(U'). */
sp_dtrsv("U", "Transpose", "Non-unit", L, U, &work[0], stat, info);
/* Multiply by inv(L'). */
sp_dtrsv("L", "Transpose", "Unit", L, U, &work[0], stat, info);
}
} while ( kase != 0 );
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) *rcond = (1. / ainvnm) / anorm;
SUPERLU_FREE (work);
SUPERLU_FREE (iwork);
return;
} /* dgscon */
/*! \brief
*
* <pre>
* Purpose
* =======
*
* dgstrsU only performs the U-solve using the LU factorization computed
* by DGSTRF.
*
* See supermatrix.h for the definition of 'SuperMatrix' structure.
*
* Arguments
* =========
*
* trans (input) trans_t
* Specifies the form of the system of equations:
* = NOTRANS: A * X = B (No transpose)
* = TRANS: A'* X = B (Transpose)
* = CONJ: A**H * X = B (Conjugate transpose)
*
* L (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U as computed by
* dgstrf(). Use compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU.
*
* U (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U as computed by
* dgstrf(). Use column-wise storage scheme, i.e., U has types:
* Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU.
*
* perm_c (input) int*, dimension (L->ncol)
* Column permutation vector, which defines the
* permutation matrix Pc; perm_c[i] = j means column i of A is
* in position j in A*Pc.
*
* perm_r (input) int*, dimension (L->nrow)
* Row permutation vector, which defines the permutation matrix Pr;
* perm_r[i] = j means row i of A is in position j in Pr*A.
*
* B (input/output) SuperMatrix*
* B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE.
* On entry, the right hand side matrix.
* On exit, the solution matrix if info = 0;
*
* stat (output) SuperLUStat_t*
* Record the statistics on runtime and floating-point operation count.
* See util.h for the definition of 'SuperLUStat_t'.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
* </pre>
*/
void
dgstrsU(trans_t trans, SuperMatrix *L, SuperMatrix *U,
int *perm_c, int *perm_r, SuperMatrix *B,
SuperLUStat_t *stat, int *info)
{
#ifdef _CRAY
_fcd ftcs1, ftcs2, ftcs3, ftcs4;
#endif
#ifdef USE_VENDOR_BLAS
double alpha = 1.0, beta = 1.0;
double *work_col;
#endif
DNformat *Bstore;
double *Bmat;
SCformat *Lstore;
NCformat *Ustore;
double *Lval, *Uval;
int fsupc, nsupr, nsupc, luptr, istart, irow;
int i, j, k, jcol, n, ldb, nrhs;
double *rhs_work, *soln;
flops_t solve_ops;
void dprint_soln();
/* Test input parameters ... */
*info = 0;
Bstore = B->Store;
ldb = Bstore->lda;
nrhs = B->ncol;
if ( trans != NOTRANS && trans != TRANS && trans != CONJ ) *info = -1;
else if ( L->nrow != L->ncol || L->nrow < 0 ||
L->Stype != SLU_SC || L->Dtype != SLU_D || L->Mtype != SLU_TRLU )
*info = -2;
else if ( U->nrow != U->ncol || U->nrow < 0 ||
U->Stype != SLU_NC || U->Dtype != SLU_D || U->Mtype != SLU_TRU )
*info = -3;
else if ( ldb < SUPERLU_MAX(0, L->nrow) ||
B->Stype != SLU_DN || B->Dtype != SLU_D || B->Mtype != SLU_GE )
*info = -6;
if ( *info ) {
i = -(*info);
xerbla_("dgstrs", &i);
return;
}
n = L->nrow;
soln = doubleMalloc(n);
if ( !soln ) ABORT("Malloc fails for local soln[].");
Bmat = Bstore->nzval;
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
solve_ops = 0;
if ( trans == NOTRANS ) {
/*
* Back solve Ux=y.
*/
for (k = Lstore->nsuper; k >= 0; k--) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += nsupc * (nsupc + 1) * nrhs;
if ( nsupc == 1 ) {
rhs_work = &Bmat[0];
for (j = 0; j < nrhs; j++) {
rhs_work[fsupc] /= Lval[luptr];
rhs_work += ldb;
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("U", strlen("U"));
ftcs3 = _cptofcd("N", strlen("N"));
STRSM( ftcs1, ftcs2, ftcs3, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#else
dtrsm_("L", "U", "N", "N", &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#endif
#else
for (j = 0; j < nrhs; j++)
dusolve ( nsupr, nsupc, &Lval[luptr], &Bmat[fsupc+j*ldb] );
#endif
}
for (j = 0; j < nrhs; ++j) {
rhs_work = &Bmat[j*ldb];
for (jcol = fsupc; jcol < fsupc + nsupc; jcol++) {
solve_ops += 2*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++ ){
irow = U_SUB(i);
rhs_work[irow] -= rhs_work[jcol] * Uval[i];
}
}
}
} /* for U-solve */
#ifdef DEBUG
printf("After U-solve: x=\n");
dprint_soln(n, nrhs, Bmat);
#endif
/* Compute the final solution X := Pc*X. */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_c[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
stat->ops[SOLVE] = solve_ops;
} else { /* Solve U'x = b */
/* Permute right hand sides to form Pc'*B. */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[perm_c[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
for (k = 0; k < nrhs; ++k) {
/* Multiply by inv(U'). */
sp_dtrsv("U", "T", "N", L, U, &Bmat[k*ldb], stat, info);
}
}
SUPERLU_FREE(soln);
}
void
dgstrs (trans_t trans, SuperMatrix *L, SuperMatrix *U,
int *perm_c, int *perm_r, SuperMatrix *B,
SuperLUStat_t *stat, int *info)
{
/*
* Purpose
* =======
*
* DGSTRS solves a system of linear equations A*X=B or A'*X=B
* with A sparse and B dense, using the LU factorization computed by
* DGSTRF.
*
* See supermatrix.h for the definition of 'SuperMatrix' structure.
*
* Arguments
* =========
*
* trans (input) trans_t
* Specifies the form of the system of equations:
* = NOTRANS: A * X = B (No transpose)
* = TRANS: A'* X = B (Transpose)
* = CONJ: A**H * X = B (Conjugate transpose)
*
* L (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U as computed by
* dgstrf(). Use compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SLU_SC, Dtype = SLU_D, Mtype = SLU_TRLU.
*
* U (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U as computed by
* dgstrf(). Use column-wise storage scheme, i.e., U has types:
* Stype = SLU_NC, Dtype = SLU_D, Mtype = SLU_TRU.
*
* perm_c (input) int*, dimension (L->ncol)
* Column permutation vector, which defines the
* permutation matrix Pc; perm_c[i] = j means column i of A is
* in position j in A*Pc.
*
* perm_r (input) int*, dimension (L->nrow)
* Row permutation vector, which defines the permutation matrix Pr;
* perm_r[i] = j means row i of A is in position j in Pr*A.
*
* B (input/output) SuperMatrix*
* B has types: Stype = SLU_DN, Dtype = SLU_D, Mtype = SLU_GE.
* On entry, the right hand side matrix.
* On exit, the solution matrix if info = 0;
*
* stat (output) SuperLUStat_t*
* Record the statistics on runtime and floating-point operation count.
* See util.h for the definition of 'SuperLUStat_t'.
*
* info (output) int*
* = 0: successful exit
* < 0: if info = -i, the i-th argument had an illegal value
*
*/
#ifdef _CRAY
_fcd ftcs1, ftcs2, ftcs3, ftcs4;
#endif
#if 0
int incx = 1, incy = 1;
#endif
#ifdef USE_VENDOR_BLAS
double alpha = 1.0, beta = 1.0;
double *work_col;
#endif
DNformat *Bstore;
double *Bmat;
SCformat *Lstore;
NCformat *Ustore;
double *Lval, *Uval;
int fsupc, nrow, nsupr, nsupc, luptr, istart, irow;
int i, j, k, iptr, jcol, n, ldb, nrhs;
double *work, *rhs_work, *soln;
flops_t solve_ops;
void dprint_soln();
/* Test input parameters ... */
*info = 0;
Bstore = B->Store;
ldb = Bstore->lda;
nrhs = B->ncol;
if ( trans != NOTRANS && trans != TRANS && trans != CONJ ) *info = -1;
else if ( L->nrow != L->ncol || L->nrow < 0 ||
L->Stype != SLU_SC || L->Dtype != SLU_D || L->Mtype != SLU_TRLU )
*info = -2;
else if ( U->nrow != U->ncol || U->nrow < 0 ||
U->Stype != SLU_NC || U->Dtype != SLU_D || U->Mtype != SLU_TRU )
*info = -3;
else if ( ldb < SUPERLU_MAX(0, L->nrow) ||
B->Stype != SLU_DN || B->Dtype != SLU_D || B->Mtype != SLU_GE )
*info = -6;
if ( *info ) {
i = -(*info);
superlu_xerbla("dgstrs", &i);
return;
}
n = L->nrow;
work = doubleCalloc(n * nrhs);
if ( !work ) ABORT("Malloc fails for local work[].");
soln = doubleMalloc(n);
if ( !soln ) ABORT("Malloc fails for local soln[].");
Bmat = Bstore->nzval;
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
solve_ops = 0;
if ( trans == NOTRANS ) {
/* Permute right hand sides to form Pr*B */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[perm_r[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
/* Forward solve PLy=Pb. */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
nrow = nsupr - nsupc;
solve_ops += nsupc * (nsupc - 1) * nrhs;
solve_ops += 2 * nrow * nsupc * nrhs;
if ( nsupc == 1 ) {
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
luptr = L_NZ_START(fsupc);
for (iptr=istart+1; iptr < L_SUB_START(fsupc+1); iptr++){
irow = L_SUB(iptr);
++luptr;
rhs_work[irow] -= rhs_work[fsupc] * Lval[luptr];
}
}
} else {
luptr = L_NZ_START(fsupc);
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("N", strlen("N"));
ftcs3 = _cptofcd("U", strlen("U"));
STRSM( ftcs1, ftcs1, ftcs2, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
SGEMM( ftcs2, ftcs2, &nrow, &nrhs, &nsupc, &alpha,
&Lval[luptr+nsupc], &nsupr, &Bmat[fsupc], &ldb,
&beta, &work[0], &n );
#else
hypre_F90_NAME_BLAS(dtrsm,DTRSM)("L","L","N","U",&nsupc,
&nrhs, &alpha, &Lval[luptr], &nsupr, &Bmat[fsupc],
&ldb);
hypre_F90_NAME_BLAS(dgemm,DGEMM)("N","N",&nrow,&nrhs,&nsupc,
&alpha, &Lval[luptr+nsupc], &nsupr, &Bmat[fsupc], &ldb,
&beta, &work[0], &n );
#endif
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
work_col = &work[j*n];
iptr = istart + nsupc;
for (i = 0; i < nrow; i++) {
irow = L_SUB(iptr);
rhs_work[irow] -= work_col[i]; /* Scatter */
work_col[i] = 0.0;
iptr++;
}
}
#else
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
sludlsolve (nsupr, nsupc, &Lval[luptr], &rhs_work[fsupc]);
sludmatvec (nsupr, nrow, nsupc, &Lval[luptr+nsupc],
&rhs_work[fsupc], &work[0] );
iptr = istart + nsupc;
for (i = 0; i < nrow; i++) {
irow = L_SUB(iptr);
rhs_work[irow] -= work[i];
work[i] = 0.0;
iptr++;
}
}
#endif
} /* else ... */
} /* for L-solve */
#ifdef DEBUG
printf("After L-solve: y=\n");
dprint_soln(n, nrhs, Bmat);
#endif
/*
* Back solve Ux=y.
*/
for (k = Lstore->nsuper; k >= 0; k--) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += nsupc * (nsupc + 1) * nrhs;
if ( nsupc == 1 ) {
rhs_work = &Bmat[0];
for (j = 0; j < nrhs; j++) {
rhs_work[fsupc] /= Lval[luptr];
rhs_work += ldb;
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("U", strlen("U"));
ftcs3 = _cptofcd("N", strlen("N"));
STRSM( ftcs1, ftcs2, ftcs3, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#else
hypre_F90_NAME_BLAS(dtrsm,DTRSM)("L","U","N","N", &nsupc,
&nrhs, &alpha, &Lval[luptr], &nsupr, &Bmat[fsupc],
&ldb);
#endif
#else
for (j = 0; j < nrhs; j++)
sludusolve ( nsupr, nsupc, &Lval[luptr], &Bmat[fsupc+j*ldb] );
#endif
}
for (j = 0; j < nrhs; ++j) {
rhs_work = &Bmat[j*ldb];
for (jcol = fsupc; jcol < fsupc + nsupc; jcol++) {
solve_ops += 2*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++ ){
irow = U_SUB(i);
rhs_work[irow] -= rhs_work[jcol] * Uval[i];
}
}
}
} /* for U-solve */
#ifdef DEBUG
printf("After U-solve: x=\n");
dprint_soln(n, nrhs, Bmat);
#endif
/* Compute the final solution X := Pc*X. */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_c[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
stat->ops[SOLVE] = solve_ops;
} else { /* Solve A'*X=B or CONJ(A)*X=B */
/* Permute right hand sides to form Pc'*B. */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[perm_c[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
stat->ops[SOLVE] = 0;
for (k = 0; k < nrhs; ++k) {
/* Multiply by inv(U'). */
sp_dtrsv("U", "T", "N", L, U, &Bmat[k*ldb], stat, info);
/* Multiply by inv(L'). */
sp_dtrsv("L", "T", "U", L, U, &Bmat[k*ldb], stat, info);
}
/* Compute the final solution X := Pr'*X (=inv(Pr)*X) */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_r[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
}
SUPERLU_FREE(work);
SUPERLU_FREE(soln);
}
