int
f2c_ctrsv(char* uplo, char* trans, char* diag, integer* N,
complex* A, integer* lda,
complex* X, integer* incX)
{
ctrsv_(uplo, trans, diag,
N, A, lda, X, incX);
return 0;
}
void
cpanel_bmod (
const int m, /* in - number of rows in the matrix */
const int w, /* in */
const int jcol, /* in */
const int nseg, /* in */
complex *dense, /* out, of size n by w */
complex *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;
complex alpha, beta;
#endif
register int k, ksub;
int fsupc, nsupc, nsupr, nrow;
int krep, krep_ind;
complex 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;
complex *lusup;
int *xlusup;
int *repfnz_col; /* repfnz[] for a column in the panel */
complex *dense_col; /* dense[] for a column in the panel */
complex *tempv1; /* Used in 1-D update */
complex *TriTmp, *MatvecTmp; /* used in 2-D update */
complex zero = {0.0, 0.0};
complex one = {1.0, 0.0};
complex 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];
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
c_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 ) {
cc_mult(&comp_temp, &ukj1, &lusup[luptr1]);
c_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++;
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
cc_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
}
} else {
ukj2 = dense_col[lsub[krep_ind - 2]];
luptr2 = luptr1 - nsupr;
cc_mult(&comp_temp, &ukj2, &lusup[luptr2-1]);
c_sub(&ukj1, &ukj1, &comp_temp);
cc_mult(&comp_temp, &ukj1, &lusup[luptr1]);
cc_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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++;
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
cc_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
cc_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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
ctrsv_( "L", "N", "U", &segsze, &lusup[luptr],
&nsupr, TriTmp, &incx );
#endif
#else
clsolve ( 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
cgemv_("N", &block_nrow, &segsze, &alpha, &lusup[luptr1],
&nsupr, TriTmp, &incx, &beta, MatvecTmp, &incy);
#endif
#else
cmatvec(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];
c_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];
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
c_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 ) {
cc_mult(&comp_temp, &ukj1, &lusup[luptr1]);
c_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;
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
cc_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_sub(&dense_col[irow], &dense_col[irow], &comp_temp);
}
} else {
ukj2 = dense_col[lsub[krep_ind - 2]];
luptr2 = luptr1 - nsupr;
cc_mult(&comp_temp, &ukj2, &lusup[luptr2-1]);
c_sub(&ukj1, &ukj1, &comp_temp);
cc_mult(&comp_temp, &ukj1, &lusup[luptr1]);
cc_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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;
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
cc_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
cc_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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
ctrsv_( "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
cgemv_( "N", &nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, tempv, &incx, &beta, tempv1, &incy );
#endif
#else
clsolve ( nsupr, segsze, &lusup[luptr], tempv );
luptr += segsze; /* Dense matrix-vector */
tempv1 = &tempv[segsze];
cmatvec (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];
c_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 ... */
}
int
pcgstrf_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 */
complex *dense, /* modified */
complex *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;
complex 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
*/
complex 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;
complex *lusup;
int *xlusup, *xlusup_end;
complex *tempv1;
int mem_error;
register float flopcnt;
complex zero = {0.0, 0.0};
complex one = {1.0, 0.0};
complex none = {-1.0, 0.0};
complex 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) pcgstrf_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 = segsze * (segsze - 1) + 2 * nrow * segsze;//sj
Gstat->procstat[pnum].fcops += flopcnt;
#if ( DEBUGlevel>=2 )
if (jcol==BADCOL)
printf("(%d) pcgstrf_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];
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
c_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 */
cc_mult(&comp_temp, &ukj1, &lusup[luptr1]);
c_sub(&ukj, &ukj, &comp_temp);
dense[lsub[krep_ind]] = ukj;
for (i = lptr + nsupc; i < xlsub_end[fsupc]; ++i) {
irow = lsub[i];
luptr++;
luptr1++;
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
cc_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_sub(&dense[irow], &dense[irow], &comp_temp);
}
} else { /* Case 3: 3cols-col update */
ukj2 = dense[lsub[krep_ind - 2]];
luptr2 = luptr1 - nsupr;
cc_mult(&comp_temp, &ukj2, &lusup[luptr2-1]);
c_sub(&ukj1, &ukj1, &comp_temp);
cc_mult(&comp_temp, &ukj1, &lusup[luptr1]);
cc_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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++;
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
cc_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
cc_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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
ctrsv_( "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
cgemv_( "N", &nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, tempv, &incx, &beta, tempv1, &incy );
#endif
#else
clsolve ( nsupr, segsze, &lusup[luptr], tempv );
luptr += segsze; /* Dense matrix-vector */
tempv1 = &tempv[segsze];
cmatvec (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];
c_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) pcgstrf_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) pcgstrf_column_bmod[3] jcol %d, fsupc %d, nsupr %d, nsupc %d, nrow %d\n",
pnum, jcol, fsupc, nsupr, nsupc, nrow);
#endif
flopcnt = nsupc * (nsupc - 1) + 2 * nrow * nsupc; //sj
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
ctrsv_( "L", "N", "U", &nsupc, &lusup[luptr],
&nsupr, &lusup[ufirst], &incx );
cgemv_( "N", &nrow, &nsupc, &alpha, &lusup[luptr+nsupc], &nsupr,
&lusup[ufirst], &incx, &beta, &lusup[ufirst+nsupc], &incy );
#endif
#else
clsolve ( nsupr, nsupc, &lusup[luptr], &lusup[ufirst] );
cmatvec ( nsupr, nrow, nsupc, &lusup[luptr+nsupc],
&lusup[ufirst], tempv );
/* Copy updates from tempv[*] into lusup[*] */
isub = ufirst + nsupc;
for (i = 0; i < nrow; i++) {
c_sub(&lusup[isub], &lusup[isub], &tempv[i]);
tempv[i] = zero;
++isub;
}
#endif
} /* if fst_col < jcol ... */
return 0;
}
/* Subroutine */ int ctrrfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb,
complex *x, integer *ldx, real *ferr, real *berr, complex *work, real
*rwork, integer *info, ftnlen uplo_len, ftnlen trans_len, ftnlen
diag_len)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer i__, j, k;
static real s, xk;
static integer nz;
static real eps;
static integer kase;
static real safe1, safe2;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *, ftnlen, ftnlen,
ftnlen), ctrsv_(char *, char *, char *, integer *, complex *,
integer *, complex *, integer *, ftnlen, ftnlen, ftnlen), clacon_(
integer *, complex *, complex *, real *, integer *);
extern doublereal slamch_(char *, ftnlen);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static logical notran;
static char transn[1], transt[1];
static logical nounit;
static real lstres;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTRRFS provides error bounds and backward error estimates for the */
/* solution to a system of linear equations with a triangular */
/* coefficient matrix. */
/* The solution matrix X must be computed by CTRTRS or some other */
/* means before entering this routine. CTRRFS does not do iterative */
/* refinement because doing so cannot improve the backward error. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) COMPLEX array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) REAL array, 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). */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1) && !
lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRRFS", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon", (ftnlen)7);
safmin = slamch_("Safe minimum", (ftnlen)12);
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A, A**T, or A**H, depending on TRANS. */
ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1, (
ftnlen)1, (ftnlen)1, (ftnlen)1);
q__1.r = -1.f, q__1.i = -0.f;
caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
i__ + j * b_dim1]), dabs(r__2));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), dabs(r__2));
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a[i__ + k * a_dim1]), dabs(
r__2))) * xk;
/* L30: */
}
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a[i__ + k * a_dim1]), dabs(
r__2))) * xk;
/* L50: */
}
rwork[k] += xk;
/* L60: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), dabs(r__2));
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a[i__ + k * a_dim1]), dabs(
r__2))) * xk;
/* L70: */
}
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), dabs(r__2));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a[i__ + k * a_dim1]), dabs(
r__2))) * xk;
/* L90: */
}
rwork[k] += xk;
/* L100: */
}
}
}
} else {
/* Compute abs(A**H)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + k * a_dim1]), dabs(r__2)))
* ((r__3 = x[i__5].r, dabs(r__3)) + (
r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(
r__4)));
/* L110: */
}
rwork[k] += s;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + j * x_dim1;
s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + k * a_dim1]), dabs(r__2)))
* ((r__3 = x[i__5].r, dabs(r__3)) + (
r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(
r__4)));
/* L130: */
}
rwork[k] += s;
/* L140: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + k * a_dim1]), dabs(r__2)))
* ((r__3 = x[i__5].r, dabs(r__3)) + (
r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(
r__4)));
/* L150: */
}
rwork[k] += s;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + j * x_dim1;
s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x[k + j * x_dim1]), dabs(r__2));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + k * a_dim1]), dabs(r__2)))
* ((r__3 = x[i__5].r, dabs(r__3)) + (
r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(
r__4)));
/* L170: */
}
rwork[k] += s;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__4);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(op(A)))* */
/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
/* Use CLACON to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
ctrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[1], &
c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L230: */
}
ctrsv_(uplo, transn, diag, n, &a[a_offset], lda, &work[1], &
c__1, (ftnlen)1, (ftnlen)1, (ftnlen)1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = i__ + j * x_dim1;
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L240: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of CTRRFS */
} /* ctrrfs_ */
int chegs2_(int *itype, char *uplo, int *n, complex *
a, int *lda, complex *b, int *ldb, int *info)
{
/* System generated locals */
int a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
float r__1, r__2;
complex q__1;
/* Local variables */
int k;
complex ct;
float akk, bkk;
extern int cher2_(char *, int *, complex *, complex *
, int *, complex *, int *, complex *, int *);
extern int lsame_(char *, char *);
extern int caxpy_(int *, complex *, complex *,
int *, complex *, int *);
int upper;
extern int ctrmv_(char *, char *, char *, int *,
complex *, int *, complex *, int *), ctrsv_(char *, char *, char *, int *, complex *,
int *, complex *, int *), clacgv_(
int *, complex *, int *), csscal_(int *, float *,
complex *, int *), xerbla_(char *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHEGS2 reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
/* B must have been previously factorized as U'*U or L*L' by CPOTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
/* = 2 or 3: compute U*A*U' or L'*A*L. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored, and how B has been factorized. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* n by n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* The triangular factor from the Cholesky factorization of B, */
/* as returned by CPOTRF. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= MAX(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < MAX(1,*n)) {
*info = -5;
} else if (*ldb < MAX(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a[k + (k + 1) * a_dim1], lda);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
clacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cher2_(uplo, &i__2, &q__1, &a[k + (k + 1) * a_dim1], lda,
&b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
ctrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
k + 1 + (k + 1) * b_dim1], ldb, &a[k + (k + 1) *
a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a[k + 1 + k * a_dim1], &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cher2_(uplo, &i__2, &q__1, &a[k + 1 + k * a_dim1], &c__1,
&b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
ctrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
&c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
ctrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[k *
b_dim1 + 1], &c__1, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
clacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k - 1;
ctrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
b_offset], ldb, &a[k + a_dim1], lda);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
clacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1]
, ldb, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
clacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a[k + a_dim1], lda);
i__2 = k - 1;
clacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L40: */
}
}
}
return 0;
/* End of CHEGS2 */
} /* chegs2_ */
void
ctrsv(char uplo, char transa, char diag, int n, complex *a, int lda, complex *x, int incx)
{
ctrsv_( &uplo, &transa, &diag, &n, a, &lda, x, &incx);
}
int
pcgstrf_snode_bmod(
const int pnum, /* process number */
const int jcol, /* in - current column in the s-node */
const int jsupno, /* in */
const int fsupc, /* in - first column in the s-node */
complex *dense, /* in */
complex *tempv, /* working array */
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
*
* Performs numeric block updates within the relaxed supernode.
*/
complex zero = {0.0, 0.0};
complex one = {1.0, 0.0};
complex none = {-1.0, 0.0};
#if ( MACH==CRAY_PVP )
_fcd ftcs1, ftcs2, ftcs3;
#endif
#ifdef USE_VENDOR_BLAS
int incx = 1, incy = 1;
complex alpha = none, beta = one;
#endif
int luptr, nsupc, nsupr, nrow;
int isub, irow, i, iptr;
register int ufirst, nextlu;
complex *lusup;
int *lsub, *xlsub, *xlsub_end, *xlusup, *xlusup_end;
register float flopcnt;
lsub = Glu->lsub;
xlsub = Glu->xlsub;
xlsub_end = Glu->xlsub_end;
lusup = Glu->lusup;
xlusup = Glu->xlusup;
xlusup_end = Glu->xlusup_end;
nextlu = xlusup[jcol];
/*
* Process the supernodal portion of L\U[*,j]
*/
for (isub = xlsub[fsupc]; isub < xlsub_end[fsupc]; isub++) {
irow = lsub[isub];
lusup[nextlu] = dense[irow];
dense[irow] = zero;
++nextlu;
}
xlusup_end[jcol] = nextlu;
if ( fsupc < jcol ) {
luptr = xlusup[fsupc];
nsupr = xlsub_end[fsupc] - xlsub[fsupc];
nsupc = jcol - fsupc; /* Excluding jcol */
ufirst = xlusup[jcol]; /* Points to the beginning of column
jcol in supernode L\U(jsupno). */
nrow = nsupr - nsupc;
flopcnt = nsupc * (nsupc - 1) + 2 * nrow * nsupc; //sj
Gstat->procstat[pnum].fcops += flopcnt;
/* ops[TRSV] += nsupc * (nsupc - 1);
ops[GEMV] += 2 * nrow * nsupc; */
#ifdef USE_VENDOR_BLAS
#if ( MACH==CRAY_PVP )
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("N", strlen("N"));
ftcs3 = _cptofcd("U", strlen("U"));
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
ctrsv_( "L", "N", "U", &nsupc, &lusup[luptr], &nsupr,
&lusup[ufirst], &incx );
cgemv_( "N", &nrow, &nsupc, &alpha, &lusup[luptr+nsupc], &nsupr,
&lusup[ufirst], &incx, &beta, &lusup[ufirst+nsupc], &incy );
#endif
#else
clsolve ( nsupr, nsupc, &lusup[luptr], &lusup[ufirst] );
cmatvec ( nsupr, nrow, nsupc, &lusup[luptr+nsupc],
&lusup[ufirst], &tempv[0] );
/* Scatter tempv[*] into lusup[*] */
iptr = ufirst + nsupc;
for (i = 0; i < nrow; i++) {
c_sub(&lusup[iptr], &lusup[iptr], &tempv[i]);
++iptr;
tempv[i] = zero;
}
#endif
}
return 0;
}
/*! \brief Performs numeric block updates within the relaxed snode.
*/
int
csnode_bmod (
const int jcol, /* in */
const int jsupno, /* in */
const int fsupc, /* in */
complex *dense, /* in */
complex *tempv, /* working array */
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;
complex alpha = {-1.0, 0.0}, beta = {1.0, 0.0};
#endif
complex comp_zero = {0.0, 0.0};
int luptr, nsupc, nsupr, nrow;
int isub, irow, i, iptr;
register int ufirst, nextlu;
int *lsub, *xlsub;
complex *lusup;
int *xlusup;
flops_t *ops = stat->ops;
lsub = Glu->lsub;
xlsub = Glu->xlsub;
lusup = (complex *) Glu->lusup;
xlusup = Glu->xlusup;
nextlu = xlusup[jcol];
/*
* Process the supernodal portion of L\U[*,j]
*/
for (isub = xlsub[fsupc]; isub < xlsub[fsupc+1]; isub++) {
irow = lsub[isub];
lusup[nextlu] = dense[irow];
dense[irow] = comp_zero;
++nextlu;
}
xlusup[jcol + 1] = nextlu; /* Initialize xlusup for next column */
if ( fsupc < jcol ) {
luptr = xlusup[fsupc];
nsupr = xlsub[fsupc+1] - xlsub[fsupc];
nsupc = jcol - fsupc; /* Excluding jcol */
ufirst = xlusup[jcol]; /* Points to the beginning of column
jcol in supernode L\U(jsupno). */
nrow = nsupr - nsupc;
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 );
CGEMV( ftcs2, &nrow, &nsupc, &alpha, &lusup[luptr+nsupc], &nsupr,
&lusup[ufirst], &incx, &beta, &lusup[ufirst+nsupc], &incy );
#else
#if SCIPY_FIX
if (nsupr < nsupc) {
/* Fail early rather than passing in invalid parameters to TRSV. */
ABORT("failed to factorize matrix");
}
#endif
ctrsv_( "L", "N", "U", &nsupc, &lusup[luptr], &nsupr,
&lusup[ufirst], &incx );
cgemv_( "N", &nrow, &nsupc, &alpha, &lusup[luptr+nsupc], &nsupr,
&lusup[ufirst], &incx, &beta, &lusup[ufirst+nsupc], &incy );
#endif
#else
clsolve ( nsupr, nsupc, &lusup[luptr], &lusup[ufirst] );
cmatvec ( nsupr, nrow, nsupc, &lusup[luptr+nsupc],
&lusup[ufirst], &tempv[0] );
/* Scatter tempv[*] into lusup[*] */
iptr = ufirst + nsupc;
for (i = 0; i < nrow; i++) {
c_sub(&lusup[iptr], &lusup[iptr], &tempv[i]);
++iptr;
tempv[i] = comp_zero;
}
#endif
}
return 0;
}
/* Subroutine */ int chegs2_(integer *itype, char *uplo, integer *n, complex *
a, integer *lda, complex *b, integer *ldb, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CHEGS2 reduces a complex Hermitian-definite generalized
eigenproblem to standard form.
If ITYPE = 1, the problem is A*x = lambda*B*x,
and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
B must have been previously factorized as U'*U or L*L' by CPOTRF.
Arguments
=========
ITYPE (input) INTEGER
= 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
= 2 or 3: compute U*A*U' or L'*A*L.
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored, and how B has been factorized.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
n by n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n by n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the transformed matrix, stored in the
same format as A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) COMPLEX array, dimension (LDB,N)
The triangular factor from the Cholesky factorization of B,
as returned by CPOTRF.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1, r__2;
complex q__1;
/* Local variables */
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *);
static integer k;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *,
integer *, complex *, integer *);
static complex ct;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
static real akk, bkk;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = a_subscr(k, k);
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a_ref(k, k + 1), lda);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
clacgv_(&i__2, &a_ref(k, k + 1), lda);
i__2 = *n - k;
clacgv_(&i__2, &b_ref(k, k + 1), ldb);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cher2_(uplo, &i__2, &q__1, &a_ref(k, k + 1), lda, &b_ref(
k, k + 1), ldb, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
clacgv_(&i__2, &b_ref(k, k + 1), ldb);
i__2 = *n - k;
ctrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &
b_ref(k + 1, k + 1), ldb, &a_ref(k, k + 1), lda);
i__2 = *n - k;
clacgv_(&i__2, &a_ref(k, k + 1), lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = a_subscr(k, k);
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a_ref(k + 1, k), &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cher2_(uplo, &i__2, &q__1, &a_ref(k + 1, k), &c__1, &
b_ref(k + 1, k), &c__1, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
ctrsv_(uplo, "No transpose", "Non-unit", &i__2, &b_ref(k
+ 1, k + 1), ldb, &a_ref(k + 1, k), &c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
i__2 = k - 1;
ctrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a_ref(1, k), &c__1);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a_ref(1, k), &c__1, &b_ref(1, k),
&c__1, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a_ref(1, k), &c__1);
i__2 = a_subscr(k, k);
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
i__2 = k - 1;
clacgv_(&i__2, &a_ref(k, 1), lda);
i__2 = k - 1;
ctrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
b_offset], ldb, &a_ref(k, 1), lda);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
clacgv_(&i__2, &b_ref(k, 1), ldb);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a_ref(k, 1), lda, &b_ref(k, 1),
ldb, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
clacgv_(&i__2, &b_ref(k, 1), ldb);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a_ref(k, 1), lda);
i__2 = k - 1;
clacgv_(&i__2, &a_ref(k, 1), lda);
i__2 = a_subscr(k, k);
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L40: */
}
}
}
return 0;
/* End of CHEGS2 */
} /* chegs2_ */
void
pcgstrf_bmod1D(
const int pnum, /* process number */
const int m, /* number of rows 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 supernode */
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 */
complex *dense, /* modified */
complex *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 block updates (sup-panel) in topological order.
* It features: col-col, 2cols-col, 3cols-col, and sup-col updates.
* 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;
complex alpha, beta;
#endif
complex ukj, ukj1, ukj2;
int luptr, luptr1, luptr2;
int segsze;
register int lptr; /* start of row subscripts of the updating supernode */
register int i, krep_ind, kfnz, isub, irow, no_zeros;
register int jj; /* index through each column in the panel */
int *repfnz_col; /* repfnz[] for a column in the panel */
complex *dense_col; /* dense[] for a column in the panel */
complex *tempv1; /* used to store matrix-vector result */
int *col_marker; /* each column of the spa_marker[*,w] */
int *col_lsub; /* each column of the panel_lsub[*,w] */
int *lsub, *xlsub_end;
complex *lusup;
int *xlusup;
register float flopcnt;
complex zero = {0.0, 0.0};
complex one = {1.0, 0.0};
complex comp_temp, comp_temp1;
#ifdef TIMING
double *utime = Gstat->utime;
double f_time;
#endif
lsub = Glu->lsub;
xlsub_end = Glu->xlsub_end;
lusup = Glu->lusup;
xlusup = Glu->xlusup;
lptr = Glu->xlsub[fsupc];
krep_ind = lptr + nsupc - 1;
/* Pointers to each column of the w-wide arrays. */
repfnz_col= repfnz;
dense_col = dense;
col_marker= spa_marker;
col_lsub = panel_lsub;
#if ( DEBUGlevel>=2 )
if (jcol == BADPAN && krep == BADREP) {
printf("(%d) pcgstrf_bmod1D[1] jcol %d, fsupc %d, krep %d, nsupc %d, nsupr %d, nrow %d\n",
pnum, jcol, fsupc, krep, nsupc, nsupr, nrow);
PrintInt10("lsub[xlsub[2774]]", nsupr, &lsub[lptr]);
}
#endif
/*
* Sequence through each column in the panel ...
*/
for (jj = jcol; jj < jcol + w; ++jj, col_marker += m, col_lsub += m,
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];
/* Calculate flops: tri-solve + mat-vector */
Gstat->procstat[pnum].fcops += flopcnt;
/* Case 1: Update U-segment of size 1 -- col-col update */
if ( segsze == 1 ) {
#ifdef TIMING
f_time = SuperLU_timer_();
#endif
ukj = dense_col[lsub[krep_ind]];
luptr += nsupr*(nsupc-1) + nsupc;
#if ( DEBUGlevel>=2 )
if (krep == BADCOL && jj == -1) {
printf("(%d) pcgstrf_bmod1D[segsze=1]: k %d, j %d, ukj %.10e\n",
pnum, lsub[krep_ind], jj, ukj);
PrintInt10("segsze=1", nsupr, &lsub[lptr]);
}
#endif
for (i = lptr + nsupc; i < xlsub_end[fsupc]; i++) {
irow = lsub[i];
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
c_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 ) {
#ifdef TIMING
f_time = SuperLU_timer_();
#endif
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 ) {
cc_mult(&comp_temp, &ukj1, &lusup[luptr1]);
c_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;
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
cc_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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
}
} else {
ukj2 = dense_col[lsub[krep_ind - 2]];
luptr2 = luptr1 - nsupr;
cc_mult(&comp_temp, &ukj2, &lusup[luptr2-1]);
c_sub(&ukj1, &ukj1, &comp_temp);
cc_mult(&comp_temp, &ukj1, &lusup[luptr1]);
cc_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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;
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
cc_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
cc_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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 */
/*
* Perform a triangular solve and matrix-vector update,
* then scatter the result of sup-col update to dense[*].
*/
no_zeros = kfnz - fsupc;
/* Gather 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;
/*#pragma ivdep*/
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 TIMING
f_time = SuperLU_timer_();
#endif
#ifdef USE_VENDOR_BLAS
#if ( MACH==CRAY_PVP )
CTRSV( ftcs1, ftcs2, ftcs3, &segsze, &lusup[luptr],
&nsupr, tempv, &incx );
#else
ctrsv_( "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
cgemv_( "N", &nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, tempv, &incx, &beta, tempv1, &incy );
#endif /* _CRAY_PVP */
#else
clsolve ( nsupr, segsze, &lusup[luptr], tempv );
luptr += segsze; /* Dense matrix-vector */
tempv1 = &tempv[segsze];
cmatvec (nsupr, nrow, segsze, &lusup[luptr], tempv, tempv1);
#endif
#ifdef TIMING
utime[FLOAT] += SuperLU_timer_() - f_time;
#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;
/*#pragma ivdep*/
for (i = 0; i < segsze; i++) {
irow = lsub[isub];
dense_col[irow] = tempv[i]; /* Scatter */
tempv[i] = zero;
isub++;
#if ( DEBUGlevel>=2 )
if (jj == -1 && krep == 3423)
printf("(%d) pcgstrf_bmod1D[scatter] jj %d, dense_col[%d] %e\n",
pnum, jj, irow, dense_col[irow]);
#endif
}
/* Scatter the update from tempv1[*] into SPA dense[*] */
/*#pragma ivdep*/
for (i = 0; i < nrow; i++) {
irow = lsub[isub];
c_sub(&dense_col[irow], &dense_col[irow],
&tempv1[i]); /* Scatter-add */
#ifdef SCATTER_FOUND
if ( col_marker[irow] != jj ) {
col_marker[irow] = jj;
col_lsub[w_lsub_end[jj-jcol]++] = irow;
}
#endif
tempv1[i] = zero;
isub++;
}
} /* else segsze >= 4 ... */
} /* for jj ... */
}
/* Return value: 0 - successful return
* > 0 - number of bytes allocated when run out of space
*/
int
ccolumn_bmod (
const int jcol, /* in */
const int nseg, /* in */
complex *dense, /* in */
complex *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;
complex 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
*/
complex 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;
complex *lusup;
int *xlusup;
int nzlumax;
complex *tempv1;
complex zero = {0.0, 0.0};
complex one = {1.0, 0.0};
complex none = {-1.0, 0.0};
complex 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;
/*
* 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];
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
c_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 */
cc_mult(&comp_temp, &ukj1, &lusup[luptr1]);
c_sub(&ukj, &ukj, &comp_temp);
dense[lsub[krep_ind]] = ukj;
for (i = lptr + nsupc; i < xlsub[fsupc+1]; ++i) {
irow = lsub[i];
luptr++;
luptr1++;
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
cc_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_sub(&dense[irow], &dense[irow], &comp_temp);
}
} else { /* Case 3: 3cols-col update */
ukj2 = dense[lsub[krep_ind - 2]];
luptr2 = luptr1 - nsupr;
cc_mult(&comp_temp, &ukj2, &lusup[luptr2-1]);
c_sub(&ukj1, &ukj1, &comp_temp);
cc_mult(&comp_temp, &ukj1, &lusup[luptr1]);
cc_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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++;
cc_mult(&comp_temp, &ukj, &lusup[luptr]);
cc_mult(&comp_temp1, &ukj1, &lusup[luptr1]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
cc_mult(&comp_temp1, &ukj2, &lusup[luptr2]);
c_add(&comp_temp, &comp_temp, &comp_temp1);
c_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
ctrsv_( "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
cgemv_( "N", &nrow, &segsze, &alpha, &lusup[luptr],
&nsupr, tempv, &incx, &beta, tempv1, &incy );
#endif
#else
clsolve ( nsupr, segsze, &lusup[luptr], tempv );
luptr += segsze; /* Dense matrix-vector */
tempv1 = &tempv[segsze];
cmatvec (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];
c_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 = cLUMemXpand(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
ctrsv_( "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
cgemv_( "N", &nrow, &nsupc, &alpha, &lusup[luptr+nsupc], &nsupr,
&lusup[ufirst], &incx, &beta, &lusup[ufirst+nsupc], &incy );
#endif
#else
clsolve ( nsupr, nsupc, &lusup[luptr], &lusup[ufirst] );
cmatvec ( nsupr, nrow, nsupc, &lusup[luptr+nsupc],
&lusup[ufirst], tempv );
/* Copy updates from tempv[*] into lusup[*] */
isub = ufirst + nsupc;
for (i = 0; i < nrow; i++) {
c_sub(&lusup[isub], &lusup[isub], &tempv[i]);
tempv[i] = zero;
++isub;
}
#endif
} /* if fst_col < jcol ... */
return 0;
}
/* Subroutine */
int ctrrfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, j, k;
real s, xk;
integer nz;
real eps;
integer kase;
real safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */
int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */
int ctrmv_(char *, char *, char *, integer *, complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *, integer *, complex *, integer *), clacn2_( integer *, complex *, complex *, real *, integer *, integer *);
extern real slamch_(char *);
real safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
logical notran;
char transn[1], transt[1];
logical nounit;
real lstres;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
else if (*nrhs < 0)
{
*info = -5;
}
else if (*lda < max(1,*n))
{
*info = -7;
}
else if (*ldb < max(1,*n))
{
*info = -9;
}
else if (*ldx < max(1,*n))
{
*info = -11;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CTRRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0)
{
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
ferr[j] = 0.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
if (notran)
{
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
}
else
{
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A, A**T, or A**H, depending on TRANS. */
ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( f2c_abs(R(i)) / ( f2c_abs(op(A))*f2c_abs(X) + f2c_abs(B) )(i) ) */
/* where f2c_abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * b_dim1;
rwork[i__] = (r__1 = b[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&b[ i__ + j * b_dim1]), f2c_abs(r__2));
/* L20: */
}
if (notran)
{
/* Compute f2c_abs(A)*f2c_abs(X) + f2c_abs(B). */
if (upper)
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), f2c_abs(r__2));
i__3 = k;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, f2c_abs(r__1)) + ( r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs( r__2))) * xk;
/* L30: */
}
/* L40: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), f2c_abs(r__2));
i__3 = k - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, f2c_abs(r__1)) + ( r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs( r__2))) * xk;
/* L50: */
}
rwork[k] += xk;
/* L60: */
}
}
}
else
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), f2c_abs(r__2));
i__3 = *n;
for (i__ = k;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, f2c_abs(r__1)) + ( r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs( r__2))) * xk;
/* L70: */
}
/* L80: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), f2c_abs(r__2));
i__3 = *n;
for (i__ = k + 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, f2c_abs(r__1)) + ( r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs( r__2))) * xk;
/* L90: */
}
rwork[k] += xk;
/* L100: */
}
}
}
}
else
{
/* Compute f2c_abs(A**H)*f2c_abs(X) + f2c_abs(B). */
if (upper)
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.f;
i__3 = k;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs(r__2))) * ((r__3 = x[i__5].r, f2c_abs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), f2c_abs(r__4))) ;
/* L110: */
}
rwork[k] += s;
/* L120: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
s = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&x[ k + j * x_dim1]), f2c_abs(r__2));
i__3 = k - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs(r__2))) * ((r__3 = x[i__5].r, f2c_abs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), f2c_abs(r__4))) ;
/* L130: */
}
rwork[k] += s;
/* L140: */
}
}
}
else
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.f;
i__3 = *n;
for (i__ = k;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs(r__2))) * ((r__3 = x[i__5].r, f2c_abs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), f2c_abs(r__4))) ;
/* L150: */
}
rwork[k] += s;
/* L160: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
s = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&x[ k + j * x_dim1]), f2c_abs(r__2));
i__3 = *n;
for (i__ = k + 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs(r__2))) * ((r__3 = x[i__5].r, f2c_abs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), f2c_abs(r__4))) ;
/* L170: */
}
rwork[k] += s;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
if (rwork[i__] > safe2)
{
/* Computing MAX */
i__3 = i__;
r__3 = s;
r__4 = ((r__1 = work[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&work[i__]), f2c_abs(r__2))) / rwork[i__]; // , expr subst
s = max(r__3,r__4);
}
else
{
/* Computing MAX */
i__3 = i__;
r__3 = s;
r__4 = ((r__1 = work[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&work[i__]), f2c_abs(r__2)) + safe1) / (rwork[i__] + safe1); // , expr subst
s = max(r__3,r__4);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( f2c_abs(inv(op(A)))* */
/* ( f2c_abs(R) + NZ*EPS*( f2c_abs(op(A))*f2c_abs(X)+f2c_abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* f2c_abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of f2c_abs(R)+NZ*EPS*(f2c_abs(op(A))*f2c_abs(X)+f2c_abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* f2c_abs(op(A))*f2c_abs(X) + f2c_abs(B) is less than SAFE2. */
/* Use CLACN2 to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = f2c_abs(R) + NZ*EPS*( f2c_abs(op(A))*f2c_abs(X)+f2c_abs(B) ))) */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
if (rwork[i__] > safe2)
{
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&work[i__]), f2c_abs(r__2)) + nz * eps * rwork[i__] ;
}
else
{
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&work[i__]), f2c_abs(r__2)) + nz * eps * rwork[i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0)
{
if (kase == 1)
{
/* Multiply by diag(W)*inv(op(A)**H). */
ctrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[1], & c__1);
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r;
q__1.i = rwork[i__4] * work[i__5].i; // , expr subst
work[i__3].r = q__1.r;
work[i__3].i = q__1.i; // , expr subst
/* L220: */
}
}
else
{
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r;
q__1.i = rwork[i__4] * work[i__5].i; // , expr subst
work[i__3].r = q__1.r;
work[i__3].i = q__1.i; // , expr subst
/* L230: */
}
ctrsv_(uplo, transn, diag, n, &a[a_offset], lda, &work[1], & c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
/* Computing MAX */
i__3 = i__ + j * x_dim1;
r__3 = lstres;
r__4 = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&x[i__ + j * x_dim1]), f2c_abs(r__2)); // , expr subst
lstres = max(r__3,r__4);
/* L240: */
}
if (lstres != 0.f)
{
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of CTRRFS */
}
int
sp_ctrsv(char *uplo, char *trans, char *diag, SuperMatrix *L,
SuperMatrix *U, complex *x, int *info)
{
/*
* Purpose
* =======
*
* sp_ctrsv() solves one of the systems of equations
* A*x = b, or A'*x = b,
* where b and x are n element vectors and A is a sparse unit , or
* non-unit, upper or lower triangular matrix.
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* uplo - (input) char*
* On entry, uplo specifies whether the matrix is an upper or
* lower triangular matrix as follows:
* uplo = 'U' or 'u' A is an upper triangular matrix.
* uplo = 'L' or 'l' A is a lower triangular matrix.
*
* trans - (input) char*
* On entry, trans specifies the equations to be solved as
* follows:
* trans = 'N' or 'n' A*x = b.
* trans = 'T' or 't' A'*x = b.
* trans = 'C' or 'c' A'*x = b.
*
* diag - (input) char*
* On entry, diag specifies whether or not A is unit
* triangular as follows:
* diag = 'U' or 'u' A is assumed to be unit triangular.
* diag = 'N' or 'n' A is not assumed to be unit
* triangular.
*
* L - (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U. Use
* compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SC, Dtype = SLU_C, Mtype = TRLU.
*
* U - (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U.
* U has types: Stype = NC, Dtype = SLU_C, Mtype = TRU.
*
* x - (input/output) complex*
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* info - (output) int*
* If *info = -i, the i-th argument had an illegal value.
*
*/
#ifdef _CRAY
_fcd ftcs1 = _cptofcd("L", strlen("L")),
ftcs2 = _cptofcd("N", strlen("N")),
ftcs3 = _cptofcd("U", strlen("U"));
#endif
SCformat *Lstore;
NCformat *Ustore;
complex *Lval, *Uval;
int incx = 1, incy = 1;
complex alpha = {1.0, 0.0}, beta = {1.0, 0.0};
complex comp_zero = {0.0, 0.0};
int nrow;
int fsupc, nsupr, nsupc, luptr, istart, irow;
int i, k, iptr, jcol;
complex *work;
flops_t solve_ops;
extern SuperLUStat_t SuperLUStat;
/* Test the input parameters */
*info = 0;
if ( !lsame_(uplo,"L") && !lsame_(uplo, "U") ) *info = -1;
else if ( !lsame_(trans, "N") && !lsame_(trans, "T") ) *info = -2;
else if ( !lsame_(diag, "U") && !lsame_(diag, "N") ) *info = -3;
else if ( L->nrow != L->ncol || L->nrow < 0 ) *info = -4;
else if ( U->nrow != U->ncol || U->nrow < 0 ) *info = -5;
if ( *info ) {
i = -(*info);
xerbla_("sp_ctrsv", &i);
return 0;
}
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
solve_ops = 0;
if ( !(work = complexCalloc(L->nrow)) )
ABORT("Malloc fails for work in sp_ctrsv().");
if ( lsame_(trans, "N") ) { /* Form x := inv(A)*x. */
if ( lsame_(uplo, "L") ) {
/* Form x := inv(L)*x */
if ( L->nrow == 0 ) return 0; /* Quick return */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
nrow = nsupr - nsupc;
solve_ops += 4 * nsupc * (nsupc - 1);
solve_ops += 8 * nrow * nsupc;
if ( nsupc == 1 ) {
for (iptr=istart+1; iptr < L_SUB_START(fsupc+1); ++iptr) {
irow = L_SUB(iptr);
++luptr;
cc_mult(&comp_zero, &x[fsupc], &Lval[luptr]);
c_sub(&x[irow], &x[irow], &comp_zero);
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
CGEMV(ftcs2, &nrow, &nsupc, &alpha, &Lval[luptr+nsupc],
&nsupr, &x[fsupc], &incx, &beta, &work[0], &incy);
#else
ctrsv_("L", "N", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
cgemv_("N", &nrow, &nsupc, &alpha, &Lval[luptr+nsupc],
&nsupr, &x[fsupc], &incx, &beta, &work[0], &incy);
#endif
#else
clsolve ( nsupr, nsupc, &Lval[luptr], &x[fsupc]);
cmatvec ( nsupr, nsupr-nsupc, nsupc, &Lval[luptr+nsupc],
&x[fsupc], &work[0] );
#endif
iptr = istart + nsupc;
for (i = 0; i < nrow; ++i, ++iptr) {
irow = L_SUB(iptr);
c_sub(&x[irow], &x[irow], &work[i]); /* Scatter */
work[i] = comp_zero;
}
}
} /* for k ... */
} else {
/* Form x := inv(U)*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = Lstore->nsuper; k >= 0; k--) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 4 * nsupc * (nsupc + 1);
if ( nsupc == 1 ) {
c_div(&x[fsupc], &x[fsupc], &Lval[luptr]);
for (i = U_NZ_START(fsupc); i < U_NZ_START(fsupc+1); ++i) {
irow = U_SUB(i);
cc_mult(&comp_zero, &x[fsupc], &Uval[i]);
c_sub(&x[irow], &x[irow], &comp_zero);
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV(ftcs3, ftcs2, ftcs2, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ctrsv_("U", "N", "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
#else
cusolve ( nsupr, nsupc, &Lval[luptr], &x[fsupc] );
#endif
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1);
i++) {
irow = U_SUB(i);
cc_mult(&comp_zero, &x[jcol], &Uval[i]);
c_sub(&x[irow], &x[irow], &comp_zero);
}
}
}
} /* for k ... */
}
} else { /* Form x := inv(A')*x */
if ( lsame_(uplo, "L") ) {
/* Form x := inv(L')*x */
if ( L->nrow == 0 ) return 0; /* Quick return */
for (k = Lstore->nsuper; k >= 0; --k) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 8 * (nsupr - nsupc) * nsupc;
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
iptr = istart + nsupc;
for (i = L_NZ_START(jcol) + nsupc;
i < L_NZ_START(jcol+1); i++) {
irow = L_SUB(iptr);
cc_mult(&comp_zero, &x[irow], &Lval[i]);
c_sub(&x[jcol], &x[jcol], &comp_zero);
iptr++;
}
}
if ( nsupc > 1 ) {
solve_ops += 4 * nsupc * (nsupc - 1);
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("T", strlen("T"));
ftcs3 = _cptofcd("U", strlen("U"));
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ctrsv_("L", "T", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
}
} else {
/* Form x := inv(U')*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++) {
irow = U_SUB(i);
cc_mult(&comp_zero, &x[irow], &Uval[i]);
c_sub(&x[jcol], &x[jcol], &comp_zero);
}
}
solve_ops += 4 * nsupc * (nsupc + 1);
if ( nsupc == 1 ) {
c_div(&x[fsupc], &x[fsupc], &Lval[luptr]);
} else {
#ifdef _CRAY
ftcs1 = _cptofcd("U", strlen("U"));
ftcs2 = _cptofcd("T", strlen("T"));
ftcs3 = _cptofcd("N", strlen("N"));
CTRSV( ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ctrsv_("U", "T", "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
} /* for k ... */
}
}
SuperLUStat.ops[SOLVE] += solve_ops;
SUPERLU_FREE(work);
return 0;
}
/* Subroutine */ int clatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, complex *a, integer *lda, complex *x, real *scale,
real *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
real xj, rec, tjj;
integer jinc;
real xbnd;
integer imax;
real tmax;
complex tjjs;
real xmax, grow;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal;
complex uscal;
integer jlast;
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
complex csumj;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int ctrsv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLATRS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow. Here A is an upper or lower */
/* triangular matrix, A**T denotes the transpose of A, A**H denotes the */
/* conjugate transpose of A, x and b are n-element vectors, and s is a */
/* scaling factor, usually less than or equal to 1, chosen so that the */
/* components of x will be less than the overflow threshold. If the */
/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
/* CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A**T * x = s*b (Transpose) */
/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max (1,N). */
/* X (input/output) COMPLEX array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) REAL */
/* The scaling factor s for the triangular system */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) REAL array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, CTRSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* for j = 1, ..., n */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the */
/* reciprocal of the largest M(j), j=1,..,n, is larger than */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
/* A**H *x = b. The basic algorithm for A upper triangular is */
/* for j = 1, ..., n */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum /= slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = scasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = scasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
/* L20: */
}
cnorm[*n] = 0.f;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5f) {
tscal = 1.f;
} else {
tscal = .5f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine CTRSV can be used. */
xmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
r_imag(&x[j]) / 2.f, dabs(r__2));
xmax = dmax(r__3,r__4);
/* L30: */
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.f;
}
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1.f / (cnorm[j] + 1.f);
/* L50: */
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.f;
/* Computing MIN */
r__1 = grow, r__2 = xbnd / xj;
grow = dmin(r__1,r__2);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
/* L70: */
}
grow = dmin(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.f;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ctrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5f) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5f / xmax;
csscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.f;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3].i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L105;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.f) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L105:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f) {
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
csscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = icamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
} else {
if (j < *n) {
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
}
/* L110: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotu_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotu_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L120: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L130: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L145;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L145:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L150: */
}
} else {
/* Solve A**H * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotc_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotc_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L160: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L170: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L185;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L185:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L190: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f) {
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of CLATRS */
} /* clatrs_ */
/*! \brief Solves one of the systems of equations A*x = b, or A'*x = b
*
* <pre>
* Purpose
* =======
*
* sp_ctrsv() solves one of the systems of equations
* A*x = b, or A'*x = b,
* where b and x are n element vectors and A is a sparse unit , or
* non-unit, upper or lower triangular matrix.
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* uplo - (input) char*
* On entry, uplo specifies whether the matrix is an upper or
* lower triangular matrix as follows:
* uplo = 'U' or 'u' A is an upper triangular matrix.
* uplo = 'L' or 'l' A is a lower triangular matrix.
*
* trans - (input) char*
* On entry, trans specifies the equations to be solved as
* follows:
* trans = 'N' or 'n' A*x = b.
* trans = 'T' or 't' A'*x = b.
* trans = 'C' or 'c' A^H*x = b.
*
* diag - (input) char*
* On entry, diag specifies whether or not A is unit
* triangular as follows:
* diag = 'U' or 'u' A is assumed to be unit triangular.
* diag = 'N' or 'n' A is not assumed to be unit
* triangular.
*
* L - (input) SuperMatrix*
* The factor L from the factorization Pr*A*Pc=L*U. Use
* compressed row subscripts storage for supernodes,
* i.e., L has types: Stype = SC, Dtype = SLU_C, Mtype = TRLU.
*
* U - (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U.
* U has types: Stype = NC, Dtype = SLU_C, Mtype = TRU.
*
* x - (input/output) complex*
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* info - (output) int*
* If *info = -i, the i-th argument had an illegal value.
* </pre>
*/
int
sp_ctrsv(char *uplo, char *trans, char *diag, SuperMatrix *L,
SuperMatrix *U, complex *x, SuperLUStat_t *stat, int *info)
{
#ifdef _CRAY
_fcd ftcs1 = _cptofcd("L", strlen("L")),
ftcs2 = _cptofcd("N", strlen("N")),
ftcs3 = _cptofcd("U", strlen("U"));
#endif
SCformat *Lstore;
NCformat *Ustore;
complex *Lval, *Uval;
int incx = 1, incy = 1;
complex temp;
complex alpha = {1.0, 0.0}, beta = {1.0, 0.0};
complex comp_zero = {0.0, 0.0};
int nrow;
int fsupc, nsupr, nsupc, luptr, istart, irow;
int i, k, iptr, jcol;
complex *work;
flops_t solve_ops;
/* Test the input parameters */
*info = 0;
if ( strncmp(uplo,"L", 1)!=0 && strncmp(uplo, "U", 1)!=0 ) *info = -1;
else if ( strncmp(trans, "N", 1)!=0 && strncmp(trans, "T", 1)!=0 &&
strncmp(trans, "C", 1)!=0) *info = -2;
else if ( strncmp(diag, "U", 1)!=0 && strncmp(diag, "N", 1)!=0 )
*info = -3;
else if ( L->nrow != L->ncol || L->nrow < 0 ) *info = -4;
else if ( U->nrow != U->ncol || U->nrow < 0 ) *info = -5;
if ( *info ) {
i = -(*info);
input_error("sp_ctrsv", &i);
return 0;
}
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
solve_ops = 0;
if ( !(work = complexCalloc(L->nrow)) )
ABORT("Malloc fails for work in sp_ctrsv().");
if ( strncmp(trans, "N", 1)==0 ) { /* Form x := inv(A)*x. */
if ( strncmp(uplo, "L", 1)==0 ) {
/* Form x := inv(L)*x */
if ( L->nrow == 0 ) return 0; /* Quick return */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
nrow = nsupr - nsupc;
/* 1 c_div costs 10 flops */
solve_ops += 4 * nsupc * (nsupc - 1) + 10 * nsupc;
solve_ops += 8 * nrow * nsupc;
if ( nsupc == 1 ) {
for (iptr=istart+1; iptr < L_SUB_START(fsupc+1); ++iptr) {
irow = L_SUB(iptr);
++luptr;
cc_mult(&comp_zero, &x[fsupc], &Lval[luptr]);
c_sub(&x[irow], &x[irow], &comp_zero);
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
CGEMV(ftcs2, &nrow, &nsupc, &alpha, &Lval[luptr+nsupc],
&nsupr, &x[fsupc], &incx, &beta, &work[0], &incy);
#else
ctrsv_("L", "N", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
cgemv_("N", &nrow, &nsupc, &alpha, &Lval[luptr+nsupc],
&nsupr, &x[fsupc], &incx, &beta, &work[0], &incy);
#endif
#else
clsolve ( nsupr, nsupc, &Lval[luptr], &x[fsupc]);
cmatvec ( nsupr, nsupr-nsupc, nsupc, &Lval[luptr+nsupc],
&x[fsupc], &work[0] );
#endif
iptr = istart + nsupc;
for (i = 0; i < nrow; ++i, ++iptr) {
irow = L_SUB(iptr);
c_sub(&x[irow], &x[irow], &work[i]); /* Scatter */
work[i] = comp_zero;
}
}
} /* for k ... */
} else {
/* Form x := inv(U)*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = Lstore->nsuper; k >= 0; k--) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
/* 1 c_div costs 10 flops */
solve_ops += 4 * nsupc * (nsupc + 1) + 10 * nsupc;
if ( nsupc == 1 ) {
c_div(&x[fsupc], &x[fsupc], &Lval[luptr]);
for (i = U_NZ_START(fsupc); i < U_NZ_START(fsupc+1); ++i) {
irow = U_SUB(i);
cc_mult(&comp_zero, &x[fsupc], &Uval[i]);
c_sub(&x[irow], &x[irow], &comp_zero);
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV(ftcs3, ftcs2, ftcs2, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ctrsv_("U", "N", "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
#else
cusolve ( nsupr, nsupc, &Lval[luptr], &x[fsupc] );
#endif
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1);
i++) {
irow = U_SUB(i);
cc_mult(&comp_zero, &x[jcol], &Uval[i]);
c_sub(&x[irow], &x[irow], &comp_zero);
}
}
}
} /* for k ... */
}
} else if ( strncmp(trans, "T", 1)==0 ) { /* Form x := inv(A')*x */
if ( strncmp(uplo, "L", 1)==0 ) {
/* Form x := inv(L')*x */
if ( L->nrow == 0 ) return 0; /* Quick return */
for (k = Lstore->nsuper; k >= 0; --k) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 8 * (nsupr - nsupc) * nsupc;
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
iptr = istart + nsupc;
for (i = L_NZ_START(jcol) + nsupc;
i < L_NZ_START(jcol+1); i++) {
irow = L_SUB(iptr);
cc_mult(&comp_zero, &x[irow], &Lval[i]);
c_sub(&x[jcol], &x[jcol], &comp_zero);
iptr++;
}
}
if ( nsupc > 1 ) {
solve_ops += 4 * nsupc * (nsupc - 1);
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("T", strlen("T"));
ftcs3 = _cptofcd("U", strlen("U"));
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ctrsv_("L", "T", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
}
} else {
/* Form x := inv(U')*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++) {
irow = U_SUB(i);
cc_mult(&comp_zero, &x[irow], &Uval[i]);
c_sub(&x[jcol], &x[jcol], &comp_zero);
}
}
/* 1 c_div costs 10 flops */
solve_ops += 4 * nsupc * (nsupc + 1) + 10 * nsupc;
if ( nsupc == 1 ) {
c_div(&x[fsupc], &x[fsupc], &Lval[luptr]);
} else {
#ifdef _CRAY
ftcs1 = _cptofcd("U", strlen("U"));
ftcs2 = _cptofcd("T", strlen("T"));
ftcs3 = _cptofcd("N", strlen("N"));
CTRSV( ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ctrsv_("U", "T", "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
} /* for k ... */
}
} else { /* Form x := conj(inv(A'))*x */
if ( strncmp(uplo, "L", 1)==0 ) {
/* Form x := conj(inv(L'))*x */
if ( L->nrow == 0 ) return 0; /* Quick return */
for (k = Lstore->nsuper; k >= 0; --k) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 8 * (nsupr - nsupc) * nsupc;
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
iptr = istart + nsupc;
for (i = L_NZ_START(jcol) + nsupc;
i < L_NZ_START(jcol+1); i++) {
irow = L_SUB(iptr);
cc_conj(&temp, &Lval[i]);
cc_mult(&comp_zero, &x[irow], &temp);
c_sub(&x[jcol], &x[jcol], &comp_zero);
iptr++;
}
}
if ( nsupc > 1 ) {
solve_ops += 4 * nsupc * (nsupc - 1);
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd(trans, strlen("T"));
ftcs3 = _cptofcd("U", strlen("U"));
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ctrsv_("L", trans, "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
}
} else {
/* Form x := conj(inv(U'))*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++) {
irow = U_SUB(i);
cc_conj(&temp, &Uval[i]);
cc_mult(&comp_zero, &x[irow], &temp);
c_sub(&x[jcol], &x[jcol], &comp_zero);
}
}
/* 1 c_div costs 10 flops */
solve_ops += 4 * nsupc * (nsupc + 1) + 10 * nsupc;
if ( nsupc == 1 ) {
cc_conj(&temp, &Lval[luptr]);
c_div(&x[fsupc], &x[fsupc], &temp);
} else {
#ifdef _CRAY
ftcs1 = _cptofcd("U", strlen("U"));
ftcs2 = _cptofcd(trans, strlen("T"));
ftcs3 = _cptofcd("N", strlen("N"));
CTRSV( ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ctrsv_("U", trans, "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
} /* for k ... */
}
}
stat->ops[SOLVE] += solve_ops;
SUPERLU_FREE(work);
return 0;
}
/* Subroutine */ int cggglm_(integer *n, integer *m, integer *p, complex *a,
integer *lda, complex *b, integer *ldb, complex *d__, complex *x,
complex *y, complex *work, integer *lwork, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CGGGLM solves a general Gauss-Markov linear model (GLM) problem:
minimize || y ||_2 subject to d = A*x + B*y
x
where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
given N-vector. It is assumed that M <= N <= M+P, and
rank(A) = M and rank( A B ) = N.
Under these assumptions, the constrained equation is always
consistent, and there is a unique solution x and a minimal 2-norm
solution y, which is obtained using a generalized QR factorization
of A and B.
In particular, if matrix B is square nonsingular, then the problem
GLM is equivalent to the following weighted linear least squares
problem
minimize || inv(B)*(d-A*x) ||_2
x
where inv(B) denotes the inverse of B.
Arguments
=========
N (input) INTEGER
The number of rows of the matrices A and B. N >= 0.
M (input) INTEGER
The number of columns of the matrix A. 0 <= M <= N.
P (input) INTEGER
The number of columns of the matrix B. P >= N-M.
A (input/output) COMPLEX array, dimension (LDA,M)
On entry, the N-by-M matrix A.
On exit, A is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB,P)
On entry, the N-by-P matrix B.
On exit, B is destroyed.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
D (input/output) COMPLEX array, dimension (N)
On entry, D is the left hand side of the GLM equation.
On exit, D is destroyed.
X (output) COMPLEX array, dimension (M)
Y (output) COMPLEX array, dimension (P)
On exit, X and Y are the solutions of the GLM problem.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,N+M+P).
For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
where NB is an upper bound for the optimal blocksizes for
CGEQRF, CGERQF, CUNMQR and CUNMRQ.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
===================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
static integer lopt, i__;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), ccopy_(integer *, complex *, integer *,
complex *, integer *), ctrsv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *);
static integer nb, np;
extern /* Subroutine */ int cggqrf_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, complex *,
complex *, integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer nb1, nb2, nb3, nb4;
extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *), cunmrq_(char *,
char *, integer *, integer *, integer *, complex *, integer *,
complex *, complex *, integer *, complex *, integer *, integer *);
static integer lwkopt;
static logical lquery;
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--d__;
--x;
--y;
--work;
/* Function Body */
*info = 0;
np = min(*n,*p);
nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, m, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb2 = ilaenv_(&c__1, "CGERQF", " ", n, m, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)1);
nb3 = ilaenv_(&c__1, "CUNMQR", " ", n, m, p, &c_n1, (ftnlen)6, (ftnlen)1);
nb4 = ilaenv_(&c__1, "CUNMRQ", " ", n, m, p, &c_n1, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
nb = max(i__1,nb4);
lwkopt = *m + np + max(*n,*p) * nb;
work[1].r = (real) lwkopt, work[1].i = 0.f;
lquery = *lwork == -1;
if (*n < 0) {
*info = -1;
} else if (*m < 0 || *m > *n) {
*info = -2;
} else if (*p < 0 || *p < *n - *m) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *n + *m + *p;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGGGLM", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Compute the GQR factorization of matrices A and B:
Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M
( 0 ) N-M ( 0 T22 ) N-M
M M+P-N N-M
where R11 and T22 are upper triangular, and Q and Z are
unitary. */
i__1 = *lwork - *m - np;
cggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m
+ 1], &work[*m + np + 1], &i__1, info);
i__1 = *m + np + 1;
lopt = work[i__1].r;
/* Update left-hand-side vector d = Q'*d = ( d1 ) M
( d2 ) N-M */
i__1 = max(1,*n);
i__2 = *lwork - *m - np;
cunmqr_("Left", "Conjugate transpose", n, &c__1, m, &a[a_offset], lda, &
work[1], &d__[1], &i__1, &work[*m + np + 1], &i__2, info);
/* Computing MAX */
i__3 = *m + np + 1;
i__1 = lopt, i__2 = (integer) work[i__3].r;
lopt = max(i__1,i__2);
/* Solve T22*y2 = d2 for y2 */
i__1 = *n - *m;
ctrsv_("Upper", "No transpose", "Non unit", &i__1, &b_ref(*m + 1, *m + *p
- *n + 1), ldb, &d__[*m + 1], &c__1);
i__1 = *n - *m;
ccopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1);
/* Set y1 = 0 */
i__1 = *m + *p - *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
y[i__2].r = 0.f, y[i__2].i = 0.f;
/* L10: */
}
/* Update d1 = d1 - T12*y2 */
i__1 = *n - *m;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("No transpose", m, &i__1, &q__1, &b_ref(1, *m + *p - *n + 1), ldb,
&y[*m + *p - *n + 1], &c__1, &c_b2, &d__[1], &c__1);
/* Solve triangular system: R11*x = d1 */
ctrsv_("Upper", "No Transpose", "Non unit", m, &a[a_offset], lda, &d__[1],
&c__1);
/* Copy D to X */
ccopy_(m, &d__[1], &c__1, &x[1], &c__1);
/* Backward transformation y = Z'*y
Computing MAX */
i__1 = 1, i__2 = *n - *p + 1;
i__3 = max(1,*p);
i__4 = *lwork - *m - np;
cunmrq_("Left", "Conjugate transpose", p, &c__1, &np, &b_ref(max(i__1,
i__2), 1), ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &
i__4, info);
/* Computing MAX */
i__4 = *m + np + 1;
i__2 = lopt, i__3 = (integer) work[i__4].r;
i__1 = *m + np + max(i__2,i__3);
work[1].r = (real) i__1, work[1].i = 0.f;
return 0;
/* End of CGGGLM */
} /* cggglm_ */
void cblas_ctrsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
const integer N, const void *A, const integer lda, void *X,
const integer incX)
{
char TA;
char UL;
char DI;
#ifdef F77_CHAR
F77_CHAR F77_TA, F77_UL, F77_DI;
#else
#define F77_TA &TA
#define F77_UL &UL
#define F77_DI &DI
#endif
#define F77_N N
#define F77_lda lda
#define F77_incX incX
integer n, i=0, tincX;
float *st=0,*x=(float *)X;
extern integer CBLAS_CallFromC;
extern integer RowMajorStrg;
RowMajorStrg = 0;
CBLAS_CallFromC = 1;
if (order == CblasColMajor)
{
if (Uplo == CblasUpper) UL = 'U';
else if (Uplo == CblasLower) UL = 'L';
else
{
cblas_xerbla(2, "cblas_ctrsv","Illegal Uplo setting, %d\n", Uplo);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if (TransA == CblasNoTrans) TA = 'N';
else if (TransA == CblasTrans) TA = 'T';
else if (TransA == CblasConjTrans) TA = 'C';
else
{
cblas_xerbla(3, "cblas_ctrsv","Illegal TransA setting, %d\n", TransA);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if (Diag == CblasUnit) DI = 'U';
else if (Diag == CblasNonUnit) DI = 'N';
else
{
cblas_xerbla(4, "cblas_ctrsv","Illegal Diag setting, %d\n", Diag);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_TA = C2F_CHAR(&TA);
F77_DI = C2F_CHAR(&DI);
#endif
ctrsv_( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X,
&F77_incX);
}
else if (order == CblasRowMajor)
{
RowMajorStrg = 1;
if (Uplo == CblasUpper) UL = 'L';
else if (Uplo == CblasLower) UL = 'U';
else
{
cblas_xerbla(2, "cblas_ctrsv","Illegal Uplo setting, %d\n", Uplo);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if (TransA == CblasNoTrans) TA = 'T';
else if (TransA == CblasTrans) TA = 'N';
else if (TransA == CblasConjTrans)
{
TA = 'N';
if ( N > 0)
{
if ( incX > 0 )
tincX = incX;
else
tincX = -incX;
n = N*2*(tincX);
x++;
st=x+n;
i = tincX << 1;
do
{
*x = -(*x);
x+=i;
}
while (x != st);
x -= n;
}
}
else
{
cblas_xerbla(3, "cblas_ctrsv","Illegal TransA setting, %d\n", TransA);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if (Diag == CblasUnit) DI = 'U';
else if (Diag == CblasNonUnit) DI = 'N';
else
{
cblas_xerbla(4, "cblas_ctrsv","Illegal Diag setting, %d\n", Diag);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_TA = C2F_CHAR(&TA);
F77_DI = C2F_CHAR(&DI);
#endif
ctrsv_( F77_UL, F77_TA, F77_DI, &F77_N, A, &F77_lda, X,
&F77_incX);
if (TransA == CblasConjTrans)
{
if (N > 0)
{
do
{
*x = -(*x);
x += i;
}
while (x != st);
}
}
}
else cblas_xerbla(1, "cblas_ctrsv", "Illegal Order setting, %d\n", order);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
