int main(int argc, char* argv[])
{
if (argc != 2) return usage(argv[0]);
int n = atoi(argv[1]), n2 = n * n;
if (n <= 0) return usage(argv[0]);
// Generate random matrix.
size_t size = sizeof(float) * n2;
float* A1 = (float*)malloc(size);
int one = 1, seed[4] = { 0, 0, 0, 1 };
slarnv_(&one, seed, &n2, A1);
// Symmetrize and increase the diagonal.
for (int i = 0; i < n; i++)
{
A1[i * n + i] += n;
for (int j = 0; j < i; j++)
A1[i * n + j] = A1[j * n + i];
}
// Clone generated matrix for GPU version
// (we can't use one copy of A, because
// spotrf rewrites the input matrix).
float* A2 = (float*)malloc(size);
memcpy(A2, A1, size);
// Use upper part of input matrix and
// rewrite it with Cholessky factor.
char uplo = 'U';
// The status info (routine must return 0 into info).
int info = 0;
// Perform decomposition on CPU.
printf("Computing on CPU ... "); fflush(stdout);
spotrf_(&uplo, &n, A1, &n, &info);
chkerr(info);
// Perform decomposition on GPU.
printf("Computing on GPU ... "); fflush(stdout);
magma_spotrf(uplo, n, A2, n, &info);
chkerr(info);
// Compare results.
float maxdiff = fabs(A1[0] - A2[0]);
for (int i = 0; i < n; i++)
for (int j = 0; j < i; j++)
{
maxdiff = fmax(maxdiff,
fabs(A1[i * n + j] - A2[i * n + j]));
maxdiff = fmax(maxdiff,
fabs(A1[j * n + i] - A2[j * n + i]));
}
printf("Done! max diff = %f\n", maxdiff);
free(A1); free(A2);
}
/* Subroutine */ int schkgt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, real *a,
real *af, real *b, real *x, real *xact, real *work, real *rwork,
integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
" \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
"5)";
static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
"RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Local variables */
integer i__, j, k, m, n;
real z__[3];
integer in, kl, ku, ix, lda;
real cond;
integer mode, koff, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[1], type__[1];
integer nrun;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer itran;
char trans[1];
integer izero, nerrs;
logical zerot;
real rcondc, rcondi, rcondo;
real ainvnm;
logical trfcon;
real result[7];
/* Fortran I/O blocks */
static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKGT tests SGTTRF, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (NMAX*4) */
/* AF (workspace) REAL array, dimension (NMAX*4) */
/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
serrge_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Set up parameters with SLATB4. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number. */
/* Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
scopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
scopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with */
/* unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
slarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
sscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
a[n] = z__[1];
if (n > 1) {
a[1] = z__[2];
}
} else if (izero == n) {
a[n * 3 - 2] = z__[0];
a[(n << 1) - 1] = z__[1];
} else {
a[(n << 1) - 2 + izero] = z__[0];
a[n - 1 + izero] = z__[1];
a[izero] = z__[2];
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
z__[1] = a[n];
a[n] = 0.f;
if (n > 1) {
z__[2] = a[1];
a[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
z__[0] = a[n * 3 - 2];
z__[1] = a[(n << 1) - 1];
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
a[(n << 1) - 2 + i__] = 0.f;
a[n - 1 + i__] = 0.f;
a[i__] = 0.f;
/* L20: */
}
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
}
}
/* + TEST 1 */
/* Factor A as L*U and compute the ratio */
/* norm(L*U - A) / (n * norm(A) * EPS ) */
i__3 = n + (m << 1);
scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
s_copy(srnamc_1.srnamt, "SGTTRF", (ftnlen)32, (ftnlen)6);
sgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ 1], &iwork[1], &info);
/* Check error code from SGTTRF. */
if (info != izero) {
alaerh_(path, "SGTTRF", &info, &izero, " ", &n, &n, &c__1, &
c__1, &c_n1, &imat, &nfail, &nerrs, nout);
}
trfcon = info != 0;
sgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
&lda, &rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
;
if (itran == 1) {
*(unsigned char *)norm = 'O';
} else {
*(unsigned char *)norm = 'I';
}
anorm = slangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
if (! trfcon) {
/* Use SGTTRS to solve for one column at a time of inv(A) */
/* or inv(A^T), computing the maximum column sum as we */
/* go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L30: */
}
x[i__] = 1.f;
sgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
if (itran == 1) {
rcondo = rcondc;
} else {
rcondi = rcondc;
}
} else {
rcondc = 0.f;
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
s_copy(srnamc_1.srnamt, "SGTCON", (ftnlen)32, (ftnlen)6);
sgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
iwork[n + 1], &info);
/* Check error code from SGTCON. */
if (info != 0) {
alaerh_(path, "SGTCON", &info, &c__0, norm, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = sget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
/* L50: */
}
/* Skip the remaining tests if the matrix is singular. */
if (trfcon) {
goto L100;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* Generate NRHS random solution vectors. */
ix = 1;
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
slarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L60: */
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Set the right hand side. */
slagtm_(trans, &n, &nrhs, &c_b63, &a[1], &a[m + 1], &a[n
+ m + 1], &xact[1], &lda, &c_b64, &b[1], &lda);
/* + TEST 2 */
/* Solve op(A) * X = B and compute the residual. */
slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "SGTTRS", (ftnlen)32, (ftnlen)6);
sgttrs_(trans, &n, &nrhs, &af[1], &af[m + 1], &af[n + m +
1], &af[n + (m << 1) + 1], &iwork[1], &x[1], &lda,
&info);
/* Check error code from SGTTRS. */
if (info != 0) {
alaerh_(path, "SGTTRS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
sgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&x[1], &lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "SGTRFS", (ftnlen)32, (ftnlen)6);
sgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &iwork[n +
1], &info);
/* Check error code from SGTRFS. */
if (info != 0) {
alaerh_(path, "SGTRFS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
sgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SCHKGT */
} /* schkgt_ */
/* Subroutine */ int sqrt03_(integer *m, integer *n, integer *k, real *af,
real *c__, real *cc, real *q, integer *lda, real *tau, real *work,
integer *lwork, real *rwork, real *result)
{
/* Initialized data */
static integer iseed[4] = { 1988,1989,1990,1991 };
/* System generated locals */
integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
q_offset, i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer j, mc, nc;
real eps;
char side[1];
integer info, iside;
extern logical lsame_(char *, char *);
real resid;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
real cnorm;
char trans[1];
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *);
integer itrans;
extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
*), sorgqr_(integer *, integer *, integer *, real *, integer *,
real *, real *, integer *, integer *), sormqr_(char *, char *,
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, real *, integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SQRT03 tests SORMQR, which computes Q*C, Q'*C, C*Q or C*Q'. */
/* SQRT03 compares the results of a call to SORMQR with the results of */
/* forming Q explicitly by a call to SORGQR and then performing matrix */
/* multiplication by a call to SGEMM. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The order of the orthogonal matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of rows or columns of the matrix C; C is m-by-n if */
/* Q is applied from the left, or n-by-m if Q is applied from */
/* the right. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* orthogonal matrix Q. M >= K >= 0. */
/* AF (input) REAL array, dimension (LDA,N) */
/* Details of the QR factorization of an m-by-n matrix, as */
/* returnedby SGEQRF. See SGEQRF for further details. */
/* C (workspace) REAL array, dimension (LDA,N) */
/* CC (workspace) REAL array, dimension (LDA,N) */
/* Q (workspace) REAL array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays AF, C, CC, and Q. */
/* TAU (input) REAL array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the QR factorization in AF. */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of WORK. LWORK must be at least M, and should be */
/* M*NB, where NB is the blocksize for this environment. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL array, dimension (4) */
/* The test ratios compare two techniques for multiplying a */
/* random matrix C by an m-by-m orthogonal matrix Q. */
/* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) */
/* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) */
/* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
/* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
cc_dim1 = *lda;
cc_offset = 1 + cc_dim1;
cc -= cc_offset;
c_dim1 = *lda;
c_offset = 1 + c_dim1;
c__ -= c_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
eps = slamch_("Epsilon");
/* Copy the first k columns of the factorization to the array Q */
slaset_("Full", m, m, &c_b4, &c_b4, &q[q_offset], lda);
i__1 = *m - 1;
slacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "SORGQR", (ftnlen)6, (ftnlen)6);
sorgqr_(m, m, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
for (iside = 1; iside <= 2; ++iside) {
if (iside == 1) {
*(unsigned char *)side = 'L';
mc = *m;
nc = *n;
} else {
*(unsigned char *)side = 'R';
mc = *n;
nc = *m;
}
/* Generate MC by NC matrix C */
i__1 = nc;
for (j = 1; j <= i__1; ++j) {
slarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
/* L10: */
}
cnorm = slange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
if (cnorm == 0.f) {
cnorm = 1.f;
}
for (itrans = 1; itrans <= 2; ++itrans) {
if (itrans == 1) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
/* Copy C */
slacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
lda);
/* Apply Q or Q' to C */
s_copy(srnamc_1.srnamt, "SORMQR", (ftnlen)6, (ftnlen)6);
sormqr_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
cc[cc_offset], lda, &work[1], lwork, &info);
/* Form explicit product and subtract */
if (lsame_(side, "L")) {
sgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
cc_offset], lda);
} else {
sgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
cc_offset], lda);
}
/* Compute error in the difference */
resid = slange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*m) *
cnorm * eps);
/* L20: */
}
/* L30: */
}
return 0;
/* End of SQRT03 */
} /* sqrt03_ */
void initialize (int argc, char **argv, int * N_p, int * DIM_p)
{
int ISEED[4] = {0,0,0,1};
int IONE=1;
int DIM;
char UPLO='n';
float FZERO=0.0;
int i;
if (argc==2)
{
DIM=atoi(argv[1]);
}
else
{
printf("usage: %s DIM\n",argv[0]);
exit(0);
}
// matrix init
int N=BSIZE*DIM;
int NN=N*N;
*N_p=N;
*DIM_p=DIM;
// linear matrix
float *Alin = (float *) malloc(NN * sizeof(float));
float *Blin = (float *) malloc(NN * sizeof(float));
float *Clin = (float *) malloc(NN * sizeof(float));
// fill the matrix with random values
slarnv_(&IONE, ISEED, &NN, Alin);
slarnv_(&IONE, ISEED, &NN, Blin);
slaset_(&UPLO,&N,&N,&FZERO,&FZERO,Clin,&N);
A = (float **) malloc(DIM*DIM*sizeof(float *));
B = (float **) malloc(DIM*DIM*sizeof(float *));
C = (float **) malloc(DIM*DIM*sizeof(float *));
#if 1
#if 1
for (i = 0; i < DIM*DIM; i++)
{
A[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
B[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
C[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
// printf( "A[%d]=%p %p %p\n", i, A[i], B[i], C[i] );
}
#else
for (i = 0; i < DIM*DIM; i++) {
A[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
// printf( "A[%d]=%p\n", i, A[i] );
}
for (i = 0; i < DIM*DIM; i++)
B[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
for (i = 0; i < DIM*DIM; i++)
C[i] = (float *) malloc(BSIZE*BSIZE*sizeof(float));
#endif
#else
float * A_scratch = (float *) malloc(DIM*DIM*BSIZE*BSIZE*sizeof(float));
float * B_scratch = (float *) malloc(DIM*DIM*BSIZE*BSIZE*sizeof(float));
float * C_scratch = (float *) malloc(DIM*DIM*BSIZE*BSIZE*sizeof(float));
for (i = 0; i < DIM*DIM; i++)
{
A[i] = &A_scratch[i*BSIZE*BSIZE];
B[i] = &B_scratch[i*BSIZE*BSIZE];
C[i] = &C_scratch[i*BSIZE*BSIZE];
// printf( "A[%d]=%p\n", i, A[i] );
}
#endif
convert_to_blocks(DIM, N, Alin, (void *)A);
convert_to_blocks(DIM, N, Blin, (void *)B);
convert_to_blocks(DIM, N, Clin, (void *)C);
free(Alin);
free(Blin);
free(Clin);
}
/* Subroutine */ int cchkpt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, complex *
a, real *d__, complex *e, complex *b, complex *x, complex *xact,
complex *work, real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 N =\002,i5,\002, type \002,i2,\002, te"
"st \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS =\002,i3,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"= \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
/* Local variables */
integer i__, j, k, n;
complex z__[3];
integer ia, in, kl, ku, ix, lda;
real cond;
integer mode;
real dmax__;
integer imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer iuplo, izero, nerrs;
logical zerot;
real rcondc;
real ainvnm;
real result[7];
/* Fortran I/O blocks */
static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKPT tests CPTTRF, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) COMPLEX array, dimension (NMAX*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) COMPLEX array, dimension (NMAX*2) */
/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrgt_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (n > 0 && ! dotype[imat]) {
goto L110;
}
/* Set up parameters with CLATB4. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a Hermitian tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
/* Check the error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ia;
d__[i__] = a[i__4].r;
i__4 = i__;
i__5 = ia + 1;
e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
ia += 2;
/* L20: */
}
if (n > 0) {
i__3 = ia;
d__[n] = a[i__3].r;
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let E be complex, D real, with values from [-1,1]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
clarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = dabs(d__[1]);
} else {
d__[1] = dabs(d__[1]) + c_abs(&e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + c_abs(&e[n - 1]
);
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + c_abs(&
e[i__]) + c_abs(&e[i__ - 1]);
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = isamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
r__1 = anorm / dmax__;
sscal_(&n, &r__1, &d__[1], &c__1);
i__3 = n - 1;
r__1 = anorm / dmax__;
csscal_(&i__3, &r__1, &e[1], &c__1);
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1].r;
if (n > 1) {
e[1].r = z__[2].r, e[1].i = z__[2].i;
}
} else if (izero == n) {
i__3 = n - 1;
e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
i__3 = n;
d__[i__3] = z__[1].r;
} else {
i__3 = izero - 1;
e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
i__3 = izero;
d__[i__3] = z__[1].r;
i__3 = izero;
e[i__3].r = z__[2].r, e[i__3].i = z__[2].i;
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1].r = d__[1], z__[1].i = 0.f;
d__[1] = 0.f;
if (n > 1) {
z__[2].r = e[1].r, z__[2].i = e[1].i;
e[1].r = 0.f, e[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
i__3 = n - 1;
z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
i__3 = n - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
i__3 = n;
z__[1].r = d__[i__3], z__[1].i = 0.f;
d__[n] = 0.f;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
i__3 = izero - 1;
z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
i__3 = izero;
z__[2].r = e[i__3].r, z__[2].i = e[i__3].i;
i__3 = izero - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
i__3 = izero;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
i__3 = izero;
z__[1].r = d__[i__3], z__[1].i = 0.f;
d__[izero] = 0.f;
}
}
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* + TEST 1 */
/* Factor A as L*D*L' and compute the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
cpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Check error code from CPTTRF. */
if (info != izero) {
alaerh_(path, "CPTTRF", &info, &izero, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
if (info > 0) {
rcondc = 0.f;
goto L100;
}
cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &work[1],
result);
/* Print the test ratio if greater than or equal to THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
/* Compute norm(A). */
anorm = clanht_("1", &n, &d__[1], &e[1]);
/* Use CPTTRS to solve for one column at a time of inv(A), */
/* computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L40: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L50: */
}
/* Computing MAX */
r__1 = 1.f, r__2 = anorm * ainvnm;
rcondc = 1.f / dmax(r__1,r__2);
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* Generate NRHS random solution vectors. */
ix = 1;
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
clarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L60: */
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L'. */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
/* Set the right hand side. */
claptm_(uplo, &n, &nrhs, &c_b48, &d__[1], &e[1], &xact[1],
&lda, &c_b49, &b[1], &lda);
/* + TEST 2 */
/* Solve A*x = b and compute the residual. */
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
cpttrs_(uplo, &n, &nrhs, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Check error code from CPTTRS. */
if (info != 0) {
alaerh_(path, "CPTTRS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
cptt02_(uplo, &n, &nrhs, &d__[1], &e[1], &x[1], &lda, &
work[1], &lda, &result[1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "CPTRFS", (ftnlen)32, (ftnlen)6);
cptrfs_(uplo, &n, &nrhs, &d__[1], &e[1], &d__[n + 1], &e[
n + 1], &b[1], &lda, &x[1], &lda, &rwork[1], &
rwork[nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1]
, &info);
/* Check error code from CPTRFS. */
if (info != 0) {
alaerh_(path, "CPTRFS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
cptt05_(&n, &nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[nrhs + 1],
&result[4]);
/* Print information about the tests that did not pass the */
/* threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* L90: */
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
L100:
s_copy(srnamc_1.srnamt, "CPTCON", (ftnlen)32, (ftnlen)6);
cptcon_(&n, &d__[n + 1], &e[n + 1], &anorm, &rcond, &rwork[1], &
info);
/* Check error code from CPTCON. */
if (info != 0) {
alaerh_(path, "CPTCON", &info, &c__0, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = sget06_(&rcond, &rcondc);
/* Print the test ratio if greater than or equal to THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKPT */
} /* cchkpt_ */
/* Subroutine */ int cstein_(integer *n, real *d__, real *e, integer *m, real
*w, integer *iblock, integer *isplit, complex *z__, integer *ldz,
real *work, integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4, r__5;
complex q__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, b1, j1, bn, jr;
real xj, scl, eps, ctr, sep, nrm, tol;
integer its;
real xjm, eps1;
integer jblk, nblk, jmax;
extern doublereal snrm2_(integer *, real *, integer *);
integer iseed[4], gpind, iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
real ortol;
integer indrv1, indrv2, indrv3, indrv4, indrv5;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *), slagtf_(
integer *, real *, real *, real *, real *, real *, real *,
integer *, integer *);
integer nrmchk;
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slagts_(integer *, integer *, real *, real *,
real *, real *, integer *, real *, real *, integer *);
integer blksiz;
real onenrm, pertol;
extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
*);
real stpcrt;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSTEIN computes the eigenvectors of a real symmetric tridiagonal */
/* matrix T corresponding to specified eigenvalues, using inverse */
/* iteration. */
/* The maximum number of iterations allowed for each eigenvector is */
/* specified by an internal parameter MAXITS (currently set to 5). */
/* Although the eigenvectors are real, they are stored in a complex */
/* array, which may be passed to CUNMTR or CUPMTR for back */
/* transformation to the eigenvectors of a complex Hermitian matrix */
/* which was reduced to tridiagonal form. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix T. */
/* E (input) REAL array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the tridiagonal matrix */
/* T, stored in elements 1 to N-1. */
/* M (input) INTEGER */
/* The number of eigenvectors to be found. 0 <= M <= N. */
/* W (input) REAL array, dimension (N) */
/* The first M elements of W contain the eigenvalues for */
/* which eigenvectors are to be computed. The eigenvalues */
/* should be grouped by split-off block and ordered from */
/* smallest to largest within the block. ( The output array */
/* W from SSTEBZ with ORDER = 'B' is expected here. ) */
/* IBLOCK (input) INTEGER array, dimension (N) */
/* The submatrix indices associated with the corresponding */
/* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */
/* the first submatrix from the top, =2 if W(i) belongs to */
/* the second submatrix, etc. ( The output array IBLOCK */
/* from SSTEBZ is expected here. ) */
/* ISPLIT (input) INTEGER array, dimension (N) */
/* The splitting points, at which T breaks up into submatrices. */
/* The first submatrix consists of rows/columns 1 to */
/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
/* through ISPLIT( 2 ), etc. */
/* ( The output array ISPLIT from SSTEBZ is expected here. ) */
/* Z (output) COMPLEX array, dimension (LDZ, M) */
/* The computed eigenvectors. The eigenvector associated */
/* with the eigenvalue W(i) is stored in the i-th column of */
/* Z. Any vector which fails to converge is set to its current */
/* iterate after MAXITS iterations. */
/* The imaginary parts of the eigenvectors are set to zero. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* WORK (workspace) REAL array, dimension (5*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* IFAIL (output) INTEGER array, dimension (M) */
/* On normal exit, all elements of IFAIL are zero. */
/* If one or more eigenvectors fail to converge after */
/* MAXITS iterations, then their indices are stored in */
/* array IFAIL. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, then i eigenvectors failed to converge */
/* in MAXITS iterations. Their indices are stored in */
/* array IFAIL. */
/* Internal Parameters */
/* =================== */
/* MAXITS INTEGER, default = 5 */
/* The maximum number of iterations performed. */
/* EXTRA INTEGER, default = 2 */
/* The number of iterations performed after norm growth */
/* criterion is satisfied, should be at least 1. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--w;
--iblock;
--isplit;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
*info = 0;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
if (*n < 0) {
*info = -1;
} else if (*m < 0 || *m > *n) {
*info = -4;
} else if (*ldz < max(1,*n)) {
*info = -9;
} else {
i__1 = *m;
for (j = 2; j <= i__1; ++j) {
if (iblock[j] < iblock[j - 1]) {
*info = -6;
goto L30;
}
if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
*info = -5;
goto L30;
}
/* L20: */
}
L30:
;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSTEIN", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
} else if (*n == 1) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
return 0;
}
/* Get machine constants. */
eps = slamch_("Precision");
/* Initialize seed for random number generator SLARNV. */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = 1;
/* L40: */
}
/* Initialize pointers. */
indrv1 = 0;
indrv2 = indrv1 + *n;
indrv3 = indrv2 + *n;
indrv4 = indrv3 + *n;
indrv5 = indrv4 + *n;
/* Compute eigenvectors of matrix blocks. */
j1 = 1;
i__1 = iblock[*m];
for (nblk = 1; nblk <= i__1; ++nblk) {
/* Find starting and ending indices of block nblk. */
if (nblk == 1) {
b1 = 1;
} else {
b1 = isplit[nblk - 1] + 1;
}
bn = isplit[nblk];
blksiz = bn - b1 + 1;
if (blksiz == 1) {
goto L60;
}
gpind = b1;
/* Compute reorthogonalization criterion and stopping criterion. */
onenrm = (r__1 = d__[b1], dabs(r__1)) + (r__2 = e[b1], dabs(r__2));
/* Computing MAX */
r__3 = onenrm, r__4 = (r__1 = d__[bn], dabs(r__1)) + (r__2 = e[bn - 1]
, dabs(r__2));
onenrm = dmax(r__3,r__4);
i__2 = bn - 1;
for (i__ = b1 + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__4 = onenrm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 = e[
i__ - 1], dabs(r__2)) + (r__3 = e[i__], dabs(r__3));
onenrm = dmax(r__4,r__5);
/* L50: */
}
ortol = onenrm * .001f;
stpcrt = sqrt(.1f / blksiz);
/* Loop through eigenvalues of block nblk. */
L60:
jblk = 0;
i__2 = *m;
for (j = j1; j <= i__2; ++j) {
if (iblock[j] != nblk) {
j1 = j;
goto L180;
}
++jblk;
xj = w[j];
/* Skip all the work if the block size is one. */
if (blksiz == 1) {
work[indrv1 + 1] = 1.f;
goto L140;
}
/* If eigenvalues j and j-1 are too close, add a relatively */
/* small perturbation. */
if (jblk > 1) {
eps1 = (r__1 = eps * xj, dabs(r__1));
pertol = eps1 * 10.f;
sep = xj - xjm;
if (sep < pertol) {
xj = xjm + pertol;
}
}
its = 0;
nrmchk = 0;
/* Get random starting vector. */
slarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
/* Copy the matrix T so it won't be destroyed in factorization. */
scopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
i__3 = blksiz - 1;
scopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
i__3 = blksiz - 1;
scopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
/* Compute LU factors with partial pivoting ( PT = LU ) */
tol = 0.f;
slagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[
indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
/* Update iteration count. */
L70:
++its;
if (its > 5) {
goto L120;
}
/* Normalize and scale the righthand side vector Pb. */
/* Computing MAX */
r__2 = eps, r__3 = (r__1 = work[indrv4 + blksiz], dabs(r__1));
scl = blksiz * onenrm * dmax(r__2,r__3) / sasum_(&blksiz, &work[
indrv1 + 1], &c__1);
sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
/* Solve the system LU = Pb. */
slagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], &
work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[
indrv1 + 1], &tol, &iinfo);
/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */
/* close enough. */
if (jblk == 1) {
goto L110;
}
if ((r__1 = xj - xjm, dabs(r__1)) > ortol) {
gpind = j;
}
if (gpind != j) {
i__3 = j - 1;
for (i__ = gpind; i__ <= i__3; ++i__) {
ctr = 0.f;
i__4 = blksiz;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = b1 - 1 + jr + i__ * z_dim1;
ctr += work[indrv1 + jr] * z__[i__5].r;
/* L80: */
}
i__4 = blksiz;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = b1 - 1 + jr + i__ * z_dim1;
work[indrv1 + jr] -= ctr * z__[i__5].r;
/* L90: */
}
/* L100: */
}
}
/* Check the infinity norm of the iterate. */
L110:
jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
nrm = (r__1 = work[indrv1 + jmax], dabs(r__1));
/* Continue for additional iterations after norm reaches */
/* stopping criterion. */
if (nrm < stpcrt) {
goto L70;
}
++nrmchk;
if (nrmchk < 3) {
goto L70;
}
goto L130;
/* If stopping criterion was not satisfied, update info and */
/* store eigenvector number in array ifail. */
L120:
++(*info);
ifail[*info] = j;
/* Accept iterate as jth eigenvector. */
L130:
scl = 1.f / snrm2_(&blksiz, &work[indrv1 + 1], &c__1);
jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
if (work[indrv1 + jmax] < 0.f) {
scl = -scl;
}
sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
L140:
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * z_dim1;
z__[i__4].r = 0.f, z__[i__4].i = 0.f;
/* L150: */
}
i__3 = blksiz;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = b1 + i__ - 1 + j * z_dim1;
i__5 = indrv1 + i__;
q__1.r = work[i__5], q__1.i = 0.f;
z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
/* L160: */
}
/* Save the shift to check eigenvalue spacing at next */
/* iteration. */
xjm = xj;
/* L170: */
}
L180:
;
}
return 0;
/* End of CSTEIN */
} /* cstein_ */
/* Subroutine */ int slarre_(char* range, integer* n, real* vl, real* vu,
integer* il, integer* iu, real* d__, real* e, real* e2, real* rtol1,
real* rtol2, real* spltol, integer* nsplit, integer* isplit, integer *
m, real* w, real* werr, real* wgap, integer* iblock, integer* indexw,
real* gers, real* pivmin, real* work, integer* iwork, integer* info) {
/* System generated locals */
integer i__1, i__2;
real r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal), log(doublereal);
/* Local variables */
integer i__, j;
real s1, s2;
integer mb;
real gl;
integer in, mm;
real gu;
integer cnt;
real eps, tau, tmp, rtl;
integer cnt1, cnt2;
real tmp1, eabs;
integer iend, jblk;
real eold;
integer indl;
real dmax__, emax;
integer wend, idum, indu;
real rtol;
integer iseed[4];
real avgap, sigma;
extern logical lsame_(char*, char*);
integer iinfo;
logical norep;
extern /* Subroutine */ int scopy_(integer*, real*, integer*, real*,
integer*), slasq2_(integer*, real*, integer*);
integer ibegin;
logical forceb;
integer irange;
real sgndef;
extern doublereal slamch_(char*);
integer wbegin;
real safmin, spdiam;
extern /* Subroutine */ int slarra_(integer*, real*, real*, real*,
real*, real*, integer*, integer*, integer*);
logical usedqd;
real clwdth, isleft;
extern /* Subroutine */ int slarrb_(integer*, real*, real*, integer*,
integer*, real*, real*, integer*, real*, real*, real*,
real*, integer*, real*, real*, integer*, integer*), slarrc_(
char*, integer*, real*, real*, real*, real*, real*,
integer*, integer*, integer*, integer*), slarrd_(char
*, char*, integer*, real*, real*, integer*, integer*, real *
, real*, real*, real*, real*, real*, integer*, integer*,
integer*, real*, real*, real*, real*, integer*, integer*,
real*, integer*, integer*), slarrk_(integer*,
integer*, real*, real*, real*, real*, real*, real*, real*,
real*, integer*);
real isrght, bsrtol, dpivot;
extern /* Subroutine */ int slarnv_(integer*, integer*, integer*, real
*);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* To find the desired eigenvalues of a given real symmetric */
/* tridiagonal matrix T, SLARRE sets any "small" off-diagonal */
/* elements to zero, and for each unreduced block T_i, it finds */
/* (a) a suitable shift at one end of the block's spectrum, */
/* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and */
/* (c) eigenvalues of each L_i D_i L_i^T. */
/* The representations and eigenvalues found are then used by */
/* SSTEMR to compute the eigenvectors of T. */
/* The accuracy varies depending on whether bisection is used to */
/* find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to */
/* conpute all and then discard any unwanted one. */
/* As an added benefit, SLARRE also outputs the n */
/* Gerschgorin intervals for the matrices L_i D_i L_i^T. */
/* Arguments */
/* ========= */
/* RANGE (input) CHARACTER */
/* = 'A': ("All") all eigenvalues will be found. */
/* = 'V': ("Value") all eigenvalues in the half-open interval */
/* (VL, VU] will be found. */
/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
/* entire matrix) will be found. */
/* N (input) INTEGER */
/* The order of the matrix. N > 0. */
/* VL (input/output) REAL */
/* VU (input/output) REAL */
/* If RANGE='V', the lower and upper bounds for the eigenvalues. */
/* Eigenvalues less than or equal to VL, or greater than VU, */
/* will not be returned. VL < VU. */
/* If RANGE='I' or ='A', SLARRE computes bounds on the desired */
/* part of the spectrum. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the N diagonal elements of the tridiagonal */
/* matrix T. */
/* On exit, the N diagonal elements of the diagonal */
/* matrices D_i. */
/* E (input/output) REAL array, dimension (N) */
/* On entry, the first (N-1) entries contain the subdiagonal */
/* elements of the tridiagonal matrix T; E(N) need not be set. */
/* On exit, E contains the subdiagonal elements of the unit */
/* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), */
/* 1 <= I <= NSPLIT, contain the base points sigma_i on output. */
/* E2 (input/output) REAL array, dimension (N) */
/* On entry, the first (N-1) entries contain the SQUARES of the */
/* subdiagonal elements of the tridiagonal matrix T; */
/* E2(N) need not be set. */
/* On exit, the entries E2( ISPLIT( I ) ), */
/* 1 <= I <= NSPLIT, have been set to zero */
/* RTOL1 (input) REAL */
/* RTOL2 (input) REAL */
/* Parameters for bisection. */
/* An interval [LEFT,RIGHT] has converged if */
/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
/* SPLTOL (input) REAL */
/* The threshold for splitting. */
/* NSPLIT (output) INTEGER */
/* The number of blocks T splits into. 1 <= NSPLIT <= N. */
/* ISPLIT (output) INTEGER array, dimension (N) */
/* The splitting points, at which T breaks up into blocks. */
/* The first block consists of rows/columns 1 to ISPLIT(1), */
/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
/* etc., and the NSPLIT-th consists of rows/columns */
/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
/* M (output) INTEGER */
/* The total number of eigenvalues (of all L_i D_i L_i^T) */
/* found. */
/* W (output) REAL array, dimension (N) */
/* The first M elements contain the eigenvalues. The */
/* eigenvalues of each of the blocks, L_i D_i L_i^T, are */
/* sorted in ascending order ( SLARRE may use the */
/* remaining N-M elements as workspace). */
/* WERR (output) REAL array, dimension (N) */
/* The error bound on the corresponding eigenvalue in W. */
/* WGAP (output) REAL array, dimension (N) */
/* The separation from the right neighbor eigenvalue in W. */
/* The gap is only with respect to the eigenvalues of the same block */
/* as each block has its own representation tree. */
/* Exception: at the right end of a block we store the left gap */
/* IBLOCK (output) INTEGER array, dimension (N) */
/* The indices of the blocks (submatrices) associated with the */
/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
/* W(i) belongs to the first block from the top, =2 if W(i) */
/* belongs to the second block, etc. */
/* INDEXW (output) INTEGER array, dimension (N) */
/* The indices of the eigenvalues within each block (submatrix); */
/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
/* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 */
/* GERS (output) REAL array, dimension (2*N) */
/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
/* is (GERS(2*i-1), GERS(2*i)). */
/* PIVMIN (output) DOUBLE PRECISION */
/* The minimum pivot in the Sturm sequence for T. */
/* WORK (workspace) REAL array, dimension (6*N) */
/* Workspace. */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* Workspace. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: A problem occured in SLARRE. */
/* < 0: One of the called subroutines signaled an internal problem. */
/* Needs inspection of the corresponding parameter IINFO */
/* for further information. */
/* =-1: Problem in SLARRD. */
/* = 2: No base representation could be found in MAXTRY iterations. */
/* Increasing MAXTRY and recompilation might be a remedy. */
/* =-3: Problem in SLARRB when computing the refined root */
/* representation for SLASQ2. */
/* =-4: Problem in SLARRB when preforming bisection on the */
/* desired part of the spectrum. */
/* =-5: Problem in SLASQ2. */
/* =-6: Problem in SLASQ2. */
/* Further Details */
/* The base representations are required to suffer very little */
/* element growth and consequently define all their eigenvalues to */
/* high relative accuracy. */
/* =============== */
/* Based on contributions by */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iwork;
--work;
--gers;
--indexw;
--iblock;
--wgap;
--werr;
--w;
--isplit;
--e2;
--e;
--d__;
/* Function Body */
*info = 0;
/* Decode RANGE */
if (lsame_(range, "A")) {
irange = 1;
} else if (lsame_(range, "V")) {
irange = 3;
} else if (lsame_(range, "I")) {
irange = 2;
}
*m = 0;
/* Get machine constants */
safmin = slamch_("S");
eps = slamch_("P");
/* Set parameters */
rtl = eps * 100.f;
/* If one were ever to ask for less initial precision in BSRTOL, */
/* one should keep in mind that for the subset case, the extremal */
/* eigenvalues must be at least as accurate as the current setting */
/* (eigenvalues in the middle need not as much accuracy) */
bsrtol = sqrt(eps) * 5e-4f;
/* Treat case of 1x1 matrix for quick return */
if (*n == 1) {
if (irange == 1 || irange == 3 && d__[1] > *vl && d__[1] <= *vu ||
irange == 2 && *il == 1 && *iu == 1) {
*m = 1;
w[1] = d__[1];
/* The computation error of the eigenvalue is zero */
werr[1] = 0.f;
wgap[1] = 0.f;
iblock[1] = 1;
indexw[1] = 1;
gers[1] = d__[1];
gers[2] = d__[1];
}
/* store the shift for the initial RRR, which is zero in this case */
e[1] = 0.f;
return 0;
}
/* General case: tridiagonal matrix of order > 1 */
/* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. */
/* Compute maximum off-diagonal entry and pivmin. */
gl = d__[1];
gu = d__[1];
eold = 0.f;
emax = 0.f;
e[*n] = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
werr[i__] = 0.f;
wgap[i__] = 0.f;
eabs = (r__1 = e[i__], dabs(r__1));
if (eabs >= emax) {
emax = eabs;
}
tmp1 = eabs + eold;
gers[(i__ << 1) - 1] = d__[i__] - tmp1;
/* Computing MIN */
r__1 = gl, r__2 = gers[(i__ << 1) - 1];
gl = dmin(r__1, r__2);
gers[i__ * 2] = d__[i__] + tmp1;
/* Computing MAX */
r__1 = gu, r__2 = gers[i__ * 2];
gu = dmax(r__1, r__2);
eold = eabs;
/* L5: */
}
/* The minimum pivot allowed in the Sturm sequence for T */
/* Computing MAX */
/* Computing 2nd power */
r__3 = emax;
r__1 = 1.f, r__2 = r__3 * r__3;
*pivmin = safmin * dmax(r__1, r__2);
/* Compute spectral diameter. The Gerschgorin bounds give an */
/* estimate that is wrong by at most a factor of SQRT(2) */
spdiam = gu - gl;
/* Compute splitting points */
slarra_(n, &d__[1], &e[1], &e2[1], spltol, &spdiam, nsplit, &isplit[1], &
iinfo);
/* Can force use of bisection instead of faster DQDS. */
/* Option left in the code for future multisection work. */
forceb = FALSE_;
if (irange == 1 && ! forceb) {
/* Set interval [VL,VU] that contains all eigenvalues */
*vl = gl;
*vu = gu;
} else {
/* We call SLARRD to find crude approximations to the eigenvalues */
/* in the desired range. In case IRANGE = INDRNG, we also obtain the */
/* interval (VL,VU] that contains all the wanted eigenvalues. */
/* An interval [LEFT,RIGHT] has converged if */
/* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) */
/* SLARRD needs a WORK of size 4*N, IWORK of size 3*N */
slarrd_(range, "B", n, vl, vu, il, iu, &gers[1], &bsrtol, &d__[1], &e[
1], &e2[1], pivmin, nsplit, &isplit[1], &mm, &w[1], &werr[1],
vl, vu, &iblock[1], &indexw[1], &work[1], &iwork[1], &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 */
i__1 = *n;
for (i__ = mm + 1; i__ <= i__1; ++i__) {
w[i__] = 0.f;
werr[i__] = 0.f;
iblock[i__] = 0;
indexw[i__] = 0;
/* L14: */
}
}
/* ** */
/* Loop over unreduced blocks */
ibegin = 1;
wbegin = 1;
i__1 = *nsplit;
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = isplit[jblk];
in = iend - ibegin + 1;
/* 1 X 1 block */
if (in == 1) {
if (irange == 1 || irange == 3 && d__[ibegin] > *vl && d__[ibegin]
<= *vu || irange == 2 && iblock[wbegin] == jblk) {
++(*m);
w[*m] = d__[ibegin];
werr[*m] = 0.f;
/* The gap for a single block doesn't matter for the later */
/* algorithm and is assigned an arbitrary large value */
wgap[*m] = 0.f;
iblock[*m] = jblk;
indexw[*m] = 1;
++wbegin;
}
/* E( IEND ) holds the shift for the initial RRR */
e[iend] = 0.f;
ibegin = iend + 1;
goto L170;
}
/* Blocks of size larger than 1x1 */
/* E( IEND ) will hold the shift for the initial RRR, for now set it =0 */
e[iend] = 0.f;
/* Find local outer bounds GL,GU for the block */
gl = d__[ibegin];
gu = d__[ibegin];
i__2 = iend;
for (i__ = ibegin; i__ <= i__2; ++i__) {
/* Computing MIN */
r__1 = gers[(i__ << 1) - 1];
gl = dmin(r__1, gl);
/* Computing MAX */
r__1 = gers[i__ * 2];
gu = dmax(r__1, gu);
/* L15: */
}
spdiam = gu - gl;
if (!(irange == 1 && ! forceb)) {
/* Count the number of eigenvalues in the current block. */
mb = 0;
i__2 = mm;
for (i__ = wbegin; i__ <= i__2; ++i__) {
if (iblock[i__] == jblk) {
++mb;
} else {
goto L21;
}
/* L20: */
}
L21:
if (mb == 0) {
/* No eigenvalue in the current block lies in the desired range */
/* E( IEND ) holds the shift for the initial RRR */
e[iend] = 0.f;
ibegin = iend + 1;
goto L170;
} else {
/* Decide whether dqds or bisection is more efficient */
usedqd = (real) mb > in * .5f && ! forceb;
wend = wbegin + mb - 1;
/* Calculate gaps for the current block */
/* In later stages, when representations for individual */
/* eigenvalues are different, we use SIGMA = E( IEND ). */
sigma = 0.f;
i__2 = wend - 1;
for (i__ = wbegin; i__ <= i__2; ++i__) {
/* Computing MAX */
r__1 = 0.f, r__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] +
werr[i__]);
wgap[i__] = dmax(r__1, r__2);
/* L30: */
}
/* Computing MAX */
r__1 = 0.f, r__2 = *vu - sigma - (w[wend] + werr[wend]);
wgap[wend] = dmax(r__1, r__2);
/* Find local index of the first and last desired evalue. */
indl = indexw[wbegin];
indu = indexw[wend];
}
}
if (irange == 1 && ! forceb || usedqd) {
/* Case of DQDS */
/* Find approximations to the extremal eigenvalues of the block */
slarrk_(&in, &c__1, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, &
rtl, &tmp, &tmp1, &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* Computing MAX */
r__2 = gl, r__3 = tmp - tmp1 - eps * 100.f * (r__1 = tmp - tmp1,
dabs(r__1));
isleft = dmax(r__2, r__3);
slarrk_(&in, &in, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, &
rtl, &tmp, &tmp1, &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* Computing MIN */
r__2 = gu, r__3 = tmp + tmp1 + eps * 100.f * (r__1 = tmp + tmp1,
dabs(r__1));
isrght = dmin(r__2, r__3);
/* Improve the estimate of the spectral diameter */
spdiam = isrght - isleft;
} else {
/* Case of bisection */
/* Find approximations to the wanted extremal eigenvalues */
/* Computing MAX */
r__2 = gl, r__3 = w[wbegin] - werr[wbegin] - eps * 100.f * (r__1 =
w[wbegin] - werr[wbegin], dabs(r__1));
isleft = dmax(r__2, r__3);
/* Computing MIN */
r__2 = gu, r__3 = w[wend] + werr[wend] + eps * 100.f * (r__1 = w[
wend] + werr[wend], dabs(r__1));
isrght = dmin(r__2, r__3);
}
/* Decide whether the base representation for the current block */
/* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I */
/* should be on the left or the right end of the current block. */
/* The strategy is to shift to the end which is "more populated" */
/* Furthermore, decide whether to use DQDS for the computation of */
/* the eigenvalue approximations at the end of SLARRE or bisection. */
/* dqds is chosen if all eigenvalues are desired or the number of */
/* eigenvalues to be computed is large compared to the blocksize. */
if (irange == 1 && ! forceb) {
/* If all the eigenvalues have to be computed, we use dqd */
usedqd = TRUE_;
/* INDL is the local index of the first eigenvalue to compute */
indl = 1;
indu = in;
/* MB = number of eigenvalues to compute */
mb = in;
wend = wbegin + mb - 1;
/* Define 1/4 and 3/4 points of the spectrum */
s1 = isleft + spdiam * .25f;
s2 = isrght - spdiam * .25f;
} else {
/* SLARRD has computed IBLOCK and INDEXW for each eigenvalue */
/* approximation. */
/* choose sigma */
if (usedqd) {
s1 = isleft + spdiam * .25f;
s2 = isrght - spdiam * .25f;
} else {
tmp = dmin(isrght, *vu) - dmax(isleft, *vl);
s1 = dmax(isleft, *vl) + tmp * .25f;
s2 = dmin(isrght, *vu) - tmp * .25f;
}
}
/* Compute the negcount at the 1/4 and 3/4 points */
if (mb > 1) {
slarrc_("T", &in, &s1, &s2, &d__[ibegin], &e[ibegin], pivmin, &
cnt, &cnt1, &cnt2, &iinfo);
}
if (mb == 1) {
sigma = gl;
sgndef = 1.f;
} else if (cnt1 - indl >= indu - cnt2) {
if (irange == 1 && ! forceb) {
sigma = dmax(isleft, gl);
} else if (usedqd) {
/* use Gerschgorin bound as shift to get pos def matrix */
/* for dqds */
sigma = isleft;
} else {
/* use approximation of the first desired eigenvalue of the */
/* block as shift */
sigma = dmax(isleft, *vl);
}
sgndef = 1.f;
} else {
if (irange == 1 && ! forceb) {
sigma = dmin(isrght, gu);
} else if (usedqd) {
/* use Gerschgorin bound as shift to get neg def matrix */
/* for dqds */
sigma = isrght;
} else {
/* use approximation of the first desired eigenvalue of the */
/* block as shift */
sigma = dmin(isrght, *vu);
}
sgndef = -1.f;
}
/* An initial SIGMA has been chosen that will be used for computing */
/* T - SIGMA I = L D L^T */
/* Define the increment TAU of the shift in case the initial shift */
/* needs to be refined to obtain a factorization with not too much */
/* element growth. */
if (usedqd) {
/* The initial SIGMA was to the outer end of the spectrum */
/* the matrix is definite and we need not retreat. */
tau = spdiam * eps * *n + *pivmin * 2.f;
} else {
if (mb > 1) {
clwdth = w[wend] + werr[wend] - w[wbegin] - werr[wbegin];
avgap = (r__1 = clwdth / (real)(wend - wbegin), dabs(r__1));
if (sgndef == 1.f) {
/* Computing MAX */
r__1 = wgap[wbegin];
tau = dmax(r__1, avgap) * .5f;
/* Computing MAX */
r__1 = tau, r__2 = werr[wbegin];
tau = dmax(r__1, r__2);
} else {
/* Computing MAX */
r__1 = wgap[wend - 1];
tau = dmax(r__1, avgap) * .5f;
/* Computing MAX */
r__1 = tau, r__2 = werr[wend];
tau = dmax(r__1, r__2);
}
} else {
tau = werr[wbegin];
}
}
for (idum = 1; idum <= 6; ++idum) {
/* Compute L D L^T factorization of tridiagonal matrix T - sigma I. */
/* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of */
/* pivots in WORK(2*IN+1:3*IN) */
dpivot = d__[ibegin] - sigma;
work[1] = dpivot;
dmax__ = dabs(work[1]);
j = ibegin;
i__2 = in - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[(in << 1) + i__] = 1.f / work[i__];
tmp = e[j] * work[(in << 1) + i__];
work[in + i__] = tmp;
dpivot = d__[j + 1] - sigma - tmp * e[j];
work[i__ + 1] = dpivot;
/* Computing MAX */
r__1 = dmax__, r__2 = dabs(dpivot);
dmax__ = dmax(r__1, r__2);
++j;
/* L70: */
}
/* check for element growth */
if (dmax__ > spdiam * 64.f) {
norep = TRUE_;
} else {
norep = FALSE_;
}
if (usedqd && ! norep) {
/* Ensure the definiteness of the representation */
/* All entries of D (of L D L^T) must have the same sign */
i__2 = in;
for (i__ = 1; i__ <= i__2; ++i__) {
tmp = sgndef * work[i__];
if (tmp < 0.f) {
norep = TRUE_;
}
/* L71: */
}
}
if (norep) {
/* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin */
/* shift which makes the matrix definite. So we should end up */
/* here really only in the case of IRANGE = VALRNG or INDRNG. */
if (idum == 5) {
if (sgndef == 1.f) {
/* The fudged Gerschgorin shift should succeed */
sigma = gl - spdiam * 2.f * eps * *n - *pivmin * 4.f;
} else {
sigma = gu + spdiam * 2.f * eps * *n + *pivmin * 4.f;
}
} else {
sigma -= sgndef * tau;
tau *= 2.f;
}
} else {
/* an initial RRR is found */
goto L83;
}
/* L80: */
}
/* if the program reaches this point, no base representation could be */
/* found in MAXTRY iterations. */
*info = 2;
return 0;
L83:
/* At this point, we have found an initial base representation */
/* T - SIGMA I = L D L^T with not too much element growth. */
/* Store the shift. */
e[iend] = sigma;
/* Store D and L. */
scopy_(&in, &work[1], &c__1, &d__[ibegin], &c__1);
i__2 = in - 1;
scopy_(&i__2, &work[in + 1], &c__1, &e[ibegin], &c__1);
if (mb > 1) {
/* Perturb each entry of the base representation by a small */
/* (but random) relative amount to overcome difficulties with */
/* glued matrices. */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = 1;
/* L122: */
}
i__2 = (in << 1) - 1;
slarnv_(&c__2, iseed, &i__2, &work[1]);
i__2 = in - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
d__[ibegin + i__ - 1] *= eps * 4.f * work[i__] + 1.f;
e[ibegin + i__ - 1] *= eps * 4.f * work[in + i__] + 1.f;
/* L125: */
}
d__[iend] *= eps * 4.f * work[in] + 1.f;
}
/* Don't update the Gerschgorin intervals because keeping track */
/* of the updates would be too much work in SLARRV. */
/* We update W instead and use it to locate the proper Gerschgorin */
/* intervals. */
/* Compute the required eigenvalues of L D L' by bisection or dqds */
if (! usedqd) {
/* If SLARRD has been used, shift the eigenvalue approximations */
/* according to their representation. This is necessary for */
/* a uniform SLARRV since dqds computes eigenvalues of the */
/* shifted representation. In SLARRV, W will always hold the */
/* UNshifted eigenvalue approximation. */
i__2 = wend;
for (j = wbegin; j <= i__2; ++j) {
w[j] -= sigma;
werr[j] += (r__1 = w[j], dabs(r__1)) * eps;
/* L134: */
}
/* call SLARRB to reduce eigenvalue error of the approximations */
/* from SLARRD */
i__2 = iend - 1;
for (i__ = ibegin; i__ <= i__2; ++i__) {
/* Computing 2nd power */
r__1 = e[i__];
work[i__] = d__[i__] * (r__1 * r__1);
/* L135: */
}
/* use bisection to find EV from INDL to INDU */
i__2 = indl - 1;
slarrb_(&in, &d__[ibegin], &work[ibegin], &indl, &indu, rtol1,
rtol2, &i__2, &w[wbegin], &wgap[wbegin], &werr[wbegin], &
work[(*n << 1) + 1], &iwork[1], pivmin, &spdiam, &in, &
iinfo);
if (iinfo != 0) {
*info = -4;
return 0;
}
/* SLARRB computes all gaps correctly except for the last one */
/* Record distance to VU/GU */
/* Computing MAX */
r__1 = 0.f, r__2 = *vu - sigma - (w[wend] + werr[wend]);
wgap[wend] = dmax(r__1, r__2);
i__2 = indu;
for (i__ = indl; i__ <= i__2; ++i__) {
++(*m);
iblock[*m] = jblk;
indexw[*m] = i__;
/* L138: */
}
} else {
/* Call dqds to get all eigs (and then possibly delete unwanted */
/* eigenvalues). */
/* Note that dqds finds the eigenvalues of the L D L^T representation */
/* of T to high relative accuracy. High relative accuracy */
/* might be lost when the shift of the RRR is subtracted to obtain */
/* the eigenvalues of T. However, T is not guaranteed to define its */
/* eigenvalues to high relative accuracy anyway. */
/* Set RTOL to the order of the tolerance used in SLASQ2 */
/* This is an ESTIMATED error, the worst case bound is 4*N*EPS */
/* which is usually too large and requires unnecessary work to be */
/* done by bisection when computing the eigenvectors */
rtol = log((real) in) * 4.f * eps;
j = ibegin;
i__2 = in - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[(i__ << 1) - 1] = (r__1 = d__[j], dabs(r__1));
work[i__ * 2] = e[j] * e[j] * work[(i__ << 1) - 1];
++j;
/* L140: */
}
work[(in << 1) - 1] = (r__1 = d__[iend], dabs(r__1));
work[in * 2] = 0.f;
slasq2_(&in, &work[1], &iinfo);
if (iinfo != 0) {
/* If IINFO = -5 then an index is part of a tight cluster */
/* and should be changed. The index is in IWORK(1) and the */
/* gap is in WORK(N+1) */
*info = -5;
return 0;
} else {
/* Test that all eigenvalues are positive as expected */
i__2 = in;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] < 0.f) {
*info = -6;
return 0;
}
/* L149: */
}
}
if (sgndef > 0.f) {
i__2 = indu;
for (i__ = indl; i__ <= i__2; ++i__) {
++(*m);
w[*m] = work[in - i__ + 1];
iblock[*m] = jblk;
indexw[*m] = i__;
/* L150: */
}
} else {
i__2 = indu;
for (i__ = indl; i__ <= i__2; ++i__) {
++(*m);
w[*m] = -work[i__];
iblock[*m] = jblk;
indexw[*m] = i__;
/* L160: */
}
}
i__2 = *m;
for (i__ = *m - mb + 1; i__ <= i__2; ++i__) {
/* the value of RTOL below should be the tolerance in SLASQ2 */
werr[i__] = rtol * (r__1 = w[i__], dabs(r__1));
/* L165: */
}
i__2 = *m - 1;
for (i__ = *m - mb + 1; i__ <= i__2; ++i__) {
/* compute the right gap between the intervals */
/* Computing MAX */
r__1 = 0.f, r__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] +
werr[i__]);
wgap[i__] = dmax(r__1, r__2);
/* L166: */
}
/* Computing MAX */
r__1 = 0.f, r__2 = *vu - sigma - (w[*m] + werr[*m]);
wgap[*m] = dmax(r__1, r__2);
}
/* proceed with next block */
ibegin = iend + 1;
wbegin = wend + 1;
L170:
;
}
return 0;
/* end of SLARRE */
} /* slarre_ */
/* Subroutine */ int slattp_(integer *imat, char *uplo, char *trans, char *
diag, integer *iseed, integer *n, real *a, real *b, real *work,
integer *info)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
doublereal d__1, d__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double pow_dd(doublereal *, doublereal *), sqrt(doublereal), r_sign(real *
, real *);
/* Local variables */
real c__;
integer i__, j;
real s, t, x, y, z__;
integer jc;
real ra;
integer jj;
real rb;
integer jl, kl, jr, ku, iy, jx;
real ulp, sfac;
integer mode;
char path[3], dist[1];
real unfl, rexp;
char type__[1];
real texp;
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *);
real star1, plus1, plus2, bscal;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal, anorm, bnorm, tleft, stemp;
logical upper;
extern /* Subroutine */ int srotg_(real *, real *, real *, real *),
slatb4_(char *, integer *, integer *, integer *, char *, integer *
, integer *, real *, integer *, real *, char *), slabad_(real *, real *);
extern doublereal slamch_(char *);
char packit[1];
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal slarnd_(integer *, integer *);
real cndnum;
integer jcnext, jcount;
extern /* Subroutine */ int slatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, real *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
real smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLATTP generates a triangular test matrix in packed storage. */
/* IMAT and UPLO uniquely specify the properties of the test */
/* matrix, which is returned in the array AP. */
/* Arguments */
/* ========= */
/* IMAT (input) INTEGER */
/* An integer key describing which matrix to generate for this */
/* path. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A will be upper or lower */
/* triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies whether the matrix or its transpose will be used. */
/* = 'N': No transpose */
/* = 'T': Transpose */
/* = 'C': Conjugate transpose (= Transpose) */
/* DIAG (output) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* SLATMS). Modified on exit. */
/* N (input) INTEGER */
/* The order of the matrix to be generated. */
/* A (output) REAL array, dimension (N*(N+1)/2) */
/* The upper or lower triangular matrix A, packed columnwise in */
/* a linear array. The j-th column of A is stored in the array */
/* AP as follows: */
/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
/* B (output) REAL array, dimension (N) */
/* The right hand side vector, if IMAT > 10. */
/* WORK (workspace) REAL array, dimension (3*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--b;
--a;
--iseed;
/* Function Body */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
unfl = slamch_("Safe minimum");
ulp = slamch_("Epsilon") * slamch_("Base");
smlnum = unfl;
bignum = (1.f - ulp) / smlnum;
slabad_(&smlnum, &bignum);
if (*imat >= 7 && *imat <= 10 || *imat == 18) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
*info = 0;
/* Quick return if N.LE.0. */
if (*n <= 0) {
return 0;
}
/* Call SLATB4 to set parameters for SLATMS. */
upper = lsame_(uplo, "U");
if (upper) {
slatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
*(unsigned char *)packit = 'C';
} else {
i__1 = -(*imat);
slatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
dist);
*(unsigned char *)packit = 'R';
}
/* IMAT <= 6: Non-unit triangular matrix */
if (*imat <= 6) {
slatms_(n, n, dist, &iseed[1], type__, &b[1], &mode, &cndnum, &anorm,
&kl, &ku, packit, &a[1], n, &work[1], info);
/* IMAT > 6: Unit triangular matrix */
/* The diagonal is deliberately set to something other than 1. */
/* IMAT = 7: Matrix is the identity */
} else if (*imat == 7) {
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
a[jc + i__ - 1] = 0.f;
/* L10: */
}
a[jc + j - 1] = (real) j;
jc += j;
/* L20: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
a[jc] = (real) j;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[jc + i__ - j] = 0.f;
/* L30: */
}
jc = jc + *n - j + 1;
/* L40: */
}
}
/* IMAT > 7: Non-trivial unit triangular matrix */
/* Generate a unit triangular matrix T with condition CNDNUM by */
/* forming a triangular matrix with known singular values and */
/* filling in the zero entries with Givens rotations. */
} else if (*imat <= 10) {
if (upper) {
jc = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
a[jc + i__] = 0.f;
/* L50: */
}
a[jc + j] = (real) j;
jc += j;
/* L60: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
a[jc] = (real) j;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[jc + i__ - j] = 0.f;
/* L70: */
}
jc = jc + *n - j + 1;
/* L80: */
}
}
/* Since the trace of a unit triangular matrix is 1, the product */
/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
/* The following triangular matrix has singular values s, 1, 1, */
/* ..., 1, 1/s: */
/* 1 y y y ... y y z */
/* 1 0 0 ... 0 0 y */
/* 1 0 ... 0 0 y */
/* . ... . . . */
/* . . . . */
/* 1 0 y */
/* 1 y */
/* 1 */
/* To fill in the zeros, we first multiply by a matrix with small */
/* condition number of the form */
/* 1 0 0 0 0 ... */
/* 1 + * 0 0 ... */
/* 1 + 0 0 0 */
/* 1 + * 0 0 */
/* 1 + 0 0 */
/* ... */
/* 1 + 0 */
/* 1 0 */
/* 1 */
/* Each element marked with a '*' is formed by taking the product */
/* of the adjacent elements marked with '+'. The '*'s can be */
/* chosen freely, and the '+'s are chosen so that the inverse of */
/* T will have elements of the same magnitude as T. If the *'s in */
/* both T and inv(T) have small magnitude, T is well conditioned. */
/* The two offdiagonals of T are stored in WORK. */
/* The product of these two matrices has the form */
/* 1 y y y y y . y y z */
/* 1 + * 0 0 . 0 0 y */
/* 1 + 0 0 . 0 0 y */
/* 1 + * . . . . */
/* 1 + . . . . */
/* . . . . . */
/* . . . . */
/* 1 + y */
/* 1 y */
/* 1 */
/* Now we multiply by Givens rotations, using the fact that */
/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
/* and */
/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
star1 = .25f;
sfac = .5f;
plus1 = sfac;
i__1 = *n;
for (j = 1; j <= i__1; j += 2) {
plus2 = star1 / plus1;
work[j] = plus1;
work[*n + j] = star1;
if (j + 1 <= *n) {
work[j + 1] = plus2;
work[*n + j + 1] = 0.f;
plus1 = star1 / plus2;
rexp = slarnd_(&c__2, &iseed[1]);
d__1 = (doublereal) sfac;
d__2 = (doublereal) rexp;
star1 *= pow_dd(&d__1, &d__2);
if (rexp < 0.f) {
d__1 = (doublereal) sfac;
d__2 = (doublereal) (1.f - rexp);
star1 = -pow_dd(&d__1, &d__2);
} else {
d__1 = (doublereal) sfac;
d__2 = (doublereal) (rexp + 1.f);
star1 = pow_dd(&d__1, &d__2);
}
}
/* L90: */
}
x = sqrt(cndnum) - 1.f / sqrt(cndnum);
if (*n > 2) {
y = sqrt(2.f / (real) (*n - 2)) * x;
} else {
y = 0.f;
}
z__ = x * x;
if (upper) {
/* Set the upper triangle of A with a unit triangular matrix */
/* of known condition number. */
jc = 1;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
a[jc + 1] = y;
if (j > 2) {
a[jc + j - 1] = work[j - 2];
}
if (j > 3) {
a[jc + j - 2] = work[*n + j - 3];
}
jc += j;
/* L100: */
}
jc -= *n;
a[jc + 1] = z__;
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
a[jc + j] = y;
/* L110: */
}
} else {
/* Set the lower triangle of A with a unit triangular matrix */
/* of known condition number. */
i__1 = *n - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
a[i__] = y;
/* L120: */
}
a[*n] = z__;
jc = *n + 1;
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
a[jc + 1] = work[j - 1];
if (j < *n - 1) {
a[jc + 2] = work[*n + j - 1];
}
a[jc + *n - j] = y;
jc = jc + *n - j + 1;
/* L130: */
}
}
/* Fill in the zeros using Givens rotations */
if (upper) {
jc = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
jcnext = jc + j;
ra = a[jcnext + j - 1];
rb = 2.f;
srotg_(&ra, &rb, &c__, &s);
/* Multiply by [ c s; -s c] on the left. */
if (*n > j + 1) {
jx = jcnext + j;
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
stemp = c__ * a[jx + j] + s * a[jx + j + 1];
a[jx + j + 1] = -s * a[jx + j] + c__ * a[jx + j + 1];
a[jx + j] = stemp;
jx += i__;
/* L140: */
}
}
/* Multiply by [-c -s; s -c] on the right. */
if (j > 1) {
i__2 = j - 1;
r__1 = -c__;
r__2 = -s;
srot_(&i__2, &a[jcnext], &c__1, &a[jc], &c__1, &r__1, &
r__2);
}
/* Negate A(J,J+1). */
a[jcnext + j - 1] = -a[jcnext + j - 1];
jc = jcnext;
/* L150: */
}
} else {
jc = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
jcnext = jc + *n - j + 1;
ra = a[jc + 1];
rb = 2.f;
srotg_(&ra, &rb, &c__, &s);
/* Multiply by [ c -s; s c] on the right. */
if (*n > j + 1) {
i__2 = *n - j - 1;
r__1 = -s;
srot_(&i__2, &a[jcnext + 1], &c__1, &a[jc + 2], &c__1, &
c__, &r__1);
}
/* Multiply by [-c s; -s -c] on the left. */
if (j > 1) {
jx = 1;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
stemp = -c__ * a[jx + j - i__] + s * a[jx + j - i__ +
1];
a[jx + j - i__ + 1] = -s * a[jx + j - i__] - c__ * a[
jx + j - i__ + 1];
a[jx + j - i__] = stemp;
jx = jx + *n - i__ + 1;
/* L160: */
}
}
/* Negate A(J+1,J). */
a[jc + 1] = -a[jc + 1];
jc = jcnext;
/* L170: */
}
}
/* IMAT > 10: Pathological test cases. These triangular matrices */
/* are badly scaled or badly conditioned, so when used in solving a */
/* triangular system they may cause overflow in the solution vector. */
} else if (*imat == 11) {
/* Type 11: Generate a triangular matrix with elements between */
/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
/* Make the right hand side large so that it requires scaling. */
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
slarnv_(&c__2, &iseed[1], &j, &a[jc]);
a[jc + j - 1] = r_sign(&c_b36, &a[jc + j - 1]);
jc += j;
/* L180: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
a[jc] = r_sign(&c_b36, &a[jc]);
jc = jc + *n - j + 1;
/* L190: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
slarnv_(&c__2, &iseed[1], n, &b[1]);
iy = isamax_(n, &b[1], &c__1);
bnorm = (r__1 = b[iy], dabs(r__1));
bscal = bignum / dmax(1.f,bnorm);
sscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 12) {
/* Type 12: Make the first diagonal element in the solve small to */
/* cause immediate overflow when dividing by T(j,j). */
/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
slarnv_(&c__2, &iseed[1], n, &b[1]);
/* Computing MAX */
r__1 = 1.f, r__2 = (real) (*n - 1);
tscal = 1.f / dmax(r__1,r__2);
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
i__2 = j - 1;
sscal_(&i__2, &tscal, &a[jc], &c__1);
r__1 = slarnd_(&c__2, &iseed[1]);
a[jc + j - 1] = r_sign(&c_b48, &r__1);
jc += j;
/* L200: */
}
a[*n * (*n + 1) / 2] = smlnum;
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
i__2 = *n - j;
sscal_(&i__2, &tscal, &a[jc + 1], &c__1);
r__1 = slarnd_(&c__2, &iseed[1]);
a[jc] = r_sign(&c_b48, &r__1);
jc = jc + *n - j + 1;
/* L210: */
}
a[1] = smlnum;
}
} else if (*imat == 13) {
/* Type 13: Make the first diagonal element in the solve small to */
/* cause immediate overflow when dividing by T(j,j). */
/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
slarnv_(&c__2, &iseed[1], n, &b[1]);
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
r__1 = slarnd_(&c__2, &iseed[1]);
a[jc + j - 1] = r_sign(&c_b48, &r__1);
jc += j;
/* L220: */
}
a[*n * (*n + 1) / 2] = smlnum;
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
r__1 = slarnd_(&c__2, &iseed[1]);
a[jc] = r_sign(&c_b48, &r__1);
jc = jc + *n - j + 1;
/* L230: */
}
a[1] = smlnum;
}
} else if (*imat == 14) {
/* Type 14: T is diagonal with small numbers on the diagonal to */
/* make the growth factor underflow, but a small right hand side */
/* chosen so that the solution does not overflow. */
if (upper) {
jcount = 1;
jc = (*n - 1) * *n / 2 + 1;
for (j = *n; j >= 1; --j) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
a[jc + i__ - 1] = 0.f;
/* L240: */
}
if (jcount <= 2) {
a[jc + j - 1] = smlnum;
} else {
a[jc + j - 1] = 1.f;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
jc = jc - j + 1;
/* L250: */
}
} else {
jcount = 1;
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[jc + i__ - j] = 0.f;
/* L260: */
}
if (jcount <= 2) {
a[jc] = smlnum;
} else {
a[jc] = 1.f;
}
++jcount;
if (jcount > 4) {
jcount = 1;
}
jc = jc + *n - j + 1;
/* L270: */
}
}
/* Set the right hand side alternately zero and small. */
if (upper) {
b[1] = 0.f;
for (i__ = *n; i__ >= 2; i__ += -2) {
b[i__] = 0.f;
b[i__ - 1] = smlnum;
/* L280: */
}
} else {
b[*n] = 0.f;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; i__ += 2) {
b[i__] = 0.f;
b[i__ + 1] = smlnum;
/* L290: */
}
}
} else if (*imat == 15) {
/* Type 15: Make the diagonal elements small to cause gradual */
/* overflow when dividing by T(j,j). To control the amount of */
/* scaling needed, the matrix is bidiagonal. */
/* Computing MAX */
r__1 = 1.f, r__2 = (real) (*n - 1);
texp = 1.f / dmax(r__1,r__2);
d__1 = (doublereal) smlnum;
d__2 = (doublereal) texp;
tscal = pow_dd(&d__1, &d__2);
slarnv_(&c__2, &iseed[1], n, &b[1]);
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 2;
for (i__ = 1; i__ <= i__2; ++i__) {
a[jc + i__ - 1] = 0.f;
/* L300: */
}
if (j > 1) {
a[jc + j - 2] = -1.f;
}
a[jc + j - 1] = tscal;
jc += j;
/* L310: */
}
b[*n] = 1.f;
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
a[jc + i__ - j] = 0.f;
/* L320: */
}
if (j < *n) {
a[jc + 1] = -1.f;
}
a[jc] = tscal;
jc = jc + *n - j + 1;
/* L330: */
}
b[1] = 1.f;
}
} else if (*imat == 16) {
/* Type 16: One zero diagonal element. */
iy = *n / 2 + 1;
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
slarnv_(&c__2, &iseed[1], &j, &a[jc]);
if (j != iy) {
a[jc + j - 1] = r_sign(&c_b36, &a[jc + j - 1]);
} else {
a[jc + j - 1] = 0.f;
}
jc += j;
/* L340: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
if (j != iy) {
a[jc] = r_sign(&c_b36, &a[jc]);
} else {
a[jc] = 0.f;
}
jc = jc + *n - j + 1;
/* L350: */
}
}
slarnv_(&c__2, &iseed[1], n, &b[1]);
sscal_(n, &c_b36, &b[1], &c__1);
} else if (*imat == 17) {
/* Type 17: Make the offdiagonal elements large to cause overflow */
/* when adding a column of T. In the non-transposed case, the */
/* matrix is constructed to cause overflow when adding a column in */
/* every other step. */
tscal = unfl / ulp;
tscal = (1.f - ulp) / tscal;
i__1 = *n * (*n + 1) / 2;
for (j = 1; j <= i__1; ++j) {
a[j] = 0.f;
/* L360: */
}
texp = 1.f;
if (upper) {
jc = (*n - 1) * *n / 2 + 1;
for (j = *n; j >= 2; j += -2) {
a[jc] = -tscal / (real) (*n + 1);
a[jc + j - 1] = 1.f;
b[j] = texp * (1.f - ulp);
jc = jc - j + 1;
a[jc] = -(tscal / (real) (*n + 1)) / (real) (*n + 2);
a[jc + j - 2] = 1.f;
b[j - 1] = texp * (real) (*n * *n + *n - 1);
texp *= 2.f;
jc = jc - j + 2;
/* L370: */
}
b[1] = (real) (*n + 1) / (real) (*n + 2) * tscal;
} else {
jc = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; j += 2) {
a[jc + *n - j] = -tscal / (real) (*n + 1);
a[jc] = 1.f;
b[j] = texp * (1.f - ulp);
jc = jc + *n - j + 1;
a[jc + *n - j - 1] = -(tscal / (real) (*n + 1)) / (real) (*n
+ 2);
a[jc] = 1.f;
b[j + 1] = texp * (real) (*n * *n + *n - 1);
texp *= 2.f;
jc = jc + *n - j;
/* L380: */
}
b[*n] = (real) (*n + 1) / (real) (*n + 2) * tscal;
}
} else if (*imat == 18) {
/* Type 18: Generate a unit triangular matrix with elements */
/* between -1 and 1, and make the right hand side large so that it */
/* requires scaling. */
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
a[jc + j - 1] = 0.f;
jc += j;
/* L390: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < *n) {
i__2 = *n - j;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
}
a[jc] = 0.f;
jc = jc + *n - j + 1;
/* L400: */
}
}
/* Set the right hand side so that the largest value is BIGNUM. */
slarnv_(&c__2, &iseed[1], n, &b[1]);
iy = isamax_(n, &b[1], &c__1);
bnorm = (r__1 = b[iy], dabs(r__1));
bscal = bignum / dmax(1.f,bnorm);
sscal_(n, &bscal, &b[1], &c__1);
} else if (*imat == 19) {
/* Type 19: Generate a triangular matrix with elements between */
/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
/* norms will exceed BIGNUM. */
/* Computing MAX */
r__1 = 1.f, r__2 = (real) (*n - 1);
tleft = bignum / dmax(r__1,r__2);
/* Computing MAX */
r__1 = 1.f, r__2 = (real) (*n);
tscal = bignum * ((real) (*n - 1) / dmax(r__1,r__2));
if (upper) {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
slarnv_(&c__2, &iseed[1], &j, &a[jc]);
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
a[jc + i__ - 1] = r_sign(&tleft, &a[jc + i__ - 1]) +
tscal * a[jc + i__ - 1];
/* L410: */
}
jc += j;
/* L420: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
a[jc + i__ - j] = r_sign(&tleft, &a[jc + i__ - j]) +
tscal * a[jc + i__ - j];
/* L430: */
}
jc = jc + *n - j + 1;
/* L440: */
}
}
slarnv_(&c__2, &iseed[1], n, &b[1]);
sscal_(n, &c_b36, &b[1], &c__1);
}
/* Flip the matrix across its counter-diagonal if the transpose will */
/* be used. */
if (! lsame_(trans, "N")) {
if (upper) {
jj = 1;
jr = *n * (*n + 1) / 2;
i__1 = *n / 2;
for (j = 1; j <= i__1; ++j) {
jl = jj;
i__2 = *n - j;
for (i__ = j; i__ <= i__2; ++i__) {
t = a[jr - i__ + j];
a[jr - i__ + j] = a[jl];
a[jl] = t;
jl += i__;
/* L450: */
}
jj = jj + j + 1;
jr -= *n - j + 1;
/* L460: */
}
} else {
jl = 1;
jj = *n * (*n + 1) / 2;
i__1 = *n / 2;
for (j = 1; j <= i__1; ++j) {
jr = jj;
i__2 = *n - j;
for (i__ = j; i__ <= i__2; ++i__) {
t = a[jl + i__ - j];
a[jl + i__ - j] = a[jr];
a[jr] = t;
jr -= i__;
/* L470: */
}
jl = jl + *n - j + 1;
jj = jj - j - 1;
/* L480: */
}
}
}
return 0;
/* End of SLATTP */
} /* slattp_ */
/* Subroutine */ int slatm1_(integer *mode, real *cond, integer *irsign,
integer *idist, integer *iseed, real *d__, integer *n, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *), pow_ri(real *, integer *), log(
doublereal), exp(doublereal);
/* Local variables */
integer i__;
real temp, alpha;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal slaran_(integer *);
extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
*);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLATM1 computes the entries of D(1..N) as specified by */
/* MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
/* of random numbers. SLATM1 is called by SLATMR to generate */
/* random test matrices for LAPACK programs. */
/* Arguments */
/* ========= */
/* MODE - INTEGER */
/* On entry describes how D is to be computed: */
/* MODE = 0 means do not change D. */
/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
/* MODE = 5 sets D to random numbers in the range */
/* ( 1/COND , 1 ) such that their logarithms */
/* are uniformly distributed. */
/* MODE = 6 set D to random numbers from same distribution */
/* as the rest of the matrix. */
/* MODE < 0 has the same meaning as ABS(MODE), except that */
/* the order of the elements of D is reversed. */
/* Thus if MODE is positive, D has entries ranging from */
/* 1 to 1/COND, if negative, from 1/COND to 1, */
/* Not modified. */
/* COND - REAL */
/* On entry, used as described under MODE above. */
/* If used, it must be >= 1. Not modified. */
/* IRSIGN - INTEGER */
/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
/* entries of D */
/* 0 => leave entries of D unchanged */
/* 1 => multiply each entry of D by 1 or -1 with probability .5 */
/* IDIST - CHARACTER*1 */
/* On entry, IDIST specifies the type of distribution to be */
/* used to generate a random matrix . */
/* 1 => UNIFORM( 0, 1 ) */
/* 2 => UNIFORM( -1, 1 ) */
/* 3 => NORMAL( 0, 1 ) */
/* Not modified. */
/* ISEED - INTEGER array, dimension ( 4 ) */
/* On entry ISEED specifies the seed of the random number */
/* generator. 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 SLATM1 */
/* to continue the same random number sequence. */
/* Changed on exit. */
/* D - REAL array, dimension ( MIN( M , N ) ) */
/* Array to be computed according to MODE, COND and IRSIGN. */
/* May be changed on exit if MODE is nonzero. */
/* N - INTEGER */
/* Number of entries of D. Not modified. */
/* INFO - INTEGER */
/* 0 => normal termination */
/* -1 => if MODE not in range -6 to 6 */
/* -2 => if MODE neither -6, 0 nor 6, and */
/* IRSIGN neither 0 nor 1 */
/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
/* -7 => if N negative */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test the input parameters. Initialize flags & seed. */
/* Parameter adjustments */
--d__;
--iseed;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Set INFO if an error */
if (*mode < -6 || *mode > 6) {
*info = -1;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
irsign != 1)) {
*info = -2;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) {
*info = -3;
} else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
*info = -4;
} else if (*n < 0) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLATM1", &i__1);
return 0;
}
/* Compute D according to COND and MODE */
if (*mode != 0) {
switch (abs(*mode)) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L70;
case 5: goto L90;
case 6: goto L110;
}
/* One large D value: */
L10:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = 1.f / *cond;
/* L20: */
}
d__[1] = 1.f;
goto L120;
/* One small D value: */
L30:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = 1.f;
/* L40: */
}
d__[*n] = 1.f / *cond;
goto L120;
/* Exponentially distributed D values: */
L50:
d__[1] = 1.f;
if (*n > 1) {
d__1 = (doublereal) (*cond);
d__2 = (doublereal) (-1.f / (real) (*n - 1));
alpha = pow_dd(&d__1, &d__2);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
d__[i__] = pow_ri(&alpha, &i__2);
/* L60: */
}
}
goto L120;
/* Arithmetically distributed D values: */
L70:
d__[1] = 1.f;
if (*n > 1) {
temp = 1.f / *cond;
alpha = (1.f - temp) / (real) (*n - 1);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
d__[i__] = (real) (*n - i__) * alpha + temp;
/* L80: */
}
}
goto L120;
/* Randomly distributed D values on ( 1/COND , 1): */
L90:
alpha = log(1.f / *cond);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = exp(alpha * slaran_(&iseed[1]));
/* L100: */
}
goto L120;
/* Randomly distributed D values from IDIST */
L110:
slarnv_(idist, &iseed[1], n, &d__[1]);
L120:
/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
/* random signs to D */
if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = slaran_(&iseed[1]);
if (temp > .5f) {
d__[i__] = -d__[i__];
}
/* L130: */
}
}
/* Reverse if MODE < 0 */
if (*mode < 0) {
i__1 = *n / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = d__[i__];
d__[i__] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = temp;
/* L140: */
}
}
}
return 0;
/* End of SLATM1 */
} /* slatm1_ */
/* Subroutine */ int slatme_(integer *n, char *dist, integer *iseed, real *
d__, integer *mode, real *cond, real *dmax__, char *ei, char *rsign,
char *upper, char *sim, real *ds, integer *modes, real *conds,
integer *kl, integer *ku, real *anorm, real *a, integer *lda, real *
work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1, r__2, r__3;
/* Local variables */
static logical bads;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
static integer isim;
static real temp;
static logical badei;
static integer i__, j;
static real alpha;
extern logical lsame_(char *, char *);
static integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real tempa[1];
static integer icols;
static logical useei;
static integer idist;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *);
static integer irows;
extern /* Subroutine */ int slatm1_(integer *, real *, integer *, integer
*, integer *, real *, integer *, integer *);
static integer ic, jc, ir, jr;
extern doublereal slange_(char *, integer *, integer *, real *, integer *,
real *);
extern /* Subroutine */ int slarge_(integer *, real *, integer *, integer
*, real *, integer *), slarfg_(integer *, real *, real *, integer
*, real *), xerbla_(char *, integer *);
extern doublereal slaran_(integer *);
static integer irsign;
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
static integer iupper;
extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
*);
static real xnorms;
static integer jcr;
static real tau;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SLATME generates random non-symmetric square matrices with
specified eigenvalues for testing LAPACK programs.
SLATME operates by applying the following sequence of
operations:
1. Set the diagonal to D, where D may be input or
computed according to MODE, COND, DMAX, and RSIGN
as described below.
2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R',
or MODE=5), certain pairs of adjacent elements of D are
interpreted as the real and complex parts of a complex
conjugate pair; A thus becomes block diagonal, with 1x1
and 2x2 blocks.
3. If UPPER='T', the upper triangle of A is set to random values
out of distribution DIST.
4. If SIM='T', A is multiplied on the left by a random matrix
X, whose singular values are specified by DS, MODES, and
CONDS, and on the right by X inverse.
5. If KL < N-1, the lower bandwidth is reduced to KL using
Householder transformations. If KU < N-1, the upper
bandwidth is reduced to KU.
6. If ANORM is not negative, the matrix is scaled to have
maximum-element-norm ANORM.
(Note: since the matrix cannot be reduced beyond Hessenberg form,
no packing options are available.)
Arguments
=========
N - INTEGER
The number of columns (or rows) of A. Not modified.
DIST - CHARACTER*1
On entry, DIST specifies the type of distribution to be used
to generate the random eigen-/singular values, and for the
upper triangle (see UPPER).
'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
'N' => NORMAL( 0, 1 ) ( 'N' for normal )
Not modified.
ISEED - INTEGER array, dimension ( 4 )
On entry ISEED specifies the seed of the random number
generator. They should lie between 0 and 4095 inclusive,
and ISEED(4) should 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 SLATME
to continue the same random number sequence.
Changed on exit.
D - REAL array, dimension ( N )
This array is used to specify the eigenvalues of A. If
MODE=0, then D is assumed to contain the eigenvalues (but
see the description of EI), otherwise they will be
computed according to MODE, COND, DMAX, and RSIGN and
placed in D.
Modified if MODE is nonzero.
MODE - INTEGER
On entry this describes how the eigenvalues are to
be specified:
MODE = 0 means use D (with EI) as input
MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
MODE = 5 sets D to random numbers in the range
( 1/COND , 1 ) such that their logarithms
are uniformly distributed. Each odd-even pair
of elements will be either used as two real
eigenvalues or as the real and imaginary part
of a complex conjugate pair of eigenvalues;
the choice of which is done is random, with
50-50 probability, for each pair.
MODE = 6 set D to random numbers from same distribution
as the rest of the matrix.
MODE < 0 has the same meaning as ABS(MODE), except that
the order of the elements of D is reversed.
Thus if MODE is between 1 and 4, D has entries ranging
from 1 to 1/COND, if between -1 and -4, D has entries
ranging from 1/COND to 1,
Not modified.
COND - REAL
On entry, this is used as described under MODE above.
If used, it must be >= 1. Not modified.
DMAX - REAL
If MODE is neither -6, 0 nor 6, the contents of D, as
computed according to MODE and COND, will be scaled by
DMAX / max(abs(D(i))). Note that DMAX need not be
positive: if DMAX is negative (or zero), D will be
scaled by a negative number (or zero).
Not modified.
EI - CHARACTER*1 array, dimension ( N )
If MODE is 0, and EI(1) is not ' ' (space character),
this array specifies which elements of D (on input) are
real eigenvalues and which are the real and imaginary parts
of a complex conjugate pair of eigenvalues. The elements
of EI may then only have the values 'R' and 'I'. If
EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is
CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex
conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th
eigenvalue is D(j) (i.e., real). EI(1) may not be 'I',
nor may two adjacent elements of EI both have the value 'I'.
If MODE is not 0, then EI is ignored. If MODE is 0 and
EI(1)=' ', then the eigenvalues will all be real.
Not modified.
RSIGN - CHARACTER*1
If MODE is not 0, 6, or -6, and RSIGN='T', then the
elements of D, as computed according to MODE and COND, will
be multiplied by a random sign (+1 or -1). If RSIGN='F',
they will not be. RSIGN may only have the values 'T' or
'F'.
Not modified.
UPPER - CHARACTER*1
If UPPER='T', then the elements of A above the diagonal
(and above the 2x2 diagonal blocks, if A has complex
eigenvalues) will be set to random numbers out of DIST.
If UPPER='F', they will not. UPPER may only have the
values 'T' or 'F'.
Not modified.
SIM - CHARACTER*1
If SIM='T', then A will be operated on by a "similarity
transform", i.e., multiplied on the left by a matrix X and
on the right by X inverse. X = U S V, where U and V are
random unitary matrices and S is a (diagonal) matrix of
singular values specified by DS, MODES, and CONDS. If
SIM='F', then A will not be transformed.
Not modified.
DS - REAL array, dimension ( N )
This array is used to specify the singular values of X,
in the same way that D specifies the eigenvalues of A.
If MODE=0, the DS contains the singular values, which
may not be zero.
Modified if MODE is nonzero.
MODES - INTEGER
CONDS - REAL
Same as MODE and COND, but for specifying the diagonal
of S. MODES=-6 and +6 are not allowed (since they would
result in randomly ill-conditioned eigenvalues.)
KL - INTEGER
This specifies the lower bandwidth of the matrix. KL=1
specifies upper Hessenberg form. If KL is at least N-1,
then A will have full lower bandwidth. KL must be at
least 1.
Not modified.
KU - INTEGER
This specifies the upper bandwidth of the matrix. KU=1
specifies lower Hessenberg form. If KU is at least N-1,
then A will have full upper bandwidth; if KU and KL
are both at least N-1, then A will be dense. Only one of
KU and KL may be less than N-1. KU must be at least 1.
Not modified.
ANORM - REAL
If ANORM is not negative, then A will be scaled by a non-
negative real number to make the maximum-element-norm of A
to be ANORM.
Not modified.
A - REAL array, dimension ( LDA, N )
On exit A is the desired test matrix.
Modified.
LDA - INTEGER
LDA specifies the first dimension of A as declared in the
calling program. LDA must be at least N.
Not modified.
WORK - REAL array, dimension ( 3*N )
Workspace.
Modified.
INFO - INTEGER
Error code. On exit, INFO will be set to one of the
following values:
0 => normal return
-1 => N negative
-2 => DIST illegal string
-5 => MODE not in range -6 to 6
-6 => COND less than 1.0, and MODE neither -6, 0 nor 6
-8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or
two adjacent elements of EI are 'I'.
-9 => RSIGN is not 'T' or 'F'
-10 => UPPER is not 'T' or 'F'
-11 => SIM is not 'T' or 'F'
-12 => MODES=0 and DS has a zero singular value.
-13 => MODES is not in the range -5 to 5.
-14 => MODES is nonzero and CONDS is less than 1.
-15 => KL is less than 1.
-16 => KU is less than 1, or KL and KU are both less than
N-1.
-19 => LDA is less than N.
1 => Error return from SLATM1 (computing D)
2 => Cannot scale to DMAX (max. eigenvalue is 0)
3 => Error return from SLATM1 (computing DS)
4 => Error return from SLARGE
5 => Zero singular value from SLATM1.
=====================================================================
1) Decode and Test the input parameters.
Initialize flags & seed.
Parameter adjustments */
--iseed;
--d__;
--ei;
--ds;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Decode DIST */
if (lsame_(dist, "U")) {
idist = 1;
} else if (lsame_(dist, "S")) {
idist = 2;
} else if (lsame_(dist, "N")) {
idist = 3;
} else {
idist = -1;
}
/* Check EI */
useei = TRUE_;
badei = FALSE_;
if (lsame_(ei + 1, " ") || *mode != 0) {
useei = FALSE_;
} else {
if (lsame_(ei + 1, "R")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
if (lsame_(ei + j, "I")) {
if (lsame_(ei + (j - 1), "I")) {
badei = TRUE_;
}
} else {
if (! lsame_(ei + j, "R")) {
badei = TRUE_;
}
}
/* L10: */
}
} else {
badei = TRUE_;
}
}
/* Decode RSIGN */
if (lsame_(rsign, "T")) {
irsign = 1;
} else if (lsame_(rsign, "F")) {
irsign = 0;
} else {
irsign = -1;
}
/* Decode UPPER */
if (lsame_(upper, "T")) {
iupper = 1;
} else if (lsame_(upper, "F")) {
iupper = 0;
} else {
iupper = -1;
}
/* Decode SIM */
if (lsame_(sim, "T")) {
isim = 1;
} else if (lsame_(sim, "F")) {
isim = 0;
} else {
isim = -1;
}
/* Check DS, if MODES=0 and ISIM=1 */
bads = FALSE_;
if (*modes == 0 && isim == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (ds[j] == 0.f) {
bads = TRUE_;
}
/* L20: */
}
}
/* Set INFO if an error */
if (*n < 0) {
*info = -1;
} else if (idist == -1) {
*info = -2;
} else if (abs(*mode) > 6) {
*info = -5;
} else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) {
*info = -6;
} else if (badei) {
*info = -8;
} else if (irsign == -1) {
*info = -9;
} else if (iupper == -1) {
*info = -10;
} else if (isim == -1) {
*info = -11;
} else if (bads) {
*info = -12;
} else if (isim == 1 && abs(*modes) > 5) {
*info = -13;
} else if (isim == 1 && *modes != 0 && *conds < 1.f) {
*info = -14;
} else if (*kl < 1) {
*info = -15;
} else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
*info = -16;
} else if (*lda < max(1,*n)) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLATME", &i__1);
return 0;
}
/* Initialize random number generator */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
/* L30: */
}
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* 2) Set up diagonal of A
Compute D according to COND and MODE */
slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
if (iinfo != 0) {
*info = 1;
return 0;
}
if (*mode != 0 && abs(*mode) != 6) {
/* Scale by DMAX */
temp = dabs(d__[1]);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
r__2 = temp, r__3 = (r__1 = d__[i__], dabs(r__1));
temp = dmax(r__2,r__3);
/* L40: */
}
if (temp > 0.f) {
alpha = *dmax__ / temp;
} else if (*dmax__ != 0.f) {
*info = 2;
return 0;
} else {
alpha = 0.f;
}
sscal_(n, &alpha, &d__[1], &c__1);
}
slaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda);
i__1 = *lda + 1;
scopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
/* Set up complex conjugate pairs */
if (*mode == 0) {
if (useei) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
if (lsame_(ei + j, "I")) {
a_ref(j - 1, j) = a_ref(j, j);
a_ref(j, j - 1) = -a_ref(j, j);
a_ref(j, j) = a_ref(j - 1, j - 1);
}
/* L50: */
}
}
} else if (abs(*mode) == 5) {
i__1 = *n;
for (j = 2; j <= i__1; j += 2) {
if (slaran_(&iseed[1]) > .5f) {
a_ref(j - 1, j) = a_ref(j, j);
a_ref(j, j - 1) = -a_ref(j, j);
a_ref(j, j) = a_ref(j - 1, j - 1);
}
/* L60: */
}
}
/* 3) If UPPER='T', set upper triangle of A to random numbers.
(but don't modify the corners of 2x2 blocks.) */
if (iupper != 0) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
if (a_ref(jc - 1, jc) != 0.f) {
jr = jc - 2;
} else {
jr = jc - 1;
}
slarnv_(&idist, &iseed[1], &jr, &a_ref(1, jc));
/* L70: */
}
}
/* 4) If SIM='T', apply similarity transformation.
-1
Transform is X A X , where X = U S V, thus
it is U S V A V' (1/S) U' */
if (isim != 0) {
/* Compute S (singular values of the eigenvector matrix)
according to CONDS and MODES */
slatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
/* Multiply by V and V' */
slarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
/* Multiply by S and (1/S) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sscal_(n, &ds[j], &a_ref(j, 1), lda);
if (ds[j] != 0.f) {
r__1 = 1.f / ds[j];
sscal_(n, &r__1, &a_ref(1, j), &c__1);
} else {
*info = 5;
return 0;
}
/* L80: */
}
/* Multiply by U and U' */
slarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
}
/* 5) Reduce the bandwidth. */
if (*kl < *n - 1) {
/* Reduce bandwidth -- kill column */
i__1 = *n - 1;
for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
ic = jcr - *kl;
irows = *n + 1 - jcr;
icols = *n + *kl - jcr;
scopy_(&irows, &a_ref(jcr, ic), &c__1, &work[1], &c__1);
xnorms = work[1];
slarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
work[1] = 1.f;
sgemv_("T", &irows, &icols, &c_b39, &a_ref(jcr, ic + 1), lda, &
work[1], &c__1, &c_b23, &work[irows + 1], &c__1);
r__1 = -tau;
sger_(&irows, &icols, &r__1, &work[1], &c__1, &work[irows + 1], &
c__1, &a_ref(jcr, ic + 1), lda);
sgemv_("N", n, &irows, &c_b39, &a_ref(1, jcr), lda, &work[1], &
c__1, &c_b23, &work[irows + 1], &c__1);
r__1 = -tau;
sger_(n, &irows, &r__1, &work[irows + 1], &c__1, &work[1], &c__1,
&a_ref(1, jcr), lda);
a_ref(jcr, ic) = xnorms;
i__2 = irows - 1;
slaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a_ref(jcr + 1, ic),
lda);
/* L90: */
}
} else if (*ku < *n - 1) {
/* Reduce upper bandwidth -- kill a row at a time. */
i__1 = *n - 1;
for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
ir = jcr - *ku;
irows = *n + *ku - jcr;
icols = *n + 1 - jcr;
scopy_(&icols, &a_ref(ir, jcr), lda, &work[1], &c__1);
xnorms = work[1];
slarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
work[1] = 1.f;
sgemv_("N", &irows, &icols, &c_b39, &a_ref(ir + 1, jcr), lda, &
work[1], &c__1, &c_b23, &work[icols + 1], &c__1);
r__1 = -tau;
sger_(&irows, &icols, &r__1, &work[icols + 1], &c__1, &work[1], &
c__1, &a_ref(ir + 1, jcr), lda);
sgemv_("C", &icols, n, &c_b39, &a_ref(jcr, 1), lda, &work[1], &
c__1, &c_b23, &work[icols + 1], &c__1);
r__1 = -tau;
sger_(&icols, n, &r__1, &work[1], &c__1, &work[icols + 1], &c__1,
&a_ref(jcr, 1), lda);
a_ref(ir, jcr) = xnorms;
i__2 = icols - 1;
slaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a_ref(ir, jcr + 1),
lda);
/* L100: */
}
}
/* Scale the matrix to have norm ANORM */
if (*anorm >= 0.f) {
temp = slange_("M", n, n, &a[a_offset], lda, tempa);
if (temp > 0.f) {
alpha = *anorm / temp;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sscal_(n, &alpha, &a_ref(1, j), &c__1);
/* L110: */
}
}
}
return 0;
/* End of SLATME */
} /* slatme_ */
/* Subroutine */ int sdrvgt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, real *a, real *af, real
*b, real *x, real *xact, real *work, real *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
"1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
"ratio = \002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
real r__1, r__2;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, j, k, m, n;
real z__[3];
integer k1, in, kl, ku, ix, nt, lda;
char fact[1];
real cond;
integer mode, koff, imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact, nfail, iseed[4];
real rcond;
extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
*, real *, integer *, real *, real *), sscal_(integer *, real *,
real *, integer *);
integer nimat;
extern doublereal sget06_(real *, real *);
real anorm;
integer itran;
extern /* Subroutine */ int sgtt01_(integer *, real *, real *, real *,
real *, real *, real *, real *, integer *, real *, integer *,
real *, real *), sgtt02_(char *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, real *,
real *), sgtt05_(char *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, real *,
integer *, real *, real *, real *);
char trans[1];
integer izero, nerrs;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
logical zerot;
extern /* Subroutine */ int sgtsv_(integer *, integer *, real *, real *,
real *, real *, integer *, integer *), slatb4_(char *, integer *,
integer *, integer *, char *, integer *, integer *, real *,
integer *, real *, char *), aladhd_(
integer *, char *), alaerh_(char *, char *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *);
real rcondc, rcondi;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
real rcondo, anormi;
extern /* Subroutine */ int slagtm_(char *, integer *, integer *, real *,
real *, real *, real *, real *, integer *, real *, real *,
integer *);
real ainvnm;
extern doublereal slangt_(char *, integer *, real *, real *, real *);
logical trfcon;
real anormo;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *), slatms_(
integer *, integer *, char *, integer *, char *, real *, integer *
, real *, real *, integer *, integer *, char *, real *, integer *,
real *, integer *), slarnv_(integer *,
integer *, integer *, real *), sgttrf_(integer *, real *, real *,
real *, real *, integer *, integer *);
real result[6];
extern /* Subroutine */ int sgttrs_(char *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, integer *), serrvx_(char *, integer *), sgtsvx_(char *, char
*, integer *, integer *, real *, real *, real *, real *, real *,
real *, real *, integer *, real *, integer *, real *, integer *,
real *, real *, real *, real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVGT tests SGTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (NMAX*4) */
/* AF (workspace) REAL array, dimension (NMAX*4) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NRHS)) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
serrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L130;
}
/* Set up parameters with SLATB4. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number. */
/* Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L130;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
scopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
scopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with */
/* unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
slarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
sscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
a[n] = z__[1];
if (n > 1) {
a[1] = z__[2];
}
} else if (izero == n) {
a[n * 3 - 2] = z__[0];
a[(n << 1) - 1] = z__[1];
} else {
a[(n << 1) - 2 + izero] = z__[0];
a[n - 1 + izero] = z__[1];
a[izero] = z__[2];
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
z__[1] = a[n];
a[n] = 0.f;
if (n > 1) {
z__[2] = a[1];
a[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
z__[0] = a[n * 3 - 2];
z__[1] = a[(n << 1) - 1];
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
a[(n << 1) - 2 + i__] = 0.f;
a[n - 1 + i__] = 0.f;
a[i__] = 0.f;
/* L20: */
}
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
}
}
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by SGTSVX. */
if (zerot) {
if (ifact == 1) {
goto L120;
}
rcondo = 0.f;
rcondi = 0.f;
} else if (ifact == 1) {
i__3 = n + (m << 1);
scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
/* Compute the 1-norm and infinity-norm of A. */
anormo = slangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
anormi = slangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
/* Factor the matrix A. */
sgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
m << 1) + 1], &iwork[1], &info);
/* Use SGTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L30: */
}
x[i__] = 1.f;
sgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
&af[n + m + 1], &af[n + (m << 1) + 1], &
iwork[1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute the 1-norm condition number of A. */
if (anormo <= 0.f || ainvnm <= 0.f) {
rcondo = 1.f;
} else {
rcondo = 1.f / anormo / ainvnm;
}
/* Use SGTTRS to solve for one column at a time of */
/* inv(A'), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L50: */
}
x[i__] = 1.f;
sgttrs_("Transpose", &n, &c__1, &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[
1], &x[1], &lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the infinity-norm condition number of A. */
if (anormi <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anormi / ainvnm;
}
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
slarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L70: */
}
/* Set the right hand side. */
slagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
if (ifact == 2 && itran == 1) {
/* --- Test SGTSV --- */
/* Solve the system using Gaussian elimination with */
/* partial pivoting. */
i__3 = n + (m << 1);
scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "SGTSV ", (ftnlen)32, (ftnlen)
6);
sgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
x[1], &lda, &info);
/* Check error code from SGTSV . */
if (info != izero) {
alaerh_(path, "SGTSV ", &info, &izero, " ", &n, &
n, &c__1, &c__1, nrhs, &imat, &nfail, &
nerrs, nout);
}
nt = 1;
if (izero == 0) {
/* Check residual of computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
sgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
m + 1], &x[1], &lda, &work[1], &lda, &
rwork[1], &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 2; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "SGTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L80: */
}
nrun = nrun + nt - 1;
}
/* --- Test SGTSVX --- */
if (ifact > 1) {
/* Initialize AF to zero. */
i__3 = n * 3 - 2;
for (i__ = 1; i__ <= i__3; ++i__) {
af[i__] = 0.f;
/* L90: */
}
}
slaset_("Full", &n, nrhs, &c_b44, &c_b44, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using SGTSVX. */
s_copy(srnamc_1.srnamt, "SGTSVX", (ftnlen)32, (ftnlen)6);
sgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
1], &iwork[n + 1], &info);
/* Check the error code from SGTSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "SGTSVX", &info, &izero, ch__1, &n, &n,
&c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute */
/* residual. */
sgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
1], &iwork[1], &work[1], &lda, &rwork[1],
result);
k1 = 1;
} else {
k1 = 2;
}
if (info == 0) {
trfcon = FALSE_;
/* Check residual of computed solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &x[1], &lda, &work[1], &lda, &rwork[1], &
result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
sgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
&rwork[1], &rwork[*nrhs + 1], &result[3]);
nt = 5;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = k1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, "SGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L100: */
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
if (result[5] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, "SGTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
nrun = nrun + nt - k1 + 2;
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVGT */
} /* sdrvgt_ */
int main(int argc, char **argv) {
int iam, nprocs;
int myrank_mpi, nprocs_mpi;
int ictxt, nprow, npcol, myrow, mycol;
int nb, m, n;
int mpA, nqA, mpU, nqU, mpVT, nqVT;
int i, j, k, itemp, min_mn;
int descA[9], descU[9], descVT[9];
float *A=NULL;
int info, infoNN, infoVV, infoNV, infoVN;
float *U_NN=NULL, *U_VV=NULL, *U_NV=NULL, *U_VN=NULL;
float *VT_NN=NULL, *VT_VV=NULL, *VT_NV=NULL, *VT_VN=NULL;
float *S_NN=NULL, *S_VV=NULL, *S_NV=NULL, *S_VN=NULL;
float *S_res_NN=NULL;
float orthU_VV, residF, orthVT_VV;
float orthU_VN, orthVT_NV;
float residS_NN, eps;
float res_repres_NV, res_repres_VN;
/**/
int izero=0,ione=1;
float rtmone=-1.0e+00;
/**/
double MPIelapsedVV, MPIelapsedNN, MPIelapsedVN, MPIelapsedNV;
char jobU, jobVT;
int nbfailure=0, nbtestcase=0,inputfromfile, nbhetereogeneity=0;
float threshold=100e+00;
char buf[1024];
FILE *fd;
char *c;
char *t_jobU, *t_jobVT;
int *t_m, *t_n, *t_nb, *t_nprow, *t_npcol;
int nb_expe, expe;
char hetereogeneityVV, hetereogeneityNN, hetereogeneityVN, hetereogeneityNV;
int iseed[4], idist;
/**/
MPI_Init( &argc, &argv);
MPI_Comm_rank(MPI_COMM_WORLD, &myrank_mpi);
MPI_Comm_size(MPI_COMM_WORLD, &nprocs_mpi);
/**/
m = 100; n = 100; nprow = 1; npcol = 1; nb = 64; jobU='A'; jobVT='A'; inputfromfile = 0;
for( i = 1; i < argc; i++ ) {
if( strcmp( argv[i], "-f" ) == 0 ) {
inputfromfile = 1;
}
if( strcmp( argv[i], "-jobvt" ) == 0 ) {
if (i+1<argc) {
if( strcmp( argv[i+1], "V" ) == 0 ){ jobVT = 'V'; i++; }
else if( strcmp( argv[i+1], "N" ) == 0 ){ jobVT = 'N'; i++; }
else if( strcmp( argv[i+1], "A" ) == 0 ){ jobVT = 'A'; i++; }
else printf(" ** warning: jobvt should be set to V, N or A in the command line ** \n");
}
else
printf(" ** warning: jobvt should be set to V, N or A in the command line ** \n");
}
if( strcmp( argv[i], "-jobu" ) == 0 ) {
if (i+1<argc) {
if( strcmp( argv[i+1], "V" ) == 0 ){ jobU = 'V'; i++; }
else if( strcmp( argv[i+1], "N" ) == 0 ){ jobU = 'N'; i++; }
else if( strcmp( argv[i+1], "A" ) == 0 ){ jobU = 'A'; i++; }
else printf(" ** warning: jobu should be set to V, N or A in the command line ** \n");
}
else
printf(" ** warning: jobu should be set to V, N or A in the command line ** \n");
}
if( strcmp( argv[i], "-m" ) == 0 ) {
m = atoi(argv[i+1]);
i++;
}
if( strcmp( argv[i], "-n" ) == 0 ) {
n = atoi(argv[i+1]);
i++;
}
if( strcmp( argv[i], "-p" ) == 0 ) {
nprow = atoi(argv[i+1]);
i++;
}
if( strcmp( argv[i], "-q" ) == 0 ) {
npcol = atoi(argv[i+1]);
i++;
}
if( strcmp( argv[i], "-nb" ) == 0 ) {
nb = atoi(argv[i+1]);
i++;
}
}
/**/
if (inputfromfile){
nb_expe = 0;
fd = fopen("svd.dat", "r");
if (fd == NULL) { printf("File failed to open svd.dat from processor mpirank(%d/%d): \n",myrank_mpi,nprocs_mpi); exit(-1); }
do {
c = fgets(buf, 1024, fd); /* get one line from the file */
if (c != NULL)
if (c[0] != '#')
nb_expe++;
} while (c != NULL); /* repeat until NULL */
fclose(fd);
t_jobU = (char *)calloc(nb_expe,sizeof(char)) ;
t_jobVT = (char *)calloc(nb_expe,sizeof(char)) ;
t_m = (int *)calloc(nb_expe,sizeof(int )) ;
t_n = (int *)calloc(nb_expe,sizeof(int )) ;
t_nb = (int *)calloc(nb_expe,sizeof(int )) ;
t_nprow = (int *)calloc(nb_expe,sizeof(int )) ;
t_npcol = (int *)calloc(nb_expe,sizeof(int )) ;
fd = fopen("svd.dat", "r");
expe=0;
do {
c = fgets(buf, 1024, fd); /* get one line from the file */
if (c != NULL)
if (c[0] != '#'){
//printf("NBEXPE = %d\n",expe);
sscanf(c,"%c %c %d %d %d %d %d",
&(t_jobU[expe]),&(t_jobVT[expe]),&(t_m[expe]),&(t_n[expe]),
&(t_nb[expe]),(&t_nprow[expe]),&(t_npcol[expe]));
expe++;
}
} while (c != NULL); /* repeat until NULL */
fclose(fd);
}
else {
nb_expe = 1;
t_jobU = (char *)calloc(nb_expe,sizeof(char)) ;
t_jobVT = (char *)calloc(nb_expe,sizeof(char)) ;
t_m = (int *)calloc(nb_expe,sizeof(int )) ;
t_n = (int *)calloc(nb_expe,sizeof(int )) ;
t_nb = (int *)calloc(nb_expe,sizeof(int )) ;
t_nprow = (int *)calloc(nb_expe,sizeof(int )) ;
t_npcol = (int *)calloc(nb_expe,sizeof(int )) ;
t_jobU[0] = jobU;
t_jobVT[0] = jobVT;
t_m[0] = m;
t_n[0] = n;
t_nb[0] = nb;
t_nprow[0] = nprow;
t_npcol[0] = npcol;
}
if (myrank_mpi==0){
printf("\n");
printf("--------------------------------------------------------------------------------------------------------------------\n");
printf(" Testing psgsevd -- float precision SVD ScaLAPACK routine \n");
printf("jobU jobVT m n nb p q || info heter resid orthU orthVT |SNN-SVV| time(s) cond(A) \n");
printf("--------------------------------------------------------------------------------------------------------------------\n");
}
/**/
for (expe = 0; expe<nb_expe; expe++){
jobU = t_jobU[expe] ;
jobVT = t_jobVT[expe] ;
m = t_m[expe] ;
n = t_n[expe] ;
nb = t_nb[expe] ;
nprow = t_nprow[expe] ;
npcol = t_npcol[expe] ;
if (nb>n)
nb = n;
if (nprow*npcol>nprocs_mpi){
if (myrank_mpi==0)
printf(" **** ERROR : we do not have enough processes available to make a p-by-q process grid ***\n");
printf(" **** Bye-bye ***\n");
MPI_Finalize(); exit(1);
}
/**/
Cblacs_pinfo( &iam, &nprocs ) ;
Cblacs_get( -1, 0, &ictxt );
Cblacs_gridinit( &ictxt, "Row", nprow, npcol );
Cblacs_gridinfo( ictxt, &nprow, &npcol, &myrow, &mycol );
/**/
min_mn = min(m,n);
/**/
//if (iam==0)
//printf("\tm=%d\tn = %d\t\t(%d,%d)\t%dx%d\n",m,n,nprow,npcol,nb,nb);
//printf("Hello World, I am proc %d over %d for MPI, proc %d over %d for BLACS in position (%d,%d) in the process grid\n",
//myrank_mpi,nprocs_mpi,iam,nprocs,myrow,mycol);
/*
*
* Work only the process in the process grid
*
*/
//if ((myrow < nprow)&(mycol < npcol)){
if ((myrow>-1)&(mycol>-1)&(myrow<nprow)&(mycol<npcol)){
/*
*
* Compute the size of the local matrices (thanks to numroc)
*
*/
mpA = numroc_( &m , &nb, &myrow, &izero, &nprow );
nqA = numroc_( &n , &nb, &mycol, &izero, &npcol );
mpU = numroc_( &m , &nb, &myrow, &izero, &nprow );
nqU = numroc_( &min_mn, &nb, &mycol, &izero, &npcol );
mpVT = numroc_( &min_mn, &nb, &myrow, &izero, &nprow );
nqVT = numroc_( &n , &nb, &mycol, &izero, &npcol );
/*
*
* Allocate and fill the matrices A and B
*
*/
A = (float *)calloc(mpA*nqA,sizeof(float)) ;
if (A==NULL){ printf("error of memory allocation A on proc %dx%d\n",myrow,mycol); exit(0); }
/**/
// seed = iam*(mpA*nqA*2); srand(seed);
idist = 2;
iseed[0] = mpA%4096;
iseed[1] = iam%4096;
iseed[2] = nqA%4096;
iseed[3] = 23;
/**/
k = 0;
for (i = 0; i < mpA; i++) {
for (j = 0; j < nqA; j++) {
slarnv_( &idist, iseed, &ione, &(A[k]) );
k++;
}
}
/*
*
* Initialize the array descriptor for the distributed matrices xA, U and VT
*
*/
itemp = max( 1, mpA );
descinit_( descA, &m, &n, &nb, &nb, &izero, &izero, &ictxt, &itemp, &info );
itemp = max( 1, mpA );
descinit_( descU, &m, &min_mn, &nb, &nb, &izero, &izero, &ictxt, &itemp, &info );
itemp = max( 1, mpVT );
descinit_( descVT, &min_mn, &n, &nb, &nb, &izero, &izero, &ictxt, &itemp, &info );
/**/
eps = pslamch_( &ictxt, "Epsilon" );
/**/
if ( ((jobU=='V')&(jobVT=='N')) ||(jobU == 'A' )||(jobVT=='A')){
nbtestcase++;
U_VN = (float *)calloc(mpU*nqU,sizeof(float)) ;
if (U_VN==NULL){ printf("error of memory allocation U_VN on proc %dx%d\n",myrow,mycol); exit(0); }
S_VN = (float *)calloc(min_mn,sizeof(float)) ;
if (S_VN==NULL){ printf("error of memory allocation S_VN on proc %dx%d\n",myrow,mycol); exit(0); }
infoVN = driver_psgesvd( 'V', 'N', m, n, A, 1, 1, descA,
S_VN, U_VN, 1, 1, descU, VT_VN, 1, 1, descVT,
&MPIelapsedVN);
orthU_VN = verif_orthogonality(m,min_mn,U_VN , 1, 1, descU);
res_repres_VN = verif_repres_VN( m, n, A, 1, 1, descA, U_VN, 1, 1, descU, S_VN);
if (infoVN==min_mn+1) hetereogeneityVN = 'H'; else hetereogeneityVN = 'N';
if ( iam==0 )
printf(" V N %6d %6d %3d %3d %3d || %3d %c %7.1e %7.1e %8.2f %7.1e\n",
m,n,nb,nprow,npcol,infoVN,hetereogeneityVN,res_repres_VN/(S_VN[0]/S_VN[min_mn-1]),
orthU_VN,MPIelapsedVN,S_VN[0]/S_VN[min_mn-1]);
if (infoVN==min_mn+1) nbhetereogeneity++ ;
else if ((res_repres_VN/eps/(S_VN[0]/S_VN[min_mn-1])>threshold)||(orthU_VN/eps>threshold)||(infoVN!=0)) nbfailure++;
}
/**/
if (((jobU=='N')&(jobVT=='V'))||(jobU == 'A' )||(jobVT=='A')){
nbtestcase++;
VT_NV = (float *)calloc(mpVT*nqVT,sizeof(float)) ;
if (VT_NV==NULL){ printf("error of memory allocation VT_NV on proc %dx%d\n",myrow,mycol); exit(0); }
S_NV = (float *)calloc(min_mn,sizeof(float)) ;
if (S_NV==NULL){ printf("error of memory allocation S_NV on proc %dx%d\n",myrow,mycol); exit(0); }
infoNV = driver_psgesvd( 'N', 'V', m, n, A, 1, 1, descA,
S_NV, U_NV, 1, 1, descU, VT_NV, 1, 1, descVT,
&MPIelapsedNV);
orthVT_NV = verif_orthogonality(min_mn,n,VT_NV, 1, 1, descVT);
res_repres_NV = verif_repres_NV( m, n, A, 1, 1, descA, VT_NV, 1, 1, descVT, S_NV);
if (infoNV==min_mn+1) hetereogeneityNV = 'H'; else hetereogeneityNV = 'N';
if ( iam==0 )
printf(" N V %6d %6d %3d %3d %3d || %3d %c %7.1e %7.1e %8.2f %7.1e\n",
m,n,nb,nprow,npcol,infoNV,hetereogeneityNV,res_repres_NV/(S_NV[0]/S_NV[min_mn-1]),
orthVT_NV,MPIelapsedNV,S_NV[0]/S_NV[min_mn-1]);
if (infoNV==min_mn+1) nbhetereogeneity++ ;
else if ((res_repres_NV/eps/(S_NV[0]/S_NV[min_mn-1])>threshold)||(orthVT_NV/eps>threshold)||(infoNV!=0)) nbfailure++;
}
/**/
if ( ((jobU=='N')&(jobVT=='N')) || ((jobU=='V')&(jobVT=='V')) || (jobU == 'A' ) || (jobVT=='A') ) {
nbtestcase++;
U_VV = (float *)calloc(mpU*nqU,sizeof(float)) ;
if (U_VV==NULL){ printf("error of memory allocation U_VV on proc %dx%d\n",myrow,mycol); exit(0); }
VT_VV = (float *)calloc(mpVT*nqVT,sizeof(float)) ;
if (VT_VV==NULL){ printf("error of memory allocation VT_VV on proc %dx%d\n",myrow,mycol); exit(0); }
S_VV = (float *)calloc(min_mn,sizeof(float)) ;
if (S_VV==NULL){ printf("error of memory allocation S_VV on proc %dx%d\n",myrow,mycol); exit(0); }
infoVV = driver_psgesvd( 'V', 'V', m, n, A, 1, 1, descA,
S_VV, U_VV, 1, 1, descU, VT_VV, 1, 1, descVT,
&MPIelapsedVV);
orthU_VV = verif_orthogonality(m,min_mn,U_VV , 1, 1, descU);
orthVT_VV = verif_orthogonality(min_mn,n,VT_VV, 1, 1, descVT);
residF = verif_representativity( m, n, A, 1, 1, descA,
U_VV, 1, 1, descU,
VT_VV, 1, 1, descVT,
S_VV);
if (infoVV==min_mn+1) hetereogeneityVV = 'H'; else hetereogeneityVV = 'N';
if ( iam==0 )
printf(" V V %6d %6d %3d %3d %3d || %3d %c %7.1e %7.1e %7.1e %8.2f %7.1e\n",
m,n,nb,nprow,npcol,infoVV,hetereogeneityVV,residF,orthU_VV,orthVT_VV,MPIelapsedVV,S_VV[0]/S_VV[min_mn-1]);
if (infoVV==min_mn+1) nbhetereogeneity++ ;
else if ((residF/eps>threshold)||(orthU_VV/eps>threshold)||(orthVT_VV/eps>threshold)||(infoVV!=0)) nbfailure++;
}
/**/
if (((jobU=='N')&(jobVT=='N'))||(jobU == 'A' )||(jobVT=='A')){
nbtestcase++;
S_NN = (float *)calloc(min_mn,sizeof(float)) ;
if (S_NN==NULL){ printf("error of memory allocation S_NN on proc %dx%d\n",myrow,mycol); exit(0); }
infoNN = driver_psgesvd( 'N', 'N', m, n, A, 1, 1, descA,
S_NN, U_NN, 1, 1, descU, VT_NN, 1, 1, descVT,
&MPIelapsedNN);
S_res_NN = (float *)calloc(min_mn,sizeof(float)) ;
if (S_res_NN==NULL){ printf("error of memory allocation S on proc %dx%d\n",myrow,mycol); exit(0); }
scopy_(&min_mn,S_VV,&ione,S_res_NN,&ione);
saxpy_ (&min_mn,&rtmone,S_NN,&ione,S_res_NN,&ione);
residS_NN = snrm2_(&min_mn,S_res_NN,&ione) / snrm2_(&min_mn,S_VV,&ione);
free(S_res_NN);
if (infoNN==min_mn+1) hetereogeneityNN = 'H'; else hetereogeneityNN = 'N';
if ( iam==0 )
printf(" N N %6d %6d %3d %3d %3d || %3d %c %7.1e %8.2f %7.1e\n",
m,n,nb,nprow,npcol,infoNN,hetereogeneityNN,residS_NN,MPIelapsedNN,S_NN[0]/S_NN[min_mn-1]);
if (infoNN==min_mn+1) nbhetereogeneity++ ;
else if ((residS_NN/eps>threshold)||(infoNN!=0)) nbfailure++;
}
/**/
if (((jobU=='V')&(jobVT=='N'))||(jobU == 'A' )||(jobVT=='A')){ free(S_VN); free(U_VN); }
if (((jobU=='N')&(jobVT=='V'))||(jobU == 'A' )||(jobVT=='A')){ free(VT_NV); free(S_NV); }
if (((jobU=='N')&(jobVT=='N'))||(jobU == 'A' )||(jobVT=='A')){ free(S_NN); }
if (((jobU=='N')&(jobVT=='N'))||((jobU=='V')&(jobVT=='V'))||(jobU == 'A' )||(jobVT=='A')){ free(U_VV); free(S_VV); free(VT_VV);}
free(A);
Cblacs_gridexit( 0 );
}
/*
* Print ending messages
*/
}
if ( iam==0 ){
printf("--------------------------------------------------------------------------------------------------------------------\n");
printf(" [ nbhetereogeneity = %d / %d ]\n",nbhetereogeneity, nbtestcase);
printf(" [ nbfailure = %d / %d ]\n",nbfailure, nbtestcase-nbhetereogeneity);
printf("--------------------------------------------------------------------------------------------------------------------\n");
printf("\n");
}
/**/
free(t_jobU );
free(t_jobVT );
free(t_m );
free(t_n );
free(t_nb );
free(t_nprow );
free(t_npcol );
MPI_Finalize();
exit(0);
}
/* Subroutine */ int slagsy_(integer *n, integer *k, 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 sdot_(integer *, real *, integer *, real *, integer *),
snrm2_(integer *, real *, integer *);
static integer i, j;
extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
static real alpha;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
sgemv_(char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, integer *), saxpy_(
integer *, real *, real *, integer *, real *, integer *), ssymv_(
char *, integer *, real *, real *, integer *, real *, integer *,
real *, real *, integer *);
static real wa, wb, wn;
extern /* Subroutine */ int xerbla_(char *, integer *), slarnv_(
integer *, integer *, integer *, real *);
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
=======
SLAGSY generates a real symmetric matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random orthogonal matrix:
A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
orthogonal 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) REAL array, dimension (LDA,N)
The generated n by n symmetric 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) REAL 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);
xerbla_("SLAGSY", &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) {
a[i + j * a_dim1] = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
a[i + i * a_dim1] = d[i];
/* L30: */
}
/* Generate lower triangle of symmetric matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
slarnv_(&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;
}
/* 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;
ssymv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b12, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
i__1 = *n - i + 1;
alpha = tau * -.5f * sdot_(&i__1, &work[*n + 1], &c__1, &work[1], &
c__1);
i__1 = *n - i + 1;
saxpy_(&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;
ssyr2_("Lower", &i__1, &c_b19, &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 = snrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
wa = r_sign(&wn, &a[*k + i + i * a_dim1]);
if (wn == 0.f) {
tau = 0.f;
} else {
wb = a[*k + i + i * a_dim1] + wa;
i__2 = *n - *k - i;
r__1 = 1.f / wb;
sscal_(&i__2, &r__1, &a[*k + i + 1 + i * a_dim1], &c__1);
a[*k + i + i * a_dim1] = 1.f;
tau = wb / wa;
}
/* 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;
sgemv_("Transpose", &i__2, &i__3, &c_b26, &a[*k + i + (i + 1) *
a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b12, &work[1]
, &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
r__1 = -(doublereal)tau;
sger_(&i__2, &i__3, &r__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;
ssymv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b12, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
i__2 = *n - *k - i + 1;
alpha = tau * -.5f * sdot_(&i__2, &work[1], &c__1, &a[*k + i + i *
a_dim1], &c__1);
i__2 = *n - *k - i + 1;
saxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i + 1;
ssyr2_("Lower", &i__2, &c_b19, &a[*k + i + i * a_dim1], &c__1, &work[
1], &c__1, &a[*k + i + (*k + i) * a_dim1], lda);
a[*k + i + i * a_dim1] = -(doublereal)wa;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
a[j + i * a_dim1] = 0.f;
/* L50: */
}
/* L60: */
}
/* Store full symmetric matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
a[j + i * a_dim1] = a[i + j * a_dim1];
/* L70: */
}
/* L80: */
}
return 0;
/* End of SLAGSY */
} /* slagsy_ */
/* Subroutine */ int sstein_(integer *n, real *d, real *e, integer *m, real *
w, integer *iblock, integer *isplit, real *z, integer *ldz, real *
work, integer *iwork, integer *ifail, integer *info)
{
/* -- LAPACK 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
=======
SSTEIN computes the eigenvectors of a real symmetric tridiagonal
matrix T corresponding to specified eigenvalues, using inverse
iteration.
The maximum number of iterations allowed for each eigenvector is
specified by an internal parameter MAXITS (currently set to 5).
Arguments
=========
N (input) INTEGER
The order of the matrix. N >= 0.
D (input) REAL array, dimension (N)
The n diagonal elements of the tridiagonal matrix T.
E (input) REAL array, dimension (N)
The (n-1) subdiagonal elements of the tridiagonal matrix
T, in elements 1 to N-1. E(N) need not be set.
M (input) INTEGER
The number of eigenvectors to be found. 0 <= M <= N.
W (input) REAL array, dimension (N)
The first M elements of W contain the eigenvalues for
which eigenvectors are to be computed. The eigenvalues
should be grouped by split-off block and ordered from
smallest to largest within the block. ( The output array
W from SSTEBZ with ORDER = 'B' is expected here. )
IBLOCK (input) INTEGER array, dimension (N)
The submatrix indices associated with the corresponding
eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
the first submatrix from the top, =2 if W(i) belongs to
the second submatrix, etc. ( The output array IBLOCK
from SSTEBZ is expected here. )
ISPLIT (input) INTEGER array, dimension (N)
The splitting points, at which T breaks up into submatrices.
The first submatrix consists of rows/columns 1 to
ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
through ISPLIT( 2 ), etc.
( The output array ISPLIT from SSTEBZ is expected here. )
Z (output) REAL array, dimension (LDZ, M)
The computed eigenvectors. The eigenvector associated
with the eigenvalue W(i) is stored in the i-th column of
Z. Any vector which fails to converge is set to its current
iterate after MAXITS iterations.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= max(1,N).
WORK (workspace) REAL array, dimension (5*N)
IWORK (workspace) INTEGER array, dimension (N)
IFAIL (output) INTEGER array, dimension (M)
On normal exit, all elements of IFAIL are zero.
If one or more eigenvectors fail to converge after
MAXITS iterations, then their indices are stored in
array IFAIL.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, then i eigenvectors failed to converge
in MAXITS iterations. Their indices are stored in
array IFAIL.
Internal Parameters
===================
MAXITS INTEGER, default = 5
The maximum number of iterations performed.
EXTRA INTEGER, default = 2
The number of iterations performed after norm growth
criterion is satisfied, should be at least 1.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
static integer c_n1 = -1;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer jblk, nblk, jmax;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *),
snrm2_(integer *, real *, integer *);
static integer i, j, iseed[4], gpind, iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer b1;
extern doublereal sasum_(integer *, real *, integer *);
static integer j1;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real ortol;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *);
static integer indrv1, indrv2, indrv3, indrv4, indrv5, bn;
static real xj;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *), slagtf_(
integer *, real *, real *, real *, real *, real *, real *,
integer *, integer *);
static integer nrmchk;
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slagts_(integer *, integer *, real *, real *,
real *, real *, integer *, real *, real *, integer *);
static integer blksiz;
static real onenrm, pertol;
extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
*);
static real stpcrt, scl, eps, ctr, sep, nrm, tol;
static integer its;
static real xjm, eps1;
#define ISEED(I) iseed[(I)]
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define W(I) w[(I)-1]
#define IBLOCK(I) iblock[(I)-1]
#define ISPLIT(I) isplit[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define IFAIL(I) ifail[(I)-1]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
*info = 0;
i__1 = *m;
for (i = 1; i <= *m; ++i) {
IFAIL(i) = 0;
/* L10: */
}
if (*n < 0) {
*info = -1;
} else if (*m < 0 || *m > *n) {
*info = -4;
} else if (*ldz < max(1,*n)) {
*info = -9;
} else {
i__1 = *m;
for (j = 2; j <= *m; ++j) {
if (IBLOCK(j) < IBLOCK(j - 1)) {
*info = -6;
goto L30;
}
if (IBLOCK(j) == IBLOCK(j - 1) && W(j) < W(j - 1)) {
*info = -5;
goto L30;
}
/* L20: */
}
L30:
;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEIN", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
} else if (*n == 1) {
Z(1,1) = 1.f;
return 0;
}
/* Get machine constants. */
eps = slamch_("Precision");
/* Initialize seed for random number generator SLARNV. */
for (i = 1; i <= 4; ++i) {
ISEED(i - 1) = 1;
/* L40: */
}
/* Initialize pointers. */
indrv1 = 0;
indrv2 = indrv1 + *n;
indrv3 = indrv2 + *n;
indrv4 = indrv3 + *n;
indrv5 = indrv4 + *n;
/* Compute eigenvectors of matrix blocks. */
j1 = 1;
i__1 = IBLOCK(*m);
for (nblk = 1; nblk <= IBLOCK(*m); ++nblk) {
/* Find starting and ending indices of block nblk. */
if (nblk == 1) {
b1 = 1;
} else {
b1 = ISPLIT(nblk - 1) + 1;
}
bn = ISPLIT(nblk);
blksiz = bn - b1 + 1;
if (blksiz == 1) {
goto L60;
}
gpind = b1;
/* Compute reorthogonalization criterion and stopping criterion
. */
onenrm = (r__1 = D(b1), dabs(r__1)) + (r__2 = E(b1), dabs(r__2));
/* Computing MAX */
r__3 = onenrm, r__4 = (r__1 = D(bn), dabs(r__1)) + (r__2 = E(bn - 1),
dabs(r__2));
onenrm = dmax(r__3,r__4);
i__2 = bn - 1;
for (i = b1 + 1; i <= bn-1; ++i) {
/* Computing MAX */
r__4 = onenrm, r__5 = (r__1 = D(i), dabs(r__1)) + (r__2 = E(i - 1)
, dabs(r__2)) + (r__3 = E(i), dabs(r__3));
onenrm = dmax(r__4,r__5);
/* L50: */
}
ortol = onenrm * .001f;
stpcrt = sqrt(.1f / blksiz);
/* Loop through eigenvalues of block nblk. */
L60:
jblk = 0;
i__2 = *m;
for (j = j1; j <= *m; ++j) {
if (IBLOCK(j) != nblk) {
j1 = j;
goto L160;
}
++jblk;
xj = W(j);
/* Skip all the work if the block size is one. */
if (blksiz == 1) {
WORK(indrv1 + 1) = 1.f;
goto L120;
}
/* If eigenvalues j and j-1 are too close, add a relativ
ely
small perturbation. */
if (jblk > 1) {
eps1 = (r__1 = eps * xj, dabs(r__1));
pertol = eps1 * 10.f;
sep = xj - xjm;
if (sep < pertol) {
xj = xjm + pertol;
}
}
its = 0;
nrmchk = 0;
/* Get random starting vector. */
slarnv_(&c__2, iseed, &blksiz, &WORK(indrv1 + 1));
/* Copy the matrix T so it won't be destroyed in factori
zation. */
scopy_(&blksiz, &D(b1), &c__1, &WORK(indrv4 + 1), &c__1);
i__3 = blksiz - 1;
scopy_(&i__3, &E(b1), &c__1, &WORK(indrv2 + 2), &c__1);
i__3 = blksiz - 1;
scopy_(&i__3, &E(b1), &c__1, &WORK(indrv3 + 1), &c__1);
/* Compute LU factors with partial pivoting ( PT = LU )
*/
tol = 0.f;
slagtf_(&blksiz, &WORK(indrv4 + 1), &xj, &WORK(indrv2 + 2), &WORK(
indrv3 + 1), &tol, &WORK(indrv5 + 1), &IWORK(1), &iinfo);
/* Update iteration count. */
L70:
++its;
if (its > 5) {
goto L100;
}
/* Normalize and scale the righthand side vector Pb.
Computing MAX */
r__2 = eps, r__3 = (r__1 = WORK(indrv4 + blksiz), dabs(r__1));
scl = blksiz * onenrm * dmax(r__2,r__3) / sasum_(&blksiz, &WORK(
indrv1 + 1), &c__1);
sscal_(&blksiz, &scl, &WORK(indrv1 + 1), &c__1);
/* Solve the system LU = Pb. */
slagts_(&c_n1, &blksiz, &WORK(indrv4 + 1), &WORK(indrv2 + 2), &
WORK(indrv3 + 1), &WORK(indrv5 + 1), &IWORK(1), &WORK(
indrv1 + 1), &tol, &iinfo);
/* Reorthogonalize by modified Gram-Schmidt if eigenvalu
es are
close enough. */
if (jblk == 1) {
goto L90;
}
if ((r__1 = xj - xjm, dabs(r__1)) > ortol) {
gpind = j;
}
if (gpind != j) {
i__3 = j - 1;
for (i = gpind; i <= j-1; ++i) {
ctr = -(doublereal)sdot_(&blksiz, &WORK(indrv1 + 1), &
c__1, &Z(b1,i), &c__1);
saxpy_(&blksiz, &ctr, &Z(b1,i), &c__1, &WORK(
indrv1 + 1), &c__1);
/* L80: */
}
}
/* Check the infinity norm of the iterate. */
L90:
jmax = isamax_(&blksiz, &WORK(indrv1 + 1), &c__1);
nrm = (r__1 = WORK(indrv1 + jmax), dabs(r__1));
/* Continue for additional iterations after norm reaches
stopping criterion. */
if (nrm < stpcrt) {
goto L70;
}
++nrmchk;
if (nrmchk < 3) {
goto L70;
}
goto L110;
/* If stopping criterion was not satisfied, update info
and
store eigenvector number in array ifail. */
L100:
++(*info);
IFAIL(*info) = j;
/* Accept iterate as jth eigenvector. */
L110:
scl = 1.f / snrm2_(&blksiz, &WORK(indrv1 + 1), &c__1);
jmax = isamax_(&blksiz, &WORK(indrv1 + 1), &c__1);
if (WORK(indrv1 + jmax) < 0.f) {
scl = -(doublereal)scl;
}
sscal_(&blksiz, &scl, &WORK(indrv1 + 1), &c__1);
L120:
i__3 = *n;
for (i = 1; i <= *n; ++i) {
Z(i,j) = 0.f;
/* L130: */
}
i__3 = blksiz;
for (i = 1; i <= blksiz; ++i) {
Z(b1+i-1,j) = WORK(indrv1 + i);
/* L140: */
}
/* Save the shift to check eigenvalue spacing at next
iteration. */
xjm = xj;
/* L150: */
}
L160:
;
}
return 0;
/* End of SSTEIN */
} /* sstein_ */
/* Subroutine */ int sqrt15_(integer *scale, integer *rksel, integer *m,
integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *
ldb, real *s, integer *rank, real *norma, real *normb, integer *iseed,
real *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1;
/* Local variables */
static integer info;
static real temp;
extern doublereal snrm2_(integer *, real *, integer *);
static integer j;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *), sgemm_(char *, char *,
integer *, integer *, integer *, real *, real *, integer *, real *
, integer *, real *, real *, integer *);
extern doublereal sasum_(integer *, real *, integer *);
static real dummy[1];
static integer mn;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int slaord_(char *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *), slaror_(char *, char *, integer *,
integer *, real *, integer *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
static real smlnum, eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SQRT15 generates a matrix with full or deficient rank and of various
norms.
Arguments
=========
SCALE (input) INTEGER
SCALE = 1: normally scaled matrix
SCALE = 2: matrix scaled up
SCALE = 3: matrix scaled down
RKSEL (input) INTEGER
RKSEL = 1: full rank matrix
RKSEL = 2: rank-deficient matrix
M (input) INTEGER
The number of rows of the matrix A.
N (input) INTEGER
The number of columns of A.
NRHS (input) INTEGER
The number of columns of B.
A (output) REAL array, dimension (LDA,N)
The M-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A.
B (output) REAL array, dimension (LDB, NRHS)
A matrix that is in the range space of matrix A.
LDB (input) INTEGER
The leading dimension of the array B.
S (output) REAL array, dimension MIN(M,N)
Singular values of A.
RANK (output) INTEGER
number of nonzero singular values of A.
NORMA (output) REAL
one-norm of A.
NORMB (output) REAL
one-norm of B.
ISEED (input/output) integer array, dimension (4)
seed for random number generator.
WORK (workspace) REAL array, dimension (LWORK)
LWORK (input) INTEGER
length of work space required.
LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--s;
--iseed;
--work;
/* Function Body */
mn = min(*m,*n);
/* Computing MAX */
i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
+ *m;
if (*lwork < max(i__1,i__2)) {
xerbla_("SQRT15", &c__16);
return 0;
}
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
eps = slamch_("Epsilon");
smlnum = smlnum / eps / eps;
bignum = 1.f / smlnum;
/* Determine rank and (unscaled) singular values */
if (*rksel == 1) {
*rank = mn;
} else if (*rksel == 2) {
*rank = mn * 3 / 4;
i__1 = mn;
for (j = *rank + 1; j <= i__1; ++j) {
s[j] = 0.f;
/* L10: */
}
} else {
xerbla_("SQRT15", &c__2);
}
if (*rank > 0) {
/* Nontrivial case */
s[1] = 1.f;
i__1 = *rank;
for (j = 2; j <= i__1; ++j) {
L20:
temp = slarnd_(&c__1, &iseed[1]);
if (temp > .1f) {
s[j] = dabs(temp);
} else {
goto L20;
}
/* L30: */
}
slaord_("Decreasing", rank, &s[1], &c__1);
/* Generate 'rank' columns of a random orthogonal matrix in A */
slarnv_(&c__2, &iseed[1], m, &work[1]);
r__1 = 1.f / snrm2_(m, &work[1], &c__1);
sscal_(m, &r__1, &work[1], &c__1);
slaset_("Full", m, rank, &c_b18, &c_b19, &a[a_offset], lda)
;
slarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
work[*m + 1]);
/* workspace used: m+mn
Generate consistent rhs in the range space of A */
i__1 = *rank * *nrhs;
slarnv_(&c__2, &iseed[1], &i__1, &work[1]);
sgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b19, &a[
a_offset], lda, &work[1], rank, &c_b18, &b[b_offset], ldb);
/* work space used: <= mn *nrhs
generate (unscaled) matrix A */
i__1 = *rank;
for (j = 1; j <= i__1; ++j) {
sscal_(m, &s[j], &a_ref(1, j), &c__1);
/* L40: */
}
if (*rank < *n) {
i__1 = *n - *rank;
slaset_("Full", m, &i__1, &c_b18, &c_b18, &a_ref(1, *rank + 1),
lda);
}
slaror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
1], &work[1], &info);
} else {
/* work space used 2*n+m
Generate null matrix and rhs */
i__1 = mn;
for (j = 1; j <= i__1; ++j) {
s[j] = 0.f;
/* L50: */
}
slaset_("Full", m, n, &c_b18, &c_b18, &a[a_offset], lda);
slaset_("Full", m, nrhs, &c_b18, &c_b18, &b[b_offset], ldb)
;
}
/* Scale the matrix */
if (*scale != 1) {
*norma = slange_("Max", m, n, &a[a_offset], lda, dummy);
if (*norma != 0.f) {
if (*scale == 2) {
/* matrix scaled up */
slascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
s[1], &mn, &info);
slascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
b_offset], ldb, &info);
} else if (*scale == 3) {
/* matrix scaled down */
slascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
s[1], &mn, &info);
slascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
b_offset], ldb, &info);
} else {
xerbla_("SQRT15", &c__1);
return 0;
}
}
}
*norma = sasum_(&mn, &s[1], &c__1);
*normb = slange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
;
return 0;
/* End of SQRT15 */
} /* sqrt15_ */
/* Subroutine */ int sdrvpt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, real *a, real *d__,
real *e, real *b, real *x, real *xact, real *work, real *rwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j, k, n;
real z__[3];
integer k1, ia, in, kl, ku, ix, nt, lda;
char fact[1];
real cond;
integer mode;
real dmax__;
integer imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact, nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer izero, nerrs;
logical zerot;
real rcondc;
real ainvnm;
real result[6];
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVPT tests SPTSV and -SVX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) REAL array, dimension (NMAX*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) REAL array, dimension (NMAX*2) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NRHS)) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
serrvx_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (n > 0 && ! dotype[imat]) {
goto L110;
}
/* Set up parameters with SLATB4. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a symmetric tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
/* Check the error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[i__] = a[ia];
e[i__] = a[ia + 1];
ia += 2;
/* L20: */
}
if (n > 0) {
d__[n] = a[ia];
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let D and E have values from [-1,1]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
slarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = dabs(d__[1]);
} else {
d__[1] = dabs(d__[1]) + dabs(e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + (r__2 = e[n -
1], dabs(r__2));
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
e[i__], dabs(r__2)) + (r__3 = e[i__ - 1],
dabs(r__3));
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = isamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
r__1 = anorm / dmax__;
sscal_(&n, &r__1, &d__[1], &c__1);
if (n > 1) {
i__3 = n - 1;
r__1 = anorm / dmax__;
sscal_(&i__3, &r__1, &e[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1];
if (n > 1) {
e[1] = z__[2];
}
} else if (izero == n) {
e[n - 1] = z__[0];
d__[n] = z__[1];
} else {
e[izero - 1] = z__[0];
d__[izero] = z__[1];
e[izero] = z__[2];
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1] = d__[1];
d__[1] = 0.f;
if (n > 1) {
z__[2] = e[1];
e[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
z__[0] = e[n - 1];
e[n - 1] = 0.f;
}
z__[1] = d__[n];
d__[n] = 0.f;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
z__[0] = e[izero - 1];
z__[2] = e[izero];
e[izero - 1] = 0.f;
e[izero] = 0.f;
}
z__[1] = d__[izero];
d__[izero] = 0.f;
}
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
slarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L40: */
}
/* Set the right hand side. */
slaptm_(&n, nrhs, &c_b23, &d__[1], &e[1], &xact[1], &lda, &c_b24,
&b[1], &lda);
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by SPTSVX. */
if (zerot) {
if (ifact == 1) {
goto L100;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = slanst_("1", &n, &d__[1], &e[1]);
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* Factor the matrix A. */
spttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Use SPTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L50: */
}
x[i__] = 1.f;
spttrs_(&n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the 1-norm condition number of A. */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
if (ifact == 2) {
/* --- Test SPTSV -- */
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor A as L*D*L' and solve the system A*X = B. */
s_copy(srnamc_1.srnamt, "SPTSV ", (ftnlen)32, (ftnlen)6);
sptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
info);
/* Check error code from SPTSV . */
if (info != izero) {
alaerh_(path, "SPTSV ", &info, &izero, " ", &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
nt = 0;
if (izero == 0) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
/* Compute the residual in the solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[
1], &lda, &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "SPTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += nt;
}
/* --- Test SPTSVX --- */
if (ifact > 1) {
/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[n + i__] = 0.f;
e[n + i__] = 0.f;
/* L80: */
}
if (n > 0) {
d__[n + n] = 0.f;
}
}
slaset_("Full", &n, nrhs, &c_b24, &c_b24, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using SPTSVX. */
s_copy(srnamc_1.srnamt, "SPTSVX", (ftnlen)32, (ftnlen)6);
sptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
*nrhs + 1], &work[1], &info);
/* Check the error code from SPTSVX. */
if (info != izero) {
alaerh_(path, "SPTSVX", &info, &izero, fact, &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
}
if (izero == 0) {
if (ifact == 2) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
k1 = 1;
sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
} else {
k1 = 2;
}
/* Compute the residual in the solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[1], &
lda, &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* Check error bounds from iterative refinement. */
sptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
&result[3]);
} else {
k1 = 6;
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "SPTSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun = nrun + 7 - k1;
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVPT */
} /* sdrvpt_ */
/* Subroutine */ int pslarnv_(integer *comm, integer *idist, integer *iseed,
integer *n, real *x)
{
extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
*);
/* .. MPI VARIABLES AND FUNCTIONS .. */
/* /+ */
/* * */
/* * (C) 1993 by Argonne National Laboratory and Mississipi State University. */
/* * All rights reserved. See COPYRIGHT in top-level directory. */
/* +/ */
/* /+ user include file for MPI programs, with no dependencies +/ */
/* /+ return codes +/ */
/* We handle datatypes by putting the variables that hold them into */
/* common. This way, a Fortran program can directly use the various */
/* datatypes and can even give them to C programs. */
/* MPI_BOTTOM needs to be a known address; here we put it at the */
/* beginning of the common block. The point-to-point and collective */
/* routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not. */
/* The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL. */
/* Their values are zero if they are not available. Note that */
/* using these reduces the portability of code (though may enhance */
/* portability between Crays and other systems) */
/* All other MPI routines are subroutines */
/* The attribute copy/delete functions are symbols that can be passed */
/* to MPI routines */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
--iseed;
/* Function Body */
slarnv_(idist, &iseed[1], n, &x[1]);
return 0;
} /* pslarnv_ */
