/* Subroutine */ int cgerc_(integer *m, integer *n, complex *alpha, complex *
x, integer *incx, complex *y, integer *incy, complex *a, integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
complex q__1, q__2;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer info;
static complex temp;
static integer i, j, ix, jy, kx;
extern int input_error(char *, int *);
/* Purpose
=======
CGERC performs the rank 1 operation
A := alpha*x*conjg( y' ) + A,
where alpha is a scalar, x is an m element vector, y is an n element
vector and A is an m by n matrix.
Parameters
==========
M - INTEGER.
On entry, M specifies the number of rows of the matrix A.
M must be at least zero.
Unchanged on exit.
N - INTEGER.
On entry, N specifies the number of columns of the matrix A.
N must be at least zero.
Unchanged on exit.
ALPHA - COMPLEX .
On entry, ALPHA specifies the scalar alpha.
Unchanged on exit.
X - COMPLEX array of dimension at least
( 1 + ( m - 1 )*abs( INCX ) ).
Before entry, the incremented array X must contain the m
element vector x.
Unchanged on exit.
INCX - INTEGER.
On entry, INCX specifies the increment for the elements of
X. INCX must not be zero.
Unchanged on exit.
Y - COMPLEX array of dimension at least
( 1 + ( n - 1 )*abs( INCY ) ).
Before entry, the incremented array Y must contain the n
element vector y.
Unchanged on exit.
INCY - INTEGER.
On entry, INCY specifies the increment for the elements of
Y. INCY must not be zero.
Unchanged on exit.
A - COMPLEX array of DIMENSION ( LDA, n ).
Before entry, the leading m by n part of the array A must
contain the matrix of coefficients. On exit, A is
overwritten by the updated matrix.
LDA - INTEGER.
On entry, LDA specifies the first dimension of A as declared
in the calling (sub) program. LDA must be at least
max( 1, m ).
Unchanged on exit.
Level 2 Blas routine.
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
Test the input parameters.
Parameter adjustments
Function Body */
#define X(I) x[(I)-1]
#define Y(I) y[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
info = 0;
if (*m < 0) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 5;
} else if (*incy == 0) {
info = 7;
} else if (*lda < max(1,*m)) {
info = 9;
}
if (info != 0) {
input_error("CGERC ", &info);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
return 0;
}
/* Start the operations. In this version the elements of A are
accessed sequentially with one pass through A. */
if (*incy > 0) {
jy = 1;
} else {
jy = 1 - (*n - 1) * *incy;
}
if (*incx == 1) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = jy;
if (Y(jy).r != 0.f || Y(jy).i != 0.f) {
r_cnjg(&q__2, &Y(jy));
q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
alpha->r * q__2.i + alpha->i * q__2.r;
temp.r = q__1.r, temp.i = q__1.i;
i__2 = *m;
for (i = 1; i <= *m; ++i) {
i__3 = i + j * a_dim1;
i__4 = i + j * a_dim1;
i__5 = i;
q__2.r = X(i).r * temp.r - X(i).i * temp.i, q__2.i =
X(i).r * temp.i + X(i).i * temp.r;
q__1.r = A(i,j).r + q__2.r, q__1.i = A(i,j).i + q__2.i;
A(i,j).r = q__1.r, A(i,j).i = q__1.i;
/* L10: */
}
}
jy += *incy;
/* L20: */
}
} else {
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*m - 1) * *incx;
}
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = jy;
if (Y(jy).r != 0.f || Y(jy).i != 0.f) {
r_cnjg(&q__2, &Y(jy));
q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
alpha->r * q__2.i + alpha->i * q__2.r;
temp.r = q__1.r, temp.i = q__1.i;
ix = kx;
i__2 = *m;
for (i = 1; i <= *m; ++i) {
i__3 = i + j * a_dim1;
i__4 = i + j * a_dim1;
i__5 = ix;
q__2.r = X(ix).r * temp.r - X(ix).i * temp.i, q__2.i =
X(ix).r * temp.i + X(ix).i * temp.r;
q__1.r = A(i,j).r + q__2.r, q__1.i = A(i,j).i + q__2.i;
A(i,j).r = q__1.r, A(i,j).i = q__1.i;
ix += *incx;
/* L30: */
}
}
jy += *incy;
/* L40: */
}
}
return 0;
/* End of CGERC . */
} /* cgerc_ */
void
zgstrs (trans_t trans, SuperMatrix *L, SuperMatrix *U,
int *perm_c, int *perm_r, SuperMatrix *B,
SuperLUStat_t *stat, int *info)
{
#ifdef _CRAY
_fcd ftcs1, ftcs2, ftcs3, ftcs4;
#endif
int incx = 1, incy = 1;
#ifdef USE_VENDOR_BLAS
doublecomplex alpha = {1.0, 0.0}, beta = {1.0, 0.0};
doublecomplex *work_col;
#endif
doublecomplex temp_comp;
DNformat *Bstore;
doublecomplex *Bmat;
SCformat *Lstore;
NCformat *Ustore;
doublecomplex *Lval, *Uval;
int fsupc, nrow, nsupr, nsupc, luptr, istart, irow;
int i, j, k, iptr, jcol, n, ldb, nrhs;
doublecomplex *work, *rhs_work, *soln;
flops_t solve_ops;
void zprint_soln();
/* Test input parameters ... */
*info = 0;
Bstore = B->Store;
ldb = Bstore->lda;
nrhs = B->ncol;
if ( trans != NOTRANS && trans != TRANS && trans != CONJ ) *info = -1;
else if ( L->nrow != L->ncol || L->nrow < 0 ||
L->Stype != SLU_SC || L->Dtype != SLU_Z || L->Mtype != SLU_TRLU )
*info = -2;
else if ( U->nrow != U->ncol || U->nrow < 0 ||
U->Stype != SLU_NC || U->Dtype != SLU_Z || U->Mtype != SLU_TRU )
*info = -3;
else if ( ldb < SUPERLU_MAX(0, L->nrow) ||
B->Stype != SLU_DN || B->Dtype != SLU_Z || B->Mtype != SLU_GE )
*info = -6;
if ( *info ) {
i = -(*info);
input_error("zgstrs", &i);
return;
}
n = L->nrow;
work = doublecomplexCalloc(n * nrhs);
if ( !work ) ABORT("Malloc fails for local work[].");
soln = doublecomplexMalloc(n);
if ( !soln ) ABORT("Malloc fails for local soln[].");
Bmat = Bstore->nzval;
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
solve_ops = 0;
if ( trans == NOTRANS ) {
/* Permute right hand sides to form Pr*B */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[perm_r[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
/* Forward solve PLy=Pb. */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
nrow = nsupr - nsupc;
solve_ops += 4 * nsupc * (nsupc - 1) * nrhs;
solve_ops += 8 * nrow * nsupc * nrhs;
if ( nsupc == 1 ) {
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
luptr = L_NZ_START(fsupc);
for (iptr=istart+1; iptr < L_SUB_START(fsupc+1); iptr++){
irow = L_SUB(iptr);
++luptr;
zz_mult(&temp_comp, &rhs_work[fsupc], &Lval[luptr]);
z_sub(&rhs_work[irow], &rhs_work[irow], &temp_comp);
}
}
} else {
luptr = L_NZ_START(fsupc);
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("N", strlen("N"));
ftcs3 = _cptofcd("U", strlen("U"));
CTRSM( ftcs1, ftcs1, ftcs2, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
CGEMM( ftcs2, ftcs2, &nrow, &nrhs, &nsupc, &alpha,
&Lval[luptr+nsupc], &nsupr, &Bmat[fsupc], &ldb,
&beta, &work[0], &n );
#else
ztrsm_("L", "L", "N", "U", &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
zgemm_( "N", "N", &nrow, &nrhs, &nsupc, &alpha,
&Lval[luptr+nsupc], &nsupr, &Bmat[fsupc], &ldb,
&beta, &work[0], &n );
#endif
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
work_col = &work[j*n];
iptr = istart + nsupc;
for (i = 0; i < nrow; i++) {
irow = L_SUB(iptr);
z_sub(&rhs_work[irow], &rhs_work[irow], &work_col[i]);
work_col[i].r = 0.0;
work_col[i].i = 0.0;
iptr++;
}
}
#else
for (j = 0; j < nrhs; j++) {
rhs_work = &Bmat[j*ldb];
zlsolve (nsupr, nsupc, &Lval[luptr], &rhs_work[fsupc]);
zmatvec (nsupr, nrow, nsupc, &Lval[luptr+nsupc],
&rhs_work[fsupc], &work[0] );
iptr = istart + nsupc;
for (i = 0; i < nrow; i++) {
irow = L_SUB(iptr);
z_sub(&rhs_work[irow], &rhs_work[irow], &work[i]);
work[i].r = 0.;
work[i].i = 0.;
iptr++;
}
}
#endif
} /* else ... */
} /* for L-solve */
#ifdef DEBUG
printf("After L-solve: y=\n");
zprint_soln(n, nrhs, Bmat);
#endif
/*
* Back solve Ux=y.
*/
for (k = Lstore->nsuper; k >= 0; k--) {
fsupc = L_FST_SUPC(k);
istart = L_SUB_START(fsupc);
nsupr = L_SUB_START(fsupc+1) - istart;
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
solve_ops += 4 * nsupc * (nsupc + 1) * nrhs;
if ( nsupc == 1 ) {
rhs_work = &Bmat[0];
for (j = 0; j < nrhs; j++) {
z_div(&rhs_work[fsupc], &rhs_work[fsupc], &Lval[luptr]);
rhs_work += ldb;
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("U", strlen("U"));
ftcs3 = _cptofcd("N", strlen("N"));
CTRSM( ftcs1, ftcs2, ftcs3, ftcs3, &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#else
ztrsm_("L", "U", "N", "N", &nsupc, &nrhs, &alpha,
&Lval[luptr], &nsupr, &Bmat[fsupc], &ldb);
#endif
#else
for (j = 0; j < nrhs; j++)
zusolve ( nsupr, nsupc, &Lval[luptr], &Bmat[fsupc+j*ldb] );
#endif
}
for (j = 0; j < nrhs; ++j) {
rhs_work = &Bmat[j*ldb];
for (jcol = fsupc; jcol < fsupc + nsupc; jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++ ){
irow = U_SUB(i);
zz_mult(&temp_comp, &rhs_work[jcol], &Uval[i]);
z_sub(&rhs_work[irow], &rhs_work[irow], &temp_comp);
}
}
}
} /* for U-solve */
#ifdef DEBUG
printf("After U-solve: x=\n");
zprint_soln(n, nrhs, Bmat);
#endif
/* Compute the final solution X := Pc*X. */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_c[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
stat->ops[SOLVE] = solve_ops;
} else { /* Solve A'*X=B or CONJ(A)*X=B */
/* Permute right hand sides to form Pc'*B. */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[perm_c[k]] = rhs_work[k];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
stat->ops[SOLVE] = 0;
if (trans == TRANS) {
for (k = 0; k < nrhs; ++k) {
/* Multiply by inv(U'). */
sp_ztrsv("U", "T", "N", L, U, &Bmat[k*ldb], stat, info);
/* Multiply by inv(L'). */
sp_ztrsv("L", "T", "U", L, U, &Bmat[k*ldb], stat, info);
}
} else { /* trans == CONJ */
for (k = 0; k < nrhs; ++k) {
/* Multiply by conj(inv(U')). */
sp_ztrsv("U", "C", "N", L, U, &Bmat[k*ldb], stat, info);
/* Multiply by conj(inv(L')). */
sp_ztrsv("L", "C", "U", L, U, &Bmat[k*ldb], stat, info);
}
}
/* Compute the final solution X := Pr'*X (=inv(Pr)*X) */
for (i = 0; i < nrhs; i++) {
rhs_work = &Bmat[i*ldb];
for (k = 0; k < n; k++) soln[k] = rhs_work[perm_r[k]];
for (k = 0; k < n; k++) rhs_work[k] = soln[k];
}
}
SUPERLU_FREE(work);
SUPERLU_FREE(soln);
}
/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha,
doublereal *x, integer *incx, doublereal *y, integer *incy,
doublereal *a, integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer info;
static doublereal temp1, temp2;
static integer i, j;
static integer ix, iy, jx, jy, kx, ky;
extern int input_error(char *, int *);
/* Purpose
=======
DSYR2 performs the symmetric rank 2 operation
A := alpha*x*y' + alpha*y*x' + A,
where alpha is a scalar, x and y are n element vectors and A is an n
by n symmetric matrix.
Parameters
==========
UPLO - CHARACTER*1.
On entry, UPLO specifies whether the upper or lower
triangular part of the array A is to be referenced as
follows:
UPLO = 'U' or 'u' Only the upper triangular part of A
is to be referenced.
UPLO = 'L' or 'l' Only the lower triangular part of A
is to be referenced.
Unchanged on exit.
N - INTEGER.
On entry, N specifies the order of the matrix A.
N must be at least zero.
Unchanged on exit.
ALPHA - DOUBLE PRECISION.
On entry, ALPHA specifies the scalar alpha.
Unchanged on exit.
X - DOUBLE PRECISION array of dimension at least
( 1 + ( n - 1 )*abs( INCX ) ).
Before entry, the incremented array X must contain the n
element vector x.
Unchanged on exit.
INCX - INTEGER.
On entry, INCX specifies the increment for the elements of
X. INCX must not be zero.
Unchanged on exit.
Y - DOUBLE PRECISION array of dimension at least
( 1 + ( n - 1 )*abs( INCY ) ).
Before entry, the incremented array Y must contain the n
element vector y.
Unchanged on exit.
INCY - INTEGER.
On entry, INCY specifies the increment for the elements of
Y. INCY must not be zero.
Unchanged on exit.
A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
Before entry with UPLO = 'U' or 'u', the leading n by n
upper triangular part of the array A must contain the upper
triangular part of the symmetric matrix and the strictly
lower triangular part of A is not referenced. On exit, the
upper triangular part of the array A is overwritten by the
upper triangular part of the updated matrix.
Before entry with UPLO = 'L' or 'l', the leading n by n
lower triangular part of the array A must contain the lower
triangular part of the symmetric matrix and the strictly
upper triangular part of A is not referenced. On exit, the
lower triangular part of the array A is overwritten by the
lower triangular part of the updated matrix.
LDA - INTEGER.
On entry, LDA specifies the first dimension of A as declared
in the calling (sub) program. LDA must be at least
max( 1, n ).
Unchanged on exit.
Level 2 Blas routine.
-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.
Test the input parameters.
Parameter adjustments
Function Body */
#define X(I) x[(I)-1]
#define Y(I) y[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
info = 0;
if ( strncmp(uplo, "U", 1)!=0 && strncmp(uplo, "L", 1)!=0 ) {
info = 1;
} else if (*n < 0) {
info = 2;
} else if (*incx == 0) {
info = 5;
} else if (*incy == 0) {
info = 7;
} else if (*lda < max(1,*n)) {
info = 9;
}
if (info != 0) {
input_error("DSYR2 ", &info);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || *alpha == 0.) {
return 0;
}
/* Set up the start points in X and Y if the increments are not both
unity. */
if (*incx != 1 || *incy != 1) {
if (*incx > 0) {
kx = 1;
} else {
kx = 1 - (*n - 1) * *incx;
}
if (*incy > 0) {
ky = 1;
} else {
ky = 1 - (*n - 1) * *incy;
}
jx = kx;
jy = ky;
}
/* Start the operations. In this version the elements of A are
accessed sequentially with one pass through the triangular part
of A. */
if (strncmp(uplo, "U", 1)==0) {
/* Form A when A is stored in the upper triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (X(j) != 0. || Y(j) != 0.) {
temp1 = *alpha * Y(j);
temp2 = *alpha * X(j);
i__2 = j;
for (i = 1; i <= j; ++i) {
A(i,j) = A(i,j) + X(i) * temp1
+ Y(i) * temp2;
/* L10: */
}
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (X(jx) != 0. || Y(jy) != 0.) {
temp1 = *alpha * Y(jy);
temp2 = *alpha * X(jx);
ix = kx;
iy = ky;
i__2 = j;
for (i = 1; i <= j; ++i) {
A(i,j) = A(i,j) + X(ix) * temp1
+ Y(iy) * temp2;
ix += *incx;
iy += *incy;
/* L30: */
}
}
jx += *incx;
jy += *incy;
/* L40: */
}
}
} else {
/* Form A when A is stored in the lower triangle. */
if (*incx == 1 && *incy == 1) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (X(j) != 0. || Y(j) != 0.) {
temp1 = *alpha * Y(j);
temp2 = *alpha * X(j);
i__2 = *n;
for (i = j; i <= *n; ++i) {
A(i,j) = A(i,j) + X(i) * temp1
+ Y(i) * temp2;
/* L50: */
}
}
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
if (X(jx) != 0. || Y(jy) != 0.) {
temp1 = *alpha * Y(jy);
temp2 = *alpha * X(jx);
ix = jx;
iy = jy;
i__2 = *n;
for (i = j; i <= *n; ++i) {
A(i,j) = A(i,j) + X(ix) * temp1
+ Y(iy) * temp2;
ix += *incx;
iy += *incy;
/* L70: */
}
}
jx += *incx;
jy += *incy;
/* L80: */
}
}
}
return 0;
/* End of DSYR2 . */
} /* dsyr2_ */
/* Subroutine */ int clagge_slu(integer *m, integer *n, integer *kl, integer *ku,
real *d, complex *a, integer *lda, integer *iseed, complex *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
static integer i, j;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cscal_(integer *, complex *, complex *, integer *), cgemv_(char *
, integer *, integer *, complex *, complex *, integer *, complex *
, integer *, complex *, complex *, integer *);
extern real scnrm2_(integer *, complex *, integer *);
static complex wa, wb;
extern /* Subroutine */ int clacgv_slu(integer *, complex *, integer *);
static real wn;
extern /* Subroutine */ int clarnv_slu(integer *, integer *, integer *, complex *);
extern int input_error(char *, int *);
static complex tau;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAGGE generates a complex general m by n matrix A, by pre- and post-
multiplying a real diagonal matrix D with random unitary matrices:
A = U*D*V. The lower and upper bandwidths may then be reduced to
kl and ku by additional unitary transformations.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
KL (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= KL <= M-1.
KU (input) INTEGER
The number of nonzero superdiagonals within the band of A.
0 <= KU <= N-1.
D (input) REAL array, dimension (min(M,N))
The diagonal elements of the diagonal matrix D.
A (output) COMPLEX array, dimension (LDA,N)
The generated m by n matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= M.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) COMPLEX array, dimension (M+N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0 || *kl > *m - 1) {
*info = -3;
} else if (*ku < 0 || *ku > *n - 1) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -7;
}
if (*info < 0) {
i__1 = -(*info);
input_error("CLAGGE", &i__1);
return 0;
}
/* initialize A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i = 1; i <= i__2; ++i) {
i__3 = i + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = min(*m,*n);
for (i = 1; i <= i__1; ++i) {
i__2 = i + i * a_dim1;
i__3 = i;
a[i__2].r = d[i__3], a[i__2].i = 0.f;
/* L30: */
}
/* pre- and post-multiply A by random unitary matrices */
for (i = min(*m,*n); i >= 1; --i) {
if (i < *m) {
/* generate random reflection */
i__1 = *m - i + 1;
clarnv_slu(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *m - i + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
d__1 = wn / c_abs(&work[1]);
q__1.r = d__1 * work[1].r, q__1.i = d__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *m - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* multiply A(i:m,i:n) by random reflection from the lef
t */
i__1 = *m - i + 1;
i__2 = *n - i + 1;
cgemv_("Conjugate transpose", &i__1, &i__2, &c_b2, &a[i + i *
a_dim1], lda, &work[1], &c__1, &c_b1, &work[*m + 1], &
c__1);
i__1 = *m - i + 1;
i__2 = *n - i + 1;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__1, &i__2, &q__1, &work[1], &c__1, &work[*m + 1], &c__1,
&a[i + i * a_dim1], lda);
}
if (i < *n) {
/* generate random reflection */
i__1 = *n - i + 1;
clarnv_slu(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
d__1 = wn / c_abs(&work[1]);
q__1.r = d__1 * work[1].r, q__1.i = d__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* multiply A(i:m,i:n) by random reflection from the rig
ht */
i__1 = *m - i + 1;
i__2 = *n - i + 1;
cgemv_("No transpose", &i__1, &i__2, &c_b2, &a[i + i * a_dim1],
lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
i__1 = *m - i + 1;
i__2 = *n - i + 1;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__1, &i__2, &q__1, &work[*n + 1], &c__1, &work[1], &c__1,
&a[i + i * a_dim1], lda);
}
/* L40: */
}
/* Reduce number of subdiagonals to KL and number of superdiagonals
to KU
Computing MAX */
i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
i__1 = max(i__2,i__3);
for (i = 1; i <= i__1; ++i) {
if (*kl <= *ku) {
/* annihilate subdiagonal elements first (necessary if K
L = 0)
Computing MIN */
i__2 = *m - 1 - *kl;
if (i <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i
) */
i__2 = *m - *kl - i + 1;
wn = scnrm2_(&i__2, &a[*kl + i + i * a_dim1], &c__1);
d__1 = wn / c_abs(&a[*kl + i + i * a_dim1]);
i__2 = *kl + i + i * a_dim1;
q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = *kl + i + i * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *m - *kl - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[*kl + i + 1 + i * a_dim1], &c__1);
i__2 = *kl + i + i * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply reflection to A(kl+i:m,i+1:n) from the l
eft */
i__2 = *m - *kl - i + 1;
i__3 = *n - i;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl + i
+ (i + 1) * a_dim1], lda, &a[*kl + i + i * a_dim1], &
c__1, &c_b1, &work[1], &c__1);
i__2 = *m - *kl - i + 1;
i__3 = *n - i;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__2, &i__3, &q__1, &a[*kl + i + i * a_dim1], &c__1, &
work[1], &c__1, &a[*kl + i + (i + 1) * a_dim1], lda);
i__2 = *kl + i + i * a_dim1;
q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
/* Computing MIN */
i__2 = *n - 1 - *ku;
if (i <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n
) */
i__2 = *n - *ku - i + 1;
wn = scnrm2_(&i__2, &a[i + (*ku + i) * a_dim1], lda);
d__1 = wn / c_abs(&a[i + (*ku + i) * a_dim1]);
i__2 = i + (*ku + i) * a_dim1;
q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = i + (*ku + i) * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *n - *ku - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[i + (*ku + i + 1) * a_dim1], lda);
i__2 = i + (*ku + i) * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply reflection to A(i+1:m,ku+i:n) from the r
ight */
i__2 = *n - *ku - i + 1;
clacgv_slu(&i__2, &a[i + (*ku + i) * a_dim1], lda);
i__2 = *m - i;
i__3 = *n - *ku - i + 1;
cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i + 1 + (*ku +
i) * a_dim1], lda, &a[i + (*ku + i) * a_dim1], lda, &
c_b1, &work[1], &c__1);
i__2 = *m - i;
i__3 = *n - *ku - i + 1;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__2, &i__3, &q__1, &work[1], &c__1, &a[i + (*ku + i)
* a_dim1], lda, &a[i + 1 + (*ku + i) * a_dim1], lda);
i__2 = i + (*ku + i) * a_dim1;
q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
} else {
/* annihilate superdiagonal elements first (necessary if
KU = 0)
Computing MIN */
i__2 = *n - 1 - *ku;
if (i <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n
) */
i__2 = *n - *ku - i + 1;
wn = scnrm2_(&i__2, &a[i + (*ku + i) * a_dim1], lda);
d__1 = wn / c_abs(&a[i + (*ku + i) * a_dim1]);
i__2 = i + (*ku + i) * a_dim1;
q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = i + (*ku + i) * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *n - *ku - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[i + (*ku + i + 1) * a_dim1], lda);
i__2 = i + (*ku + i) * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply reflection to A(i+1:m,ku+i:n) from the r
ight */
i__2 = *n - *ku - i + 1;
clacgv_slu(&i__2, &a[i + (*ku + i) * a_dim1], lda);
i__2 = *m - i;
i__3 = *n - *ku - i + 1;
cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i + 1 + (*ku +
i) * a_dim1], lda, &a[i + (*ku + i) * a_dim1], lda, &
c_b1, &work[1], &c__1);
i__2 = *m - i;
i__3 = *n - *ku - i + 1;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__2, &i__3, &q__1, &work[1], &c__1, &a[i + (*ku + i)
* a_dim1], lda, &a[i + 1 + (*ku + i) * a_dim1], lda);
i__2 = i + (*ku + i) * a_dim1;
q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
/* Computing MIN */
i__2 = *m - 1 - *kl;
if (i <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i
) */
i__2 = *m - *kl - i + 1;
wn = scnrm2_(&i__2, &a[*kl + i + i * a_dim1], &c__1);
d__1 = wn / c_abs(&a[*kl + i + i * a_dim1]);
i__2 = *kl + i + i * a_dim1;
q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = *kl + i + i * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *m - *kl - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[*kl + i + 1 + i * a_dim1], &c__1);
i__2 = *kl + i + i * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply reflection to A(kl+i:m,i+1:n) from the l
eft */
i__2 = *m - *kl - i + 1;
i__3 = *n - i;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl + i
+ (i + 1) * a_dim1], lda, &a[*kl + i + i * a_dim1], &
c__1, &c_b1, &work[1], &c__1);
i__2 = *m - *kl - i + 1;
i__3 = *n - i;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__2, &i__3, &q__1, &a[*kl + i + i * a_dim1], &c__1, &
work[1], &c__1, &a[*kl + i + (i + 1) * a_dim1], lda);
i__2 = *kl + i + i * a_dim1;
q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
}
i__2 = *m;
for (j = *kl + i + 1; j <= i__2; ++j) {
i__3 = j + i * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L50: */
}
i__2 = *n;
for (j = *ku + i + 1; j <= i__2; ++j) {
i__3 = i + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L60: */
}
/* L70: */
}
return 0;
/* End of CLAGGE */
} /* clagge_slu */
void
cgscon(char *norm, SuperMatrix *L, SuperMatrix *U,
float anorm, float *rcond, SuperLUStat_t *stat, int *info)
{
/* Local variables */
int kase, kase1, onenrm, i;
float ainvnm;
complex *work;
int isave[3];
extern int crscl_(int *, complex *, complex *, int *);
extern int clacon2_(int *, complex *, complex *, float *, int *, int []);
/* Test the input parameters. */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || strncmp(norm, "O", 1)==0;
if (! onenrm && ! strncmp(norm, "I", 1)==0) *info = -1;
else if (L->nrow < 0 || L->nrow != L->ncol ||
L->Stype != SLU_SC || L->Dtype != SLU_C || L->Mtype != SLU_TRLU)
*info = -2;
else if (U->nrow < 0 || U->nrow != U->ncol ||
U->Stype != SLU_NC || U->Dtype != SLU_C || U->Mtype != SLU_TRU)
*info = -3;
if (*info != 0) {
i = -(*info);
input_error("cgscon", &i);
return;
}
/* Quick return if possible */
*rcond = 0.;
if ( L->nrow == 0 || U->nrow == 0) {
*rcond = 1.;
return;
}
work = complexCalloc( 3*L->nrow );
if ( !work )
ABORT("Malloc fails for work arrays in cgscon.");
/* Estimate the norm of inv(A). */
ainvnm = 0.;
if ( onenrm ) kase1 = 1;
else kase1 = 2;
kase = 0;
do {
clacon2_(&L->nrow, &work[L->nrow], &work[0], &ainvnm, &kase, isave);
if (kase == 0) break;
if (kase == kase1) {
/* Multiply by inv(L). */
sp_ctrsv("L", "No trans", "Unit", L, U, &work[0], stat, info);
/* Multiply by inv(U). */
sp_ctrsv("U", "No trans", "Non-unit", L, U, &work[0], stat, info);
} else {
/* Multiply by inv(U'). */
sp_ctrsv("U", "Transpose", "Non-unit", L, U, &work[0], stat, info);
/* Multiply by inv(L'). */
sp_ctrsv("L", "Transpose", "Unit", L, U, &work[0], stat, info);
}
} while ( kase != 0 );
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.) *rcond = (1. / ainvnm) / anorm;
SUPERLU_FREE (work);
return;
} /* cgscon */
int
__vfscanf (FILE *s, const char *format, va_list argptr)
#endif
{
va_list arg = (va_list) argptr;
register const char *f = format;
register unsigned char fc; /* Current character of the format. */
register size_t done = 0; /* Assignments done. */
register size_t read_in = 0; /* Chars read in. */
register int c = 0; /* Last char read. */
register int width; /* Maximum field width. */
register int flags; /* Modifiers for current format element. */
/* Status for reading F-P nums. */
char got_dot, got_e, negative;
/* If a [...] is a [^...]. */
char not_in;
/* Base for integral numbers. */
int base;
/* Signedness for integral numbers. */
int number_signed;
/* Decimal point character. */
wchar_t decimal;
/* The thousands character of the current locale. */
wchar_t thousands;
/* Integral holding variables. */
union
{
long long int q;
unsigned long long int uq;
long int l;
unsigned long int ul;
} num;
/* Character-buffer pointer. */
char *str = NULL;
wchar_t *wstr = NULL;
char **strptr = NULL;
size_t strsize = 0;
/* We must not react on white spaces immediately because they can
possibly be matched even if in the input stream no character is
available anymore. */
int skip_space = 0;
/* Workspace. */
char *tw; /* Temporary pointer. */
char *wp = NULL; /* Workspace. */
size_t wpmax = 0; /* Maximal size of workspace. */
size_t wpsize; /* Currently used bytes in workspace. */
#define ADDW(Ch) \
do \
{ \
if (wpsize == wpmax) \
{ \
char *old = wp; \
wpmax = UCHAR_MAX > 2 * wpmax ? UCHAR_MAX : 2 * wpmax; \
wp = (char *) alloca (wpmax); \
if (old != NULL) \
memcpy (wp, old, wpsize); \
} \
wp[wpsize++] = (Ch); \
} \
while (0)
ARGCHECK (s, format);
/* Figure out the decimal point character. */
if (mbtowc (&decimal, _NL_CURRENT (LC_NUMERIC, DECIMAL_POINT),
strlen (_NL_CURRENT (LC_NUMERIC, DECIMAL_POINT))) <= 0)
decimal = (wchar_t) *_NL_CURRENT (LC_NUMERIC, DECIMAL_POINT);
/* Figure out the thousands separator character. */
if (mbtowc (&thousands, _NL_CURRENT (LC_NUMERIC, THOUSANDS_SEP),
strlen (_NL_CURRENT (LC_NUMERIC, THOUSANDS_SEP))) <= 0)
thousands = (wchar_t) *_NL_CURRENT (LC_NUMERIC, THOUSANDS_SEP);
/* Lock the stream. */
LOCK_STREAM (s);
/* Run through the format string. */
while (*f != '\0')
{
unsigned int argpos;
/* Extract the next argument, which is of type TYPE.
For a %N$... spec, this is the Nth argument from the beginning;
otherwise it is the next argument after the state now in ARG. */
#if 0
/* XXX Possible optimization. */
# define ARG(type) (argpos == 0 ? va_arg (arg, type) : \
({ va_list arg = (va_list) argptr; \
arg = (va_list) ((char *) arg \
+ (argpos - 1) \
* __va_rounded_size (void *)); \
va_arg (arg, type); \
}))
#else
# define ARG(type) (argpos == 0 ? va_arg (arg, type) : \
({ unsigned int pos = argpos; \
va_list arg = (va_list) argptr; \
while (--pos > 0) \
(void) va_arg (arg, void *); \
va_arg (arg, type); \
}))
#endif
if (!isascii (*f))
{
/* Non-ASCII, may be a multibyte. */
int len = mblen (f, strlen (f));
if (len > 0)
{
do
{
c = inchar ();
if (c == EOF)
input_error ();
else if (c != *f++)
{
ungetc (c, s);
conv_error ();
}
}
while (--len > 0);
continue;
}
}
fc = *f++;
if (fc != '%')
{
/* Remember to skip spaces. */
if (isspace (fc))
{
skip_space = 1;
continue;
}
/* Read a character. */
c = inchar ();
/* Characters other than format specs must just match. */
if (c == EOF)
input_error ();
/* We saw white space char as the last character in the format
string. Now it's time to skip all leading white space. */
if (skip_space)
{
while (isspace (c))
if (inchar () == EOF && errno == EINTR)
conv_error ();
skip_space = 0;
}
if (c != fc)
{
ungetc (c, s);
conv_error ();
}
continue;
}
/* This is the start of the conversion string. */
flags = 0;
/* Initialize state of modifiers. */
argpos = 0;
/* Prepare temporary buffer. */
wpsize = 0;
/* Check for a positional parameter specification. */
if (isdigit (*f))
{
argpos = *f++ - '0';
while (isdigit (*f))
argpos = argpos * 10 + (*f++ - '0');
if (*f == '$')
++f;
else
{
/* Oops; that was actually the field width. */
width = argpos;
flags |= WIDTH;
argpos = 0;
goto got_width;
}
}
/* Check for the assignment-suppressing and the number grouping flag. */
while (*f == '*' || *f == '\'')
switch (*f++)
{
case '*':
flags |= SUPPRESS;
break;
case '\'':
flags |= GROUP;
break;
}
/* We have seen width. */
if (isdigit (*f))
flags |= WIDTH;
/* Find the maximum field width. */
width = 0;
while (isdigit (*f))
{
width *= 10;
width += *f++ - '0';
}
got_width:
if (width == 0)
width = -1;
/* Check for type modifiers. */
while (*f == 'h' || *f == 'l' || *f == 'L' || *f == 'a' || *f == 'q')
switch (*f++)
{
case 'h':
/* int's are short int's. */
if (flags & TYPEMOD)
/* Signal illegal format element. */
conv_error ();
flags |= SHORT;
break;
case 'l':
if (flags & (SHORT|LONGDBL))
conv_error ();
else if (flags & LONG)
{
/* A double `l' is equivalent to an `L'. */
flags &= ~LONG;
flags |= LONGDBL;
}
else
/* int's are long int's. */
flags |= LONG;
break;
case 'q':
case 'L':
/* double's are long double's, and int's are long long int's. */
if (flags & TYPEMOD)
/* Signal illegal format element. */
conv_error ();
flags |= LONGDBL;
break;
case 'a':
if (flags & TYPEMOD)
/* Signal illegal format element. */
conv_error ();
/* String conversions (%s, %[) take a `char **'
arg and fill it in with a malloc'd pointer. */
flags |= MALLOC;
break;
}
/* End of the format string? */
if (*f == '\0')
conv_error ();
/* We must take care for EINTR errors. */
if (c == EOF && errno == EINTR)
input_error ();
/* Find the conversion specifier. */
fc = *f++;
if (skip_space || (fc != '[' && fc != 'c' && fc != 'C' && fc != 'n'))
{
/* Eat whitespace. */
do
if (inchar () == EOF && errno == EINTR)
input_error ();
while (isspace (c));
ungetc (c, s);
skip_space = 0;
}
switch (fc)
{
case '%': /* Must match a literal '%'. */
c = inchar ();
if (c != fc)
{
ungetc (c, s);
conv_error ();
}
break;
case 'n': /* Answer number of assignments done. */
/* Corrigendum 1 to ISO C 1990 describes the allowed flags
with the 'n' conversion specifier. */
if (!(flags & SUPPRESS))
{
/* Don't count the read-ahead. */
if (flags & LONGDBL)
*ARG (long long int *) = read_in;
else if (flags & LONG)
*ARG (long int *) = read_in;
else if (flags & SHORT)
*ARG (short int *) = read_in;
else
*ARG (int *) = read_in;
#ifdef NO_BUG_IN_ISO_C_CORRIGENDUM_1
/* We have a severe problem here. The ISO C standard
contradicts itself in explaining the effect of the %n
format in `scanf'. While in ISO C:1990 and the ISO C
Amendement 1:1995 the result is described as
Execution of a %n directive does not effect the
assignment count returned at the completion of
execution of the f(w)scanf function.
in ISO C Corrigendum 1:1994 the following was added:
Subclause 7.9.6.2
Add the following fourth example:
In:
#include <stdio.h>
int d1, d2, n1, n2, i;
i = sscanf("123", "%d%n%n%d", &d1, &n1, &n2, &d2);
the value 123 is assigned to d1 and the value3 to n1.
Because %n can never get an input failure the value
of 3 is also assigned to n2. The value of d2 is not
affected. The value 3 is assigned to i.
We go for now with the historically correct code fro ISO C,
i.e., we don't count the %n assignments. When it ever
should proof to be wrong just remove the #ifdef above. */
++done;
#endif
}
break;
case 'c': /* Match characters. */
if ((flags & LONG) == 0)
{
if (!(flags & SUPPRESS))
{
str = ARG (char *);
if (str == NULL)
conv_error ();
}
c = inchar ();
if (c == EOF)
input_error ();
if (width == -1)
width = 1;
if (!(flags & SUPPRESS))
{
do
*str++ = c;
while (--width > 0 && inchar () != EOF);
}
else
while (--width > 0 && inchar () != EOF);
if (width > 0)
/* I.e., EOF was read. */
--read_in;
if (!(flags & SUPPRESS))
++done;
break;
}
/* FALLTHROUGH */
case 'C':
/* Get UTF-8 encoded wide character. Here we assume (as in
other parts of the libc) that we only have to handle
UTF-8. */
{
wint_t val;
size_t cnt = 0;
int first = 1;
if (!(flags & SUPPRESS))
{
wstr = ARG (wchar_t *);
if (str == NULL)
conv_error ();
}
do
{
#define NEXT_WIDE_CHAR(First) \
c = inchar (); \
if (c == EOF) \
/* EOF is only an error for the first character. */ \
if (First) \
input_error (); \
else \
{ \
--read_in; \
break; \
} \
val = c; \
if (val >= 0x80) \
{ \
if ((c & 0xc0) == 0x80 || (c & 0xfe) == 0xfe) \
encode_error (); \
if ((c & 0xe0) == 0xc0) \
{ \
/* We expect two bytes. */ \
cnt = 1; \
val &= 0x1f; \
} \
else if ((c & 0xf0) == 0xe0) \
{ \
/* We expect three bytes. */ \
cnt = 2; \
val &= 0x0f; \
} \
else if ((c & 0xf8) == 0xf0) \
{ \
/* We expect four bytes. */ \
cnt = 3; \
val &= 0x07; \
} \
else if ((c & 0xfc) == 0xf8) \
{ \
/* We expect five bytes. */ \
cnt = 4; \
val &= 0x03; \
} \
else \
{ \
/* We expect six bytes. */ \
cnt = 5; \
val &= 0x01; \
} \
\
do \
{ \
c = inchar (); \
if (c == EOF \
|| (c & 0xc0) == 0x80 || (c & 0xfe) == 0xfe) \
encode_error (); \
val <<= 6; \
val |= c & 0x3f; \
} \
while (--cnt > 0); \
} \
\
if (!(flags & SUPPRESS)) \
*wstr++ = val; \
first = 0
NEXT_WIDE_CHAR (first);
}
while (--width > 0);
if (width > 0)
/* I.e., EOF was read. */
--read_in;
if (!(flags & SUPPRESS))
++done;
}
break;
case 's': /* Read a string. */
if (flags & LONG)
/* We have to process a wide character string. */
goto wide_char_string;
#define STRING_ARG(Str, Type) \
if (!(flags & SUPPRESS)) \
{ \
if (flags & MALLOC) \
{ \
/* The string is to be stored in a malloc'd buffer. */ \
strptr = ARG (char **); \
if (strptr == NULL) \
conv_error (); \
/* Allocate an initial buffer. */ \
strsize = 100; \
*strptr = malloc (strsize * sizeof (Type)); \
Str = (Type *) *strptr; \
} \
else \
Str = ARG (Type *); \
if (Str == NULL) \
conv_error (); \
}
STRING_ARG (str, char);
c = inchar ();
if (c == EOF)
input_error ();
do
{
if (isspace (c))
{
ungetc (c, s);
break;
}
#define STRING_ADD_CHAR(Str, c, Type) \
if (!(flags & SUPPRESS)) \
{ \
*Str++ = c; \
if ((flags & MALLOC) && (char *) Str == *strptr + strsize) \
{ \
/* Enlarge the buffer. */ \
Str = realloc (*strptr, strsize * 2 * sizeof (Type)); \
if (Str == NULL) \
{ \
/* Can't allocate that much. Last-ditch effort. */\
Str = realloc (*strptr, \
(strsize + 1) * sizeof (Type)); \
if (Str == NULL) \
{ \
/* We lose. Oh well. \
Terminate the string and stop converting, \
so at least we don't skip any input. */ \
((Type *) (*strptr))[strsize] = '\0'; \
++done; \
conv_error (); \
} \
else \
{ \
*strptr = (char *) Str; \
Str = ((Type *) *strptr) + strsize; \
++strsize; \
} \
} \
else \
{ \
*strptr = (char *) Str; \
Str = ((Type *) *strptr) + strsize; \
strsize *= 2; \
} \
} \
}
STRING_ADD_CHAR (str, c, char);
} while ((width <= 0 || --width > 0) && inchar () != EOF);
if (c == EOF)
--read_in;
if (!(flags & SUPPRESS))
{
*str = '\0';
++done;
}
break;
case 'S':
/* Wide character string. */
wide_char_string:
{
wint_t val;
int first = 1;
STRING_ARG (wstr, wchar_t);
do
{
size_t cnt = 0;
NEXT_WIDE_CHAR (first);
if (iswspace (val))
{
/* XXX We would have to push back the whole wide char
with possibly many bytes. But since scanf does
not make a difference for white space characters
we can simply push back a simple <SP> which is
guaranteed to be in the [:space:] class. */
ungetc (' ', s);
break;
}
STRING_ADD_CHAR (wstr, val, wchar_t);
first = 0;
}
while (width <= 0 || --width > 0);
if (!(flags & SUPPRESS))
{
*wstr = L'\0';
++done;
}
}
break;
case 'x': /* Hexadecimal integer. */
case 'X': /* Ditto. */
base = 16;
number_signed = 0;
goto number;
case 'o': /* Octal integer. */
base = 8;
number_signed = 0;
goto number;
case 'u': /* Unsigned decimal integer. */
base = 10;
number_signed = 0;
goto number;
case 'd': /* Signed decimal integer. */
base = 10;
number_signed = 1;
goto number;
case 'i': /* Generic number. */
base = 0;
number_signed = 1;
number:
c = inchar ();
if (c == EOF)
input_error ();
/* Check for a sign. */
if (c == '-' || c == '+')
{
ADDW (c);
if (width > 0)
--width;
c = inchar ();
}
/* Look for a leading indication of base. */
if (width != 0 && c == '0')
{
if (width > 0)
--width;
ADDW (c);
c = inchar ();
if (width != 0 && tolower (c) == 'x')
{
if (base == 0)
base = 16;
if (base == 16)
{
if (width > 0)
--width;
c = inchar ();
}
}
else if (base == 0)
base = 8;
}
if (base == 0)
base = 10;
/* Read the number into workspace. */
while (c != EOF && width != 0)
{
if (base == 16 ? !isxdigit (c) :
((!isdigit (c) || c - '0' >= base) &&
!((flags & GROUP) && base == 10 && c == thousands)))
break;
ADDW (c);
if (width > 0)
--width;
c = inchar ();
}
/* The just read character is not part of the number anymore. */
ungetc (c, s);
if (wpsize == 0 ||
(wpsize == 1 && (wp[0] == '+' || wp[0] == '-')))
/* There was no number. */
conv_error ();
/* Convert the number. */
ADDW ('\0');
if (flags & LONGDBL)
{
if (number_signed)
num.q = __strtoq_internal (wp, &tw, base, flags & GROUP);
else
num.uq = __strtouq_internal (wp, &tw, base, flags & GROUP);
}
else
{
if (number_signed)
num.l = __strtol_internal (wp, &tw, base, flags & GROUP);
else
num.ul = __strtoul_internal (wp, &tw, base, flags & GROUP);
}
if (wp == tw)
conv_error ();
if (!(flags & SUPPRESS))
{
if (! number_signed)
{
if (flags & LONGDBL)
*ARG (unsigned LONGLONG int *) = num.uq;
else if (flags & LONG)
*ARG (unsigned long int *) = num.ul;
else if (flags & SHORT)
*ARG (unsigned short int *)
= (unsigned short int) num.ul;
else
*ARG (unsigned int *) = (unsigned int) num.ul;
}
else
{
if (flags & LONGDBL)
*ARG (LONGLONG int *) = num.q;
else if (flags & LONG)
*ARG (long int *) = num.l;
else if (flags & SHORT)
*ARG (short int *) = (short int) num.l;
else
*ARG (int *) = (int) num.l;
}
++done;
}
break;
case 'e': /* Floating-point numbers. */
case 'E':
case 'f':
case 'g':
case 'G':
c = inchar ();
if (c == EOF)
input_error ();
/* Check for a sign. */
if (c == '-' || c == '+')
{
negative = c == '-';
if (inchar () == EOF)
/* EOF is only an input error before we read any chars. */
conv_error ();
if (width > 0)
--width;
}
else
negative = 0;
got_dot = got_e = 0;
do
{
if (isdigit (c))
ADDW (c);
else if (got_e && wp[wpsize - 1] == 'e'
&& (c == '-' || c == '+'))
ADDW (c);
else if (wpsize > 0 && !got_e && tolower (c) == 'e')
{
ADDW ('e');
got_e = got_dot = 1;
}
else if (c == decimal && !got_dot)
{
ADDW (c);
got_dot = 1;
}
else if ((flags & GROUP) && c == thousands && !got_dot)
ADDW (c);
else
break;
if (width > 0)
--width;
}
while (inchar () != EOF && width != 0);
/* The last read character is not part of the number anymore. */
ungetc (c, s);
if (wpsize == 0)
conv_error ();
/* Convert the number. */
ADDW ('\0');
if (flags & LONGDBL)
{
long double d = __strtold_internal (wp, &tw, flags & GROUP);
if (!(flags & SUPPRESS) && tw != wp)
*ARG (long double *) = negative ? -d : d;
}
else if (flags & LONG)
{
double d = __strtod_internal (wp, &tw, flags & GROUP);
if (!(flags & SUPPRESS) && tw != wp)
*ARG (double *) = negative ? -d : d;
}
else
{
float d = __strtof_internal (wp, &tw, flags & GROUP);
if (!(flags & SUPPRESS) && tw != wp)
*ARG (float *) = negative ? -d : d;
}
if (tw == wp)
conv_error ();
if (!(flags & SUPPRESS))
++done;
break;
case '[': /* Character class. */
if (flags & LONG)
{
STRING_ARG (wstr, wchar_t);
c = '\0'; /* This is to keep gcc quiet. */
}
else
{
STRING_ARG (str, char);
c = inchar ();
if (c == EOF)
input_error ();
}
if (*f == '^')
{
++f;
not_in = 1;
}
else
not_in = 0;
/* Fill WP with byte flags indexed by character.
We will use this flag map for matching input characters. */
if (wpmax < UCHAR_MAX)
{
wpmax = UCHAR_MAX;
wp = (char *) alloca (wpmax);
}
memset (wp, 0, UCHAR_MAX);
fc = *f;
if (fc == ']' || fc == '-')
{
/* If ] or - appears before any char in the set, it is not
the terminator or separator, but the first char in the
set. */
wp[fc] = 1;
++f;
}
while ((fc = *f++) != '\0' && fc != ']')
{
if (fc == '-' && *f != '\0' && *f != ']' &&
(unsigned char) f[-2] <= (unsigned char) *f)
{
/* Add all characters from the one before the '-'
up to (but not including) the next format char. */
for (fc = f[-2]; fc < *f; ++fc)
wp[fc] = 1;
}
else
/* Add the character to the flag map. */
wp[fc] = 1;
}
if (fc == '\0')
{
if (!(flags & LONG))
ungetc (c, s);
conv_error();
}
if (flags & LONG)
{
wint_t val;
int first = 1;
do
{
size_t cnt = 0;
NEXT_WIDE_CHAR (first);
if (val > 255 || wp[val] == not_in)
{
/* XXX We have a problem here. We read a wide
character and this possibly took several
bytes. But we can only push back one single
character. To be sure we don't create wrong
input we push it back only in case it is
representable within one byte. */
if (val < 0x80)
ungetc (val, s);
break;
}
STRING_ADD_CHAR (wstr, val, wchar_t);
if (width > 0)
--width;
first = 0;
}
while (width != 0);
if (first)
conv_error ();
if (!(flags & SUPPRESS))
{
*wstr = L'\0';
++done;
}
}
else
{
num.ul = read_in - 1; /* -1 because we already read one char. */
do
{
if (wp[c] == not_in)
{
ungetc (c, s);
break;
}
STRING_ADD_CHAR (str, c, char);
if (width > 0)
--width;
}
while (width != 0 && inchar () != EOF);
if (read_in == num.ul)
conv_error ();
if (!(flags & SUPPRESS))
{
*str = '\0';
++done;
}
}
break;
case 'p': /* Generic pointer. */
base = 16;
/* A PTR must be the same size as a `long int'. */
flags &= ~(SHORT|LONGDBL);
flags |= LONG;
number_signed = 0;
goto number;
}
/* Subroutine */ int claror_slu(char *side, char *init, integer *m, integer *n,
complex *a, integer *lda, integer *iseed, complex *x, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1, q__2;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static integer kbeg, jcol;
static real xabs;
static integer irow, j;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cscal_(integer *, complex *, complex *, integer *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
static complex csign;
static integer ixfrm, itype, nxfrm;
static real xnorm;
extern real scnrm2_(integer *, complex *, integer *);
extern /* Subroutine */ int clacgv_slu(integer *, complex *, integer *);
extern /* Complex */ VOID clarnd_slu(complex *, integer *, integer *);
extern /* Subroutine */ int claset_slu(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
extern int input_error(char *, int *);
static real factor;
static complex xnorms;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAROR pre- or post-multiplies an M by N matrix A by a random
unitary matrix U, overwriting A. A may optionally be
initialized to the identity matrix before multiplying by U.
U is generated using the method of G.W. Stewart
( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ).
(BLAS-2 version)
Arguments
=========
SIDE - CHARACTER*1
SIDE specifies whether A is multiplied on the left or right
by U.
SIDE = 'L' Multiply A on the left (premultiply) by U
SIDE = 'R' Multiply A on the right (postmultiply) by U*
SIDE = 'C' Multiply A on the left by U and the right by U*
SIDE = 'T' Multiply A on the left by U and the right by U'
Not modified.
INIT - CHARACTER*1
INIT specifies whether or not A should be initialized to
the identity matrix.
INIT = 'I' Initialize A to (a section of) the
identity matrix before applying U.
INIT = 'N' No initialization. Apply U to the
input matrix A.
INIT = 'I' may be used to generate square (i.e., unitary)
or rectangular orthogonal matrices (orthogonality being
in the sense of CDOTC):
For square matrices, M=N, and SIDE many be either 'L' or
'R'; the rows will be orthogonal to each other, as will the
columns.
For rectangular matrices where M < N, SIDE = 'R' will
produce a dense matrix whose rows will be orthogonal and
whose columns will not, while SIDE = 'L' will produce a
matrix whose rows will be orthogonal, and whose first M
columns will be orthogonal, the remaining columns being
zero.
For matrices where M > N, just use the previous
explaination, interchanging 'L' and 'R' and "rows" and
"columns".
Not modified.
M - INTEGER
Number of rows of A. Not modified.
N - INTEGER
Number of columns of A. Not modified.
A - COMPLEX array, dimension ( LDA, N )
Input and output array. Overwritten by U A ( if SIDE = 'L' )
or by A U ( if SIDE = 'R' )
or by U A U* ( if SIDE = 'C')
or by U A U' ( if SIDE = 'T') on exit.
LDA - INTEGER
Leading dimension of A. Must be at least MAX ( 1, M ).
Not modified.
ISEED - INTEGER array, dimension ( 4 )
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to CLAROR to continue the same random number
sequence.
Modified.
X - COMPLEX array, dimension ( 3*MAX( M, N ) )
Workspace. Of length:
2*M + N if SIDE = 'L',
2*N + M if SIDE = 'R',
3*N if SIDE = 'C' or 'T'.
Modified.
INFO - INTEGER
An error flag. It is set to:
0 if no error.
1 if CLARND returned a bad random number (installation
problem)
-1 if SIDE is not L, R, C, or T.
-3 if M is negative.
-4 if N is negative or if SIDE is C or T and N is not equal
to M.
-6 if LDA is less than M.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--x;
/* Function Body */
if (*n == 0 || *m == 0) {
return 0;
}
itype = 0;
if (strncmp(side, "L", 1)==0) {
itype = 1;
} else if (strncmp(side, "R", 1)==0) {
itype = 2;
} else if (strncmp(side, "C", 1)==0) {
itype = 3;
} else if (strncmp(side, "T", 1)==0) {
itype = 4;
}
/* Check for argument errors. */
*info = 0;
if (itype == 0) {
*info = -1;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0 || itype == 3 && *n != *m) {
*info = -4;
} else if (*lda < *m) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
input_error("CLAROR", &i__1);
return 0;
}
if (itype == 1) {
nxfrm = *m;
} else {
nxfrm = *n;
}
/* Initialize A to the identity matrix if desired */
if (strncmp(init, "I", 1)==0) {
claset_slu("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda);
}
/* If no rotation possible, still multiply by
a random complex number from the circle |x| = 1
2) Compute Rotation by computing Householder
Transformations H(2), H(3), ..., H(n). Note that the
order in which they are computed is irrelevant. */
i__1 = nxfrm;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
x[i__2].r = 0.f, x[i__2].i = 0.f;
/* L40: */
}
i__1 = nxfrm;
for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
kbeg = nxfrm - ixfrm + 1;
/* Generate independent normal( 0, 1 ) random numbers */
i__2 = nxfrm;
for (j = kbeg; j <= i__2; ++j) {
i__3 = j;
clarnd_slu(&q__1, &c__3, &iseed[1]);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L50: */
}
/* Generate a Householder transformation from the random vector
X */
xnorm = scnrm2_(&ixfrm, &x[kbeg], &c__1);
xabs = c_abs(&x[kbeg]);
if (xabs != 0.f) {
i__2 = kbeg;
q__1.r = x[i__2].r / xabs, q__1.i = x[i__2].i / xabs;
csign.r = q__1.r, csign.i = q__1.i;
} else {
csign.r = 1.f, csign.i = 0.f;
}
q__1.r = xnorm * csign.r, q__1.i = xnorm * csign.i;
xnorms.r = q__1.r, xnorms.i = q__1.i;
i__2 = nxfrm + kbeg;
q__1.r = -(doublereal)csign.r, q__1.i = -(doublereal)csign.i;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
factor = xnorm * (xnorm + xabs);
if (dabs(factor) < 1e-20f) {
*info = 1;
i__2 = -(*info);
input_error("CLAROR", &i__2);
return 0;
} else {
factor = 1.f / factor;
}
i__2 = kbeg;
i__3 = kbeg;
q__1.r = x[i__3].r + xnorms.r, q__1.i = x[i__3].i + xnorms.i;
x[i__2].r = q__1.r, x[i__2].i = q__1.i;
/* Apply Householder transformation to A */
if (itype == 1 || itype == 3 || itype == 4) {
/* Apply H(k) on the left of A */
cgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], &
c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
q__2.r = factor, q__2.i = 0.f;
q__1.r = -(doublereal)q__2.r, q__1.i = -(doublereal)q__2.i;
cgerc_(&ixfrm, n, &q__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
c__1, &a[kbeg + a_dim1], lda);
}
if (itype >= 2 && itype <= 4) {
/* Apply H(k)* (or H(k)') on the right of A */
if (itype == 4) {
clacgv_slu(&ixfrm, &x[kbeg], &c__1);
}
cgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg]
, &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
q__2.r = factor, q__2.i = 0.f;
q__1.r = -(doublereal)q__2.r, q__1.i = -(doublereal)q__2.i;
cgerc_(m, &ixfrm, &q__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
c__1, &a[kbeg * a_dim1 + 1], lda);
}
/* L60: */
}
clarnd_slu(&q__1, &c__3, &iseed[1]);
x[1].r = q__1.r, x[1].i = q__1.i;
xabs = c_abs(&x[1]);
if (xabs != 0.f) {
q__1.r = x[1].r / xabs, q__1.i = x[1].i / xabs;
csign.r = q__1.r, csign.i = q__1.i;
} else {
csign.r = 1.f, csign.i = 0.f;
}
i__1 = nxfrm << 1;
x[i__1].r = csign.r, x[i__1].i = csign.i;
/* Scale the matrix A by D. */
if (itype == 1 || itype == 3 || itype == 4) {
i__1 = *m;
for (irow = 1; irow <= i__1; ++irow) {
r_cnjg(&q__1, &x[nxfrm + irow]);
cscal_(n, &q__1, &a[irow + a_dim1], lda);
/* L70: */
}
}
if (itype == 2 || itype == 3) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
cscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
/* L80: */
}
}
if (itype == 4) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
r_cnjg(&q__1, &x[nxfrm + jcol]);
cscal_(m, &q__1, &a[jcol * a_dim1 + 1], &c__1);
/* L90: */
}
}
return 0;
/* End of CLAROR */
} /* claror_slu */
/* Subroutine */ int claghe_slu(integer *n, integer *k, real *d, complex *a,
integer *lda, integer *iseed, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
/* Local variables */
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *);
static integer i, j;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *);
static complex alpha;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), chemv_(char *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
extern real scnrm2_(integer *, complex *, integer *);
static complex wa, wb;
static real wn;
extern /* Subroutine */ int clarnv_slu(integer *, integer *, integer *, complex *);
extern int input_error(char *, int *);
static complex tau;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAGHE generates a complex hermitian matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random unitary matrix:
A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
unitary transformations.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
K (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= K <= N-1.
D (input) REAL array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) COMPLEX array, dimension (LDA,N)
The generated n by n hermitian matrix A (the full matrix is
stored).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) COMPLEX array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
input_error("CLAGHE", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = i + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
i__2 = i + i * a_dim1;
i__3 = i;
a[i__2].r = d[i__3], a[i__2].i = 0.f;
/* L30: */
}
/* Generate lower triangle of hermitian matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
clarnv_slu(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
d__1 = wn / c_abs(&work[1]);
q__1.r = d__1 * work[1].r, q__1.i = d__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * u */
i__1 = *n - i + 1;
chemv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b1, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__1 = *n - i + 1;
cdotc_(&q__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__1 = *n - i + 1;
caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
i__1 = *n - i + 1;
q__1.r = -1.f, q__1.i = 0.f;
cher2_("Lower", &i__1, &q__1, &work[1], &c__1, &work[*n + 1], &c__1, &
a[i + i * a_dim1], lda);
/* L40: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i = 1; i <= i__1; ++i) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i + 1;
wn = scnrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
d__1 = wn / c_abs(&a[*k + i + i * a_dim1]);
i__2 = *k + i + i * a_dim1;
q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = *k + i + i * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *n - *k - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[*k + i + 1 + i * a_dim1], &c__1);
i__2 = *k + i + i * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i + (i + 1)
* a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b1, &work[
1], &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__2, &i__3, &q__1, &a[*k + i + i * a_dim1], &c__1, &work[1],
&c__1, &a[*k + i + (i + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the rig
ht
compute y := tau * A * u */
i__2 = *n - *k - i + 1;
chemv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__2 = *n - *k - i + 1;
cdotc_(&q__4, &i__2, &work[1], &c__1, &a[*k + i + i * a_dim1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - *k - i + 1;
caxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i + 1;
q__1.r = -1.f, q__1.i = 0.f;
cher2_("Lower", &i__2, &q__1, &a[*k + i + i * a_dim1], &c__1, &work[1]
, &c__1, &a[*k + i + (*k + i) * a_dim1], lda);
i__2 = *k + i + i * a_dim1;
q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
i__3 = j + i * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L50: */
}
/* L60: */
}
/* Store full hermitian matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = j + i * a_dim1;
r_cnjg(&q__1, &a[i + j * a_dim1]);
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of CLAGHE */
} /* claghe_slu */
/*! \brief Solves one of the systems of equations A*x = b, or A'*x = b
*
* <pre>
* Purpose
* =======
*
* sp_ztrsv() solves one of the systems of equations
* A*x = b, or A'*x = b,
* where b and x are n element vectors and A is a sparse unit , or
* non-unit, upper or lower triangular matrix.
* No test for singularity or near-singularity is included in this
* routine. Such tests must be performed before calling this routine.
*
* Parameters
* ==========
*
* uplo - (input) char*
* On entry, uplo specifies whether the matrix is an upper or
* lower triangular matrix as follows:
* uplo = 'U' or 'u' A is an upper triangular matrix.
* uplo = 'L' or 'l' A is a lower triangular matrix.
*
* trans - (input) char*
* On entry, trans specifies the equations to be solved as
* follows:
* trans = 'N' or 'n' A*x = b.
* trans = 'T' or 't' A'*x = b.
* trans = 'C' or 'c' A^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_Z, Mtype = TRLU.
*
* U - (input) SuperMatrix*
* The factor U from the factorization Pr*A*Pc=L*U.
* U has types: Stype = NC, Dtype = SLU_Z, Mtype = TRU.
*
* x - (input/output) doublecomplex*
* Before entry, the incremented array X must contain the n
* element right-hand side vector b. On exit, X is overwritten
* with the solution vector x.
*
* info - (output) int*
* If *info = -i, the i-th argument had an illegal value.
* </pre>
*/
int
sp_ztrsv(char *uplo, char *trans, char *diag, SuperMatrix *L,
SuperMatrix *U, doublecomplex *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;
doublecomplex *Lval, *Uval;
int incx = 1, incy = 1;
doublecomplex temp;
doublecomplex alpha = {1.0, 0.0}, beta = {1.0, 0.0};
doublecomplex comp_zero = {0.0, 0.0};
int nrow;
int fsupc, nsupr, nsupc, luptr, istart, irow;
int i, k, iptr, jcol;
doublecomplex *work;
flops_t solve_ops;
/* 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_ztrsv", &i);
return 0;
}
Lstore = L->Store;
Lval = Lstore->nzval;
Ustore = U->Store;
Uval = Ustore->nzval;
solve_ops = 0;
if ( !(work = doublecomplexCalloc(L->nrow)) )
ABORT("Malloc fails for work in sp_ztrsv().");
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 z_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;
zz_mult(&comp_zero, &x[fsupc], &Lval[luptr]);
z_sub(&x[irow], &x[irow], &comp_zero);
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
CGEMV(ftcs2, &nrow, &nsupc, &alpha, &Lval[luptr+nsupc],
&nsupr, &x[fsupc], &incx, &beta, &work[0], &incy);
#else
ztrsv_("L", "N", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
zgemv_("N", &nrow, &nsupc, &alpha, &Lval[luptr+nsupc],
&nsupr, &x[fsupc], &incx, &beta, &work[0], &incy);
#endif
#else
zlsolve ( nsupr, nsupc, &Lval[luptr], &x[fsupc]);
zmatvec ( nsupr, nsupr-nsupc, nsupc, &Lval[luptr+nsupc],
&x[fsupc], &work[0] );
#endif
iptr = istart + nsupc;
for (i = 0; i < nrow; ++i, ++iptr) {
irow = L_SUB(iptr);
z_sub(&x[irow], &x[irow], &work[i]); /* Scatter */
work[i] = comp_zero;
}
}
} /* for k ... */
} else {
/* Form x := inv(U)*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = Lstore->nsuper; k >= 0; k--) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
/* 1 z_div costs 10 flops */
solve_ops += 4 * nsupc * (nsupc + 1) + 10 * nsupc;
if ( nsupc == 1 ) {
z_div(&x[fsupc], &x[fsupc], &Lval[luptr]);
for (i = U_NZ_START(fsupc); i < U_NZ_START(fsupc+1); ++i) {
irow = U_SUB(i);
zz_mult(&comp_zero, &x[fsupc], &Uval[i]);
z_sub(&x[irow], &x[irow], &comp_zero);
}
} else {
#ifdef USE_VENDOR_BLAS
#ifdef _CRAY
CTRSV(ftcs3, ftcs2, ftcs2, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ztrsv_("U", "N", "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
#else
zusolve ( nsupr, nsupc, &Lval[luptr], &x[fsupc] );
#endif
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1);
i++) {
irow = U_SUB(i);
zz_mult(&comp_zero, &x[jcol], &Uval[i]);
z_sub(&x[irow], &x[irow], &comp_zero);
}
}
}
} /* for k ... */
}
} else 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);
zz_mult(&comp_zero, &x[irow], &Lval[i]);
z_sub(&x[jcol], &x[jcol], &comp_zero);
iptr++;
}
}
if ( nsupc > 1 ) {
solve_ops += 4 * nsupc * (nsupc - 1);
#ifdef _CRAY
ftcs1 = _cptofcd("L", strlen("L"));
ftcs2 = _cptofcd("T", strlen("T"));
ftcs3 = _cptofcd("U", strlen("U"));
CTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ztrsv_("L", "T", "U", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
}
} else {
/* Form x := inv(U')*x */
if ( U->nrow == 0 ) return 0; /* Quick return */
for (k = 0; k <= Lstore->nsuper; k++) {
fsupc = L_FST_SUPC(k);
nsupr = L_SUB_START(fsupc+1) - L_SUB_START(fsupc);
nsupc = L_FST_SUPC(k+1) - fsupc;
luptr = L_NZ_START(fsupc);
for (jcol = fsupc; jcol < L_FST_SUPC(k+1); jcol++) {
solve_ops += 8*(U_NZ_START(jcol+1) - U_NZ_START(jcol));
for (i = U_NZ_START(jcol); i < U_NZ_START(jcol+1); i++) {
irow = U_SUB(i);
zz_mult(&comp_zero, &x[irow], &Uval[i]);
z_sub(&x[jcol], &x[jcol], &comp_zero);
}
}
/* 1 z_div costs 10 flops */
solve_ops += 4 * nsupc * (nsupc + 1) + 10 * nsupc;
if ( nsupc == 1 ) {
z_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
ztrsv_("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);
zz_conj(&temp, &Lval[i]);
zz_mult(&comp_zero, &x[irow], &temp);
z_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"));
ZTRSV(ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ztrsv_("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);
zz_conj(&temp, &Uval[i]);
zz_mult(&comp_zero, &x[irow], &temp);
z_sub(&x[jcol], &x[jcol], &comp_zero);
}
}
/* 1 z_div costs 10 flops */
solve_ops += 4 * nsupc * (nsupc + 1) + 10 * nsupc;
if ( nsupc == 1 ) {
zz_conj(&temp, &Lval[luptr]);
z_div(&x[fsupc], &x[fsupc], &temp);
} else {
#ifdef _CRAY
ftcs1 = _cptofcd("U", strlen("U"));
ftcs2 = _cptofcd(trans, strlen("T"));
ftcs3 = _cptofcd("N", strlen("N"));
ZTRSV( ftcs1, ftcs2, ftcs3, &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#else
ztrsv_("U", trans, "N", &nsupc, &Lval[luptr], &nsupr,
&x[fsupc], &incx);
#endif
}
} /* for k ... */
}
}
stat->ops[SOLVE] += solve_ops;
SUPERLU_FREE(work);
return 0;
}
void
dgssv(superlu_options_t *options, SuperMatrix *A, int *perm_c, int *perm_r,
SuperMatrix *L, SuperMatrix *U, SuperMatrix *B,
SuperLUStat_t *stat, int *info )
{
DNformat *Bstore;
SuperMatrix *AA;/* A in SLU_NC format used by the factorization routine.*/
SuperMatrix AC; /* Matrix postmultiplied by Pc */
int lwork = 0, *etree, i;
GlobalLU_t Glu; /* Not needed on return. */
/* Set default values for some parameters */
int panel_size; /* panel size */
int relax; /* no of columns in a relaxed snodes */
int permc_spec;
trans_t trans = NOTRANS;
double *utime;
double t; /* Temporary time */
/* Test the input parameters ... */
*info = 0;
Bstore = B->Store;
if ( options->Fact != DOFACT ) *info = -1;
else if ( A->nrow != A->ncol || A->nrow < 0 ||
(A->Stype != SLU_NC && A->Stype != SLU_NR) ||
A->Dtype != SLU_D || A->Mtype != SLU_GE )
*info = -2;
else if ( B->ncol < 0 || Bstore->lda < SUPERLU_MAX(0, A->nrow) ||
B->Stype != SLU_DN || B->Dtype != SLU_D || B->Mtype != SLU_GE )
*info = -7;
if ( *info != 0 ) {
i = -(*info);
input_error("dgssv", &i);
return;
}
utime = stat->utime;
/* Convert A to SLU_NC format when necessary. */
if ( A->Stype == SLU_NR ) {
NRformat *Astore = A->Store;
AA = (SuperMatrix *) SUPERLU_MALLOC( sizeof(SuperMatrix) );
dCreate_CompCol_Matrix(AA, A->ncol, A->nrow, Astore->nnz,
Astore->nzval, Astore->colind, Astore->rowptr,
SLU_NC, A->Dtype, A->Mtype);
trans = TRANS;
} else {
if ( A->Stype == SLU_NC ) AA = A;
}
t = SuperLU_timer_();
/*
* Get column permutation vector perm_c[], according to permc_spec:
* permc_spec = NATURAL: natural ordering
* permc_spec = MMD_AT_PLUS_A: minimum degree on structure of A'+A
* permc_spec = MMD_ATA: minimum degree on structure of A'*A
* permc_spec = COLAMD: approximate minimum degree column ordering
* permc_spec = MY_PERMC: the ordering already supplied in perm_c[]
*/
permc_spec = options->ColPerm;
if ( permc_spec != MY_PERMC && options->Fact == DOFACT )
get_perm_c(permc_spec, AA, perm_c);
utime[COLPERM] = SuperLU_timer_() - t;
etree = intMalloc(A->ncol);
t = SuperLU_timer_();
sp_preorder(options, AA, perm_c, etree, &AC);
utime[ETREE] = SuperLU_timer_() - t;
panel_size = sp_ienv(1);
relax = sp_ienv(2);
/*printf("Factor PA = LU ... relax %d\tw %d\tmaxsuper %d\trowblk %d\n",
relax, panel_size, sp_ienv(3), sp_ienv(4));*/
t = SuperLU_timer_();
/* Compute the LU factorization of A. */
dgstrf(options, &AC, relax, panel_size, etree,
NULL, lwork, perm_c, perm_r, L, U, &Glu, stat, info);
utime[FACT] = SuperLU_timer_() - t;
t = SuperLU_timer_();
if ( *info == 0 ) {
/* Solve the system A*X=B, overwriting B with X. */
dgstrs (trans, L, U, perm_c, perm_r, B, stat, info);
}
utime[SOLVE] = SuperLU_timer_() - t;
SUPERLU_FREE (etree);
Destroy_CompCol_Permuted(&AC);
if ( A->Stype == SLU_NR ) {
Destroy_SuperMatrix_Store(AA);
SUPERLU_FREE(AA);
}
}
/*! \brief Performs one of the matrix-vector operations y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y
*
* <pre>
* Purpose
* =======
*
* sp_zgemv() performs one of the matrix-vector operations
* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
* where alpha and beta are scalars, x and y are vectors and A is a
* sparse A->nrow by A->ncol matrix.
*
* Parameters
* ==========
*
* TRANS - (input) char*
* On entry, TRANS specifies the operation to be performed as
* follows:
* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
* TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
* TRANS = 'C' or 'c' y := alpha*A^H*x + beta*y.
*
* ALPHA - (input) doublecomplex
* On entry, ALPHA specifies the scalar alpha.
*
* A - (input) SuperMatrix*
* Before entry, the leading m by n part of the array A must
* contain the matrix of coefficients.
*
* X - (input) doublecomplex*, array of DIMENSION at least
* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
* and at least
* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
* Before entry, the incremented array X must contain the
* vector x.
*
* INCX - (input) int
* On entry, INCX specifies the increment for the elements of
* X. INCX must not be zero.
*
* BETA - (input) doublecomplex
* On entry, BETA specifies the scalar beta. When BETA is
* supplied as zero then Y need not be set on input.
*
* Y - (output) doublecomplex*, array of DIMENSION at least
* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
* and at least
* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
* Before entry with BETA non-zero, the incremented array Y
* must contain the vector y. On exit, Y is overwritten by the
* updated vector y.
*
* INCY - (input) int
* On entry, INCY specifies the increment for the elements of
* Y. INCY must not be zero.
*
* ==== Sparse Level 2 Blas routine.
* </pre>
*/
int
sp_zgemv(char *trans, doublecomplex alpha, SuperMatrix *A, doublecomplex *x,
int incx, doublecomplex beta, doublecomplex *y, int incy)
{
/* Local variables */
NCformat *Astore;
doublecomplex *Aval;
int info;
doublecomplex temp, temp1;
int lenx, leny, i, j, irow;
int iy, jx, jy, kx, ky;
int notran;
doublecomplex comp_zero = {0.0, 0.0};
doublecomplex comp_one = {1.0, 0.0};
notran = ( strncmp(trans, "N", 1)==0 || strncmp(trans, "n", 1)==0 );
Astore = A->Store;
Aval = Astore->nzval;
/* Test the input parameters */
info = 0;
if ( !notran && strncmp(trans, "T", 1)!=0 && strncmp(trans, "C", 1)!=0)
info = 1;
else if ( A->nrow < 0 || A->ncol < 0 ) info = 3;
else if (incx == 0) info = 5;
else if (incy == 0) info = 8;
if (info != 0) {
input_error("sp_zgemv ", &info);
return 0;
}
/* Quick return if possible. */
if (A->nrow == 0 || A->ncol == 0 ||
z_eq(&alpha, &comp_zero) &&
z_eq(&beta, &comp_one))
return 0;
/* Set LENX and LENY, the lengths of the vectors x and y, and set
up the start points in X and Y. */
if ( notran ) {
lenx = A->ncol;
leny = A->nrow;
} else {
lenx = A->nrow;
leny = A->ncol;
}
if (incx > 0) kx = 0;
else kx = - (lenx - 1) * incx;
if (incy > 0) ky = 0;
else ky = - (leny - 1) * incy;
/* Start the operations. In this version the elements of A are
accessed sequentially with one pass through A. */
/* First form y := beta*y. */
if ( !z_eq(&beta, &comp_one) ) {
if (incy == 1) {
if ( z_eq(&beta, &comp_zero) )
for (i = 0; i < leny; ++i) y[i] = comp_zero;
else
for (i = 0; i < leny; ++i)
zz_mult(&y[i], &beta, &y[i]);
} else {
iy = ky;
if ( z_eq(&beta, &comp_zero) )
for (i = 0; i < leny; ++i) {
y[iy] = comp_zero;
iy += incy;
}
else
for (i = 0; i < leny; ++i) {
zz_mult(&y[iy], &beta, &y[iy]);
iy += incy;
}
}
}
if ( z_eq(&alpha, &comp_zero) ) return 0;
if ( notran ) {
/* Form y := alpha*A*x + y. */
jx = kx;
if (incy == 1) {
for (j = 0; j < A->ncol; ++j) {
if ( !z_eq(&x[jx], &comp_zero) ) {
zz_mult(&temp, &alpha, &x[jx]);
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
zz_mult(&temp1, &temp, &Aval[i]);
z_add(&y[irow], &y[irow], &temp1);
}
}
jx += incx;
}
} else {
ABORT("Not implemented.");
}
} else if (strncmp(trans, "T", 1) == 0 || strncmp(trans, "t", 1) == 0) {
/* Form y := alpha*A'*x + y. */
jy = ky;
if (incx == 1) {
for (j = 0; j < A->ncol; ++j) {
temp = comp_zero;
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
zz_mult(&temp1, &Aval[i], &x[irow]);
z_add(&temp, &temp, &temp1);
}
zz_mult(&temp1, &alpha, &temp);
z_add(&y[jy], &y[jy], &temp1);
jy += incy;
}
} else {
ABORT("Not implemented.");
}
} else { /* trans == 'C' or 'c' */
/* Form y := alpha * conj(A) * x + y. */
doublecomplex temp2;
jy = ky;
if (incx == 1) {
for (j = 0; j < A->ncol; ++j) {
temp = comp_zero;
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
temp2.r = Aval[i].r;
temp2.i = -Aval[i].i; /* conjugation */
zz_mult(&temp1, &temp2, &x[irow]);
z_add(&temp, &temp, &temp1);
}
zz_mult(&temp1, &alpha, &temp);
z_add(&y[jy], &y[jy], &temp1);
jy += incy;
}
} else {
ABORT("Not implemented.");
}
}
return 0;
} /* sp_zgemv */
/*! \brief
*
* <pre>
* Purpose
* =======
*
* SGSEQU computes row and column scalings intended to equilibrate an
* M-by-N sparse matrix A and reduce its condition number. R returns the row
* scale factors and C the column scale factors, chosen to try to make
* the largest element in each row and column of the matrix B with
* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
*
* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
* number and BIGNUM = largest safe number. Use of these scaling
* factors is not guaranteed to reduce the condition number of A but
* works well in practice.
*
* See supermatrix.h for the definition of 'SuperMatrix' structure.
*
* Arguments
* =========
*
* A (input) SuperMatrix*
* The matrix of dimension (A->nrow, A->ncol) whose equilibration
* factors are to be computed. The type of A can be:
* Stype = SLU_NC; Dtype = SLU_S; Mtype = SLU_GE.
*
* R (output) float*, size A->nrow
* If INFO = 0 or INFO > M, R contains the row scale factors
* for A.
*
* C (output) float*, size A->ncol
* If INFO = 0, C contains the column scale factors for A.
*
* ROWCND (output) float*
* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
* AMAX is neither too large nor too small, it is not worth
* scaling by R.
*
* COLCND (output) float*
* If INFO = 0, COLCND contains the ratio of the smallest
* C(i) to the largest C(i). If COLCND >= 0.1, it is not
* worth scaling by C.
*
* AMAX (output) float*
* Absolute value of largest matrix element. If AMAX is very
* close to overflow or very close to underflow, the matrix
* should be scaled.
*
* INFO (output) int*
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, and i is
* <= A->nrow: the i-th row of A is exactly zero
* > A->ncol: the (i-M)-th column of A is exactly zero
*
* =====================================================================
* </pre>
*/
void
sgsequ(SuperMatrix *A, float *r, float *c, float *rowcnd,
float *colcnd, float *amax, int *info)
{
/* Local variables */
NCformat *Astore;
float *Aval;
int i, j, irow;
float rcmin, rcmax;
float bignum, smlnum;
extern float smach(char *);
/* Test the input parameters. */
*info = 0;
if ( A->nrow < 0 || A->ncol < 0 ||
A->Stype != SLU_NC || A->Dtype != SLU_S || A->Mtype != SLU_GE )
*info = -1;
if (*info != 0) {
i = -(*info);
input_error("sgsequ", &i);
return;
}
/* Quick return if possible */
if ( A->nrow == 0 || A->ncol == 0 ) {
*rowcnd = 1.;
*colcnd = 1.;
*amax = 0.;
return;
}
Astore = A->Store;
Aval = Astore->nzval;
/* Get machine constants. */
smlnum = smach("S"); /* slamch_("S"); */
bignum = 1. / smlnum;
/* Compute row scale factors. */
for (i = 0; i < A->nrow; ++i) r[i] = 0.;
/* Find the maximum element in each row. */
for (j = 0; j < A->ncol; ++j)
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
r[irow] = SUPERLU_MAX( r[irow], fabs(Aval[i]) );
}
/* Find the maximum and minimum scale factors. */
rcmin = bignum;
rcmax = 0.;
for (i = 0; i < A->nrow; ++i) {
rcmax = SUPERLU_MAX(rcmax, r[i]);
rcmin = SUPERLU_MIN(rcmin, r[i]);
}
*amax = rcmax;
if (rcmin == 0.) {
/* Find the first zero scale factor and return an error code. */
for (i = 0; i < A->nrow; ++i)
if (r[i] == 0.) {
*info = i + 1;
return;
}
} else {
/* Invert the scale factors. */
for (i = 0; i < A->nrow; ++i)
r[i] = 1. / SUPERLU_MIN( SUPERLU_MAX( r[i], smlnum ), bignum );
/* Compute ROWCND = min(R(I)) / max(R(I)) */
*rowcnd = SUPERLU_MAX( rcmin, smlnum ) / SUPERLU_MIN( rcmax, bignum );
}
/* Compute column scale factors */
for (j = 0; j < A->ncol; ++j) c[j] = 0.;
/* Find the maximum element in each column, assuming the row
scalings computed above. */
for (j = 0; j < A->ncol; ++j)
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
c[j] = SUPERLU_MAX( c[j], fabs(Aval[i]) * r[irow] );
}
/* Find the maximum and minimum scale factors. */
rcmin = bignum;
rcmax = 0.;
for (j = 0; j < A->ncol; ++j) {
rcmax = SUPERLU_MAX(rcmax, c[j]);
rcmin = SUPERLU_MIN(rcmin, c[j]);
}
if (rcmin == 0.) {
/* Find the first zero scale factor and return an error code. */
for (j = 0; j < A->ncol; ++j)
if ( c[j] == 0. ) {
*info = A->nrow + j + 1;
return;
}
} else {
/* Invert the scale factors. */
for (j = 0; j < A->ncol; ++j)
c[j] = 1. / SUPERLU_MIN( SUPERLU_MAX( c[j], smlnum ), bignum);
/* Compute COLCND = min(C(J)) / max(C(J)) */
*colcnd = SUPERLU_MAX( rcmin, smlnum ) / SUPERLU_MIN( rcmax, bignum );
}
return;
} /* sgsequ */
/* NOTE the approach here (reading phase, parsing phase) is the not most
* latency reducing approach. Its probably not even the approach that would
* maximize bandwidth. However it is an easy approach. */
BNJ::PullParser::State BNJ::PullParser::Pull(char const * const * key_set,
unsigned key_set_length)
{
/* For now, always set new user keys.
* FIXME: Is there a better spot for this assignment? */
_ctx.key_set = key_set;
_ctx.key_set_length = key_set_length;
/* If incoming on value, then user must have gotten value on last Pull().
* Advance to next value. If at end, parse more data. */
if(VALUE_ST == _state){
assert(_val_idx < _val_len);
bnj_val* tmp = _valbuff + _val_idx;
/* If user ignored fragmented string just parse through it.
* ONLY STRINGS should make it here.
* Call ChunkRead8() until nothing left.. */
if(bnj_incomplete(&_pstate, tmp)){
assert(bnj_val_type(tmp) == BNJ_STRING);
while(ChunkRead8(NULL, 0));
}
/* Transition to depth lag state in case depth changed. */
++_val_idx;
if(_val_len == _val_idx)
_state = DEPTH_LAG_ST;
}
/* No fragments entering the switch loop. */
unsigned frag_key_len = 0;
while(true){
switch(_state){
case PARSE_ST:
{
/* Parser is at end state when depth is 0 not at begin state. */
if(!_depth && _parser_state != ST_BEGIN){
_parser_state = ST_NO_DATA;
return _parser_state;
}
/* If no more bytes to parse, then go to read state. */
if(_first_empty == _first_unparsed)
FillBuffer(_len);
/* Assign output values. */
_pstate.v = _valbuff;
_pstate.vlen = 4;
_val_idx = 0;
_val_len = 0;
/* Set offset to where parsing begins. Parse data.
* Advance first unparsed to where parsing ended. */
const uint8_t* res = bnj_parse(&_pstate, &_ctx,
_buffer + _first_unparsed, _first_empty - _first_unparsed);
/* Abort on error. */
if(_pstate.flags & BNJ_ERROR_MASK)
throw input_error(s_error_msgs[_pstate.flags - BNJ_ERROR_MASK], 0);
if(!frag_key_len){
_offset = _first_unparsed;
}
else{
/* Restore key length to first value.
* Increment since more chars may have been added. */
_pstate.v->key_length += frag_key_len;
/* Bias any other values read in.
* Start point is moves away from offset. */
for(unsigned i = 0; i <= _pstate.vi; ++i){
_pstate.v[i].key_offset += frag_key_len;
_pstate.v[i].strval_offset += frag_key_len;
}
_pstate.v->key_offset += 0;
frag_key_len = 0;
_offset = 0;
}
_first_unparsed = res - _buffer;
/* If read any semblance of values, then switch to value state. */
if(_pstate.vi){
_val_len = _pstate.vi;
_state = VALUE_ST;
break;
}
/* Otherwise must be lagging c parser depth.*/
/* FALLTHROUGH */
_state = DEPTH_LAG_ST;
}
/* Catch up to c parser's depth. */
case DEPTH_LAG_ST:
if(_depth < _pstate.depth){
++_depth;
_parser_state = (_pstate.stack[_depth] & BNJ_OBJECT) ? ST_MAP : ST_LIST;
return _parser_state;
}
else if(_depth > _pstate.depth){
_parser_state = (_pstate.stack[_depth] & BNJ_OBJECT) ? ST_ASCEND_MAP
: ST_ASCEND_LIST;
--_depth;
return _parser_state;
}
/* Otherwise, parser depth caught up to c parser depth.
* Parse more data. */
_state = PARSE_ST;
break;
case VALUE_ST:
{
bnj_val* tmp = _valbuff + _val_idx;
unsigned type = bnj_val_type(tmp);
/* Remember number of UTF-8 characters.
* ChunkRead*() will need this initialized. */
if(type == BNJ_STRING)
_utf8_remaining = bnj_strlen8(tmp);
/* If key is incomplete or non-string value incomplete,
* then attempt to read full value. */
if(bnj_incomplete(&_pstate, tmp)){
/* If string value then ChunkRead*() will handle fragmentation. */
if(type == BNJ_STRING){
_state = VALUE_ST;
_parser_state = ST_DATUM;
return ST_DATUM;
}
/* Move fragment from near buffer end * to buffer start
* so FillBuffer() appends to fragment.
* Note only string value fragments are 'large' fragments.
* Since string fragments are filtered out at this point, the
* fragment shift should not be very expensive. */
/* Bias key offsets before shifting fragment.
* Note strval_offset only applies to BNJ_STRING. */
tmp->key_offset += _offset;
unsigned length = _len;
uint8_t* start = bnj_fragcompact(tmp, _buffer, &length);
_first_empty = start - _buffer;
/* Remember key offset and length. */
frag_key_len = tmp->key_length;
/* Fill buffer and switch to parsing state. */
FillBuffer(length + _first_empty);
_state = PARSE_ST;
break;
}
/* Otherwise have a piece of data ready to return to the user. */
_parser_state = ST_DATUM;
/* If beginning map or list, then lagging depth. */
if(BNJ_ARR_BEGIN == type || BNJ_OBJ_BEGIN == type){
_state = DEPTH_LAG_ST;
break;
}
return _parser_state;
}
break;
/* Should not be any other states. */
default:
assert(0);
}
}
}
/* Subroutine */ int slagge_slu(integer *m, integer *n, integer *kl, integer *ku,
real *d, real *a, integer *lda, integer *iseed, real *work, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Builtin functions */
double r_sign(real *, real *);
/* Local variables */
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
extern real snrm2_(integer *, real *, integer *);
static integer i, j;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *);
static real wa, wb, wn;
extern /* Subroutine */ int slarnv_slu(integer *, integer *, integer *, real *);
extern int input_error(char *, int *);
static real tau;
/* -- LAPACK auxiliary test routine (version 2.0)
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SLAGGE generates a real general m by n matrix A, by pre- and post-
multiplying a real diagonal matrix D with random orthogonal matrices:
A = U*D*V. The lower and upper bandwidths may then be reduced to
kl and ku by additional orthogonal transformations.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
KL (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= KL <= M-1.
KU (input) INTEGER
The number of nonzero superdiagonals within the band of A.
0 <= KU <= N-1.
D (input) REAL array, dimension (min(M,N))
The diagonal elements of the diagonal matrix D.
A (output) REAL array, dimension (LDA,N)
The generated m by n matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= M.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) REAL array, dimension (M+N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0 || *kl > *m - 1) {
*info = -3;
} else if (*ku < 0 || *ku > *n - 1) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -7;
}
if (*info < 0) {
i__1 = -(*info);
input_error("SLAGGE", &i__1);
return 0;
}
/* initialize A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i = 1; i <= i__2; ++i) {
a[i + j * a_dim1] = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = min(*m,*n);
for (i = 1; i <= i__1; ++i) {
a[i + i * a_dim1] = d[i];
/* L30: */
}
/* pre- and post-multiply A by random orthogonal matrices */
for (i = min(*m,*n); i >= 1; --i) {
if (i < *m) {
/* generate random reflection */
i__1 = *m - i + 1;
slarnv_slu(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *m - i + 1;
wn = snrm2_(&i__1, &work[1], &c__1);
wa = r_sign(&wn, &work[1]);
if (wn == 0.f) {
tau = 0.f;
} else {
wb = work[1] + wa;
i__1 = *m - i;
r__1 = 1.f / wb;
sscal_(&i__1, &r__1, &work[2], &c__1);
work[1] = 1.f;
tau = wb / wa;
}
/* multiply A(i:m,i:n) by random reflection from the lef
t */
i__1 = *m - i + 1;
i__2 = *n - i + 1;
sgemv_("Transpose", &i__1, &i__2, &c_b11, &a[i + i * a_dim1], lda,
&work[1], &c__1, &c_b13, &work[*m + 1], &c__1);
i__1 = *m - i + 1;
i__2 = *n - i + 1;
r__1 = -(doublereal)tau;
sger_(&i__1, &i__2, &r__1, &work[1], &c__1, &work[*m + 1], &c__1,
&a[i + i * a_dim1], lda);
}
if (i < *n) {
/* generate random reflection */
i__1 = *n - i + 1;
slarnv_slu(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = snrm2_(&i__1, &work[1], &c__1);
wa = r_sign(&wn, &work[1]);
if (wn == 0.f) {
tau = 0.f;
} else {
wb = work[1] + wa;
i__1 = *n - i;
r__1 = 1.f / wb;
sscal_(&i__1, &r__1, &work[2], &c__1);
work[1] = 1.f;
tau = wb / wa;
}
/* multiply A(i:m,i:n) by random reflection from the rig
ht */
i__1 = *m - i + 1;
i__2 = *n - i + 1;
sgemv_("No transpose", &i__1, &i__2, &c_b11, &a[i + i * a_dim1],
lda, &work[1], &c__1, &c_b13, &work[*n + 1], &c__1);
i__1 = *m - i + 1;
i__2 = *n - i + 1;
r__1 = -(doublereal)tau;
sger_(&i__1, &i__2, &r__1, &work[*n + 1], &c__1, &work[1], &c__1,
&a[i + i * a_dim1], lda);
}
/* L40: */
}
/* Reduce number of subdiagonals to KL and number of superdiagonals
to KU
Computing MAX */
i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
i__1 = max(i__2,i__3);
for (i = 1; i <= i__1; ++i) {
if (*kl <= *ku) {
/* annihilate subdiagonal elements first (necessary if K
L = 0)
Computing MIN */
i__2 = *m - 1 - *kl;
if (i <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i
) */
i__2 = *m - *kl - i + 1;
wn = snrm2_(&i__2, &a[*kl + i + i * a_dim1], &c__1);
wa = r_sign(&wn, &a[*kl + i + i * a_dim1]);
if (wn == 0.f) {
tau = 0.f;
} else {
wb = a[*kl + i + i * a_dim1] + wa;
i__2 = *m - *kl - i;
r__1 = 1.f / wb;
sscal_(&i__2, &r__1, &a[*kl + i + 1 + i * a_dim1], &c__1);
a[*kl + i + i * a_dim1] = 1.f;
tau = wb / wa;
}
/* apply reflection to A(kl+i:m,i+1:n) from the l
eft */
i__2 = *m - *kl - i + 1;
i__3 = *n - i;
sgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i + (i + 1)
* a_dim1], lda, &a[*kl + i + i * a_dim1], &c__1, &
c_b13, &work[1], &c__1);
i__2 = *m - *kl - i + 1;
i__3 = *n - i;
r__1 = -(doublereal)tau;
sger_(&i__2, &i__3, &r__1, &a[*kl + i + i * a_dim1], &c__1, &
work[1], &c__1, &a[*kl + i + (i + 1) * a_dim1], lda);
a[*kl + i + i * a_dim1] = -(doublereal)wa;
}
/* Computing MIN */
i__2 = *n - 1 - *ku;
if (i <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n
) */
i__2 = *n - *ku - i + 1;
wn = snrm2_(&i__2, &a[i + (*ku + i) * a_dim1], lda);
wa = r_sign(&wn, &a[i + (*ku + i) * a_dim1]);
if (wn == 0.f) {
tau = 0.f;
} else {
wb = a[i + (*ku + i) * a_dim1] + wa;
i__2 = *n - *ku - i;
r__1 = 1.f / wb;
sscal_(&i__2, &r__1, &a[i + (*ku + i + 1) * a_dim1], lda);
a[i + (*ku + i) * a_dim1] = 1.f;
tau = wb / wa;
}
/* apply reflection to A(i+1:m,ku+i:n) from the r
ight */
i__2 = *m - i;
i__3 = *n - *ku - i + 1;
sgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i + 1 + (*ku
+ i) * a_dim1], lda, &a[i + (*ku + i) * a_dim1], lda,
&c_b13, &work[1], &c__1);
i__2 = *m - i;
i__3 = *n - *ku - i + 1;
r__1 = -(doublereal)tau;
sger_(&i__2, &i__3, &r__1, &work[1], &c__1, &a[i + (*ku + i) *
a_dim1], lda, &a[i + 1 + (*ku + i) * a_dim1], lda);
a[i + (*ku + i) * a_dim1] = -(doublereal)wa;
}
} else {
/* annihilate superdiagonal elements first (necessary if
KU = 0)
Computing MIN */
i__2 = *n - 1 - *ku;
if (i <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n
) */
i__2 = *n - *ku - i + 1;
wn = snrm2_(&i__2, &a[i + (*ku + i) * a_dim1], lda);
wa = r_sign(&wn, &a[i + (*ku + i) * a_dim1]);
if (wn == 0.f) {
tau = 0.f;
} else {
wb = a[i + (*ku + i) * a_dim1] + wa;
i__2 = *n - *ku - i;
r__1 = 1.f / wb;
sscal_(&i__2, &r__1, &a[i + (*ku + i + 1) * a_dim1], lda);
a[i + (*ku + i) * a_dim1] = 1.f;
tau = wb / wa;
}
/* apply reflection to A(i+1:m,ku+i:n) from the r
ight */
i__2 = *m - i;
i__3 = *n - *ku - i + 1;
sgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i + 1 + (*ku
+ i) * a_dim1], lda, &a[i + (*ku + i) * a_dim1], lda,
&c_b13, &work[1], &c__1);
i__2 = *m - i;
i__3 = *n - *ku - i + 1;
r__1 = -(doublereal)tau;
sger_(&i__2, &i__3, &r__1, &work[1], &c__1, &a[i + (*ku + i) *
a_dim1], lda, &a[i + 1 + (*ku + i) * a_dim1], lda);
a[i + (*ku + i) * a_dim1] = -(doublereal)wa;
}
/* Computing MIN */
i__2 = *m - 1 - *kl;
if (i <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i
) */
i__2 = *m - *kl - i + 1;
wn = snrm2_(&i__2, &a[*kl + i + i * a_dim1], &c__1);
wa = r_sign(&wn, &a[*kl + i + i * a_dim1]);
if (wn == 0.f) {
tau = 0.f;
} else {
wb = a[*kl + i + i * a_dim1] + wa;
i__2 = *m - *kl - i;
r__1 = 1.f / wb;
sscal_(&i__2, &r__1, &a[*kl + i + 1 + i * a_dim1], &c__1);
a[*kl + i + i * a_dim1] = 1.f;
tau = wb / wa;
}
/* apply reflection to A(kl+i:m,i+1:n) from the l
eft */
i__2 = *m - *kl - i + 1;
i__3 = *n - i;
sgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i + (i + 1)
* a_dim1], lda, &a[*kl + i + i * a_dim1], &c__1, &
c_b13, &work[1], &c__1);
i__2 = *m - *kl - i + 1;
i__3 = *n - i;
r__1 = -(doublereal)tau;
sger_(&i__2, &i__3, &r__1, &a[*kl + i + i * a_dim1], &c__1, &
work[1], &c__1, &a[*kl + i + (i + 1) * a_dim1], lda);
a[*kl + i + i * a_dim1] = -(doublereal)wa;
}
}
i__2 = *m;
for (j = *kl + i + 1; j <= i__2; ++j) {
a[j + i * a_dim1] = 0.f;
/* L50: */
}
i__2 = *n;
for (j = *ku + i + 1; j <= i__2; ++j) {
a[i + j * a_dim1] = 0.f;
/* L60: */
}
/* L70: */
}
return 0;
/* End of SLAGGE */
} /* slagge_slu */
void crossword(char num[], int n)
{
int i, j, k;
char input_num[10];
char str[] = "I GIVE UP";
printf("plesase input four not repeated figures:");
while(1)
{
fgets(input_num, 10, stdin);
if(strncmp(input_num, str, 9)==0)
{
printf("The right result:");
printf("%s\n", num);
break;
}
if(input_error(input_num, n))
{
for (i = 0,j = 0; i < n; i++)
{
if(input_num[j] == num[i])
j++;
}
if(n == j)
{
printf("YOU BET!\n");
printf("THe right result:%s\n", num);
break;
}
k = 0;
for (i = 0; i < n; i++)
{
for (j = 0; j < n; j++)
{
if(num[i] == input_num[j])
{
if(i == j)
{
printf("A");
}
else
{
printf("B");
}
break;
}
else
k++;
}
}
if(n*n == k)
{
printf("0000");
}
}
else
{
printf("you input number not conform to requirements!!");
}
printf("\nplesase input four not repeated figures again:");
}
}
