/* Subroutine */ int serrlq_(char *path, integer *nunit)
{
/* Local variables */
real a[4] /* was [2][2] */, b[2];
integer i__, j;
real w[2], x[2], af[4] /* was [2][2] */;
integer info;
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SERRLQ tests the error exits for the REAL routines */
/* that use the LQ decomposition of a general matrix. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 2; ++j) {
for (i__ = 1; i__ <= 2; ++i__) {
a[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
af[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
/* L10: */
}
b[j - 1] = 0.f;
w[j - 1] = 0.f;
x[j - 1] = 0.f;
/* L20: */
}
infoc_1.ok = TRUE_;
/* Error exits for LQ factorization */
/* SGELQF */
s_copy(srnamc_1.srnamt, "SGELQF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgelqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgelqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgelqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sgelqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGELQ2 */
s_copy(srnamc_1.srnamt, "SGELQ2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgelq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
chkxer_("SGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgelq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
chkxer_("SGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgelq2_(&c__2, &c__1, a, &c__1, b, w, &info);
chkxer_("SGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGELQS */
s_copy(srnamc_1.srnamt, "SGELQS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgelqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgelqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgelqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgelqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgelqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sgelqs_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sgelqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORGLQ */
s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorglq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorglq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorglq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorglq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorglq_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorglq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sorglq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORGL2 */
s_copy(srnamc_1.srnamt, "SORGL2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorgl2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorgl2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorgl2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorgl2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorgl2_(&c__1, &c__1, &c__2, a, &c__1, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorgl2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORMLQ */
s_copy(srnamc_1.srnamt, "SORMLQ", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sormlq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sormlq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sormlq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sormlq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormlq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormlq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormlq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sormlq_("L", "N", &c__2, &c__0, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sormlq_("R", "N", &c__0, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sormlq_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
sormlq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
sormlq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORML2 */
s_copy(srnamc_1.srnamt, "SORML2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorml2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorml2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorml2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sorml2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorml2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorml2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorml2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sorml2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sorml2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sorml2_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of SERRLQ */
} /* serrlq_ */
/* Subroutine */ int slqt03_(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
*), sorglq_(integer *, integer *, integer *, real *, integer *,
real *, real *, integer *, integer *), sormlq_(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 */
/* ======= */
/* SLQT03 tests SORMLQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
/* SLQT03 compares the results of a call to SORMLQ with the results of */
/* forming Q explicitly by a call to SORGLQ and then performing matrix */
/* multiplication by a call to SGEMM. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows or columns of the matrix C; C is n-by-m if */
/* Q is applied from the left, or m-by-n if Q is applied from */
/* the right. M >= 0. */
/* N (input) INTEGER */
/* The order of the orthogonal matrix Q. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* orthogonal matrix Q. N >= K >= 0. */
/* AF (input) REAL array, dimension (LDA,N) */
/* Details of the LQ factorization of an m-by-n matrix, as */
/* returned by SGELQF. See SGELQF for further details. */
/* C (workspace) REAL array, dimension (LDA,N) */
/* CC (workspace) REAL array, dimension (LDA,N) */
/* Q (workspace) REAL array, dimension (LDA,N) */
/* 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 LQ 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 n-by-n orthogonal matrix Q. */
/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * 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 rows of the factorization to the array Q */
slaset_("Full", n, n, &c_b4, &c_b4, &q[q_offset], lda);
i__1 = *n - 1;
slacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ 1], lda);
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)32, (ftnlen)6);
sorglq_(n, n, 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 = *n;
nc = *m;
} else {
*(unsigned char *)side = 'R';
mc = *m;
nc = *n;
}
/* 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, "SORMLQ", (ftnlen)32, (ftnlen)6);
sormlq_(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,*n) *
cnorm * eps);
/* L20: */
}
/* L30: */
}
return 0;
/* End of SLQT03 */
} /* slqt03_ */
/* Subroutine */ int slqt02_(integer *m, integer *n, integer *k, real *a,
real *af, real *q, real *l, integer *lda, real *tau, real *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real eps;
integer info;
real resid;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
real anorm;
extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
real *, real *, integer *, real *, real *, integer *);
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 *), sorglq_(
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLQT02 tests SORGLQ, which generates an m-by-n matrix Q with */
/* orthonornmal rows that is defined as the product of k elementary */
/* reflectors. */
/* Given the LQ factorization of an m-by-n matrix A, SLQT02 generates */
/* the orthogonal matrix Q defined by the factorization of the first k */
/* rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and */
/* checks that the rows of Q are orthonormal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q to be generated. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q to be generated. */
/* N >= M >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by SLQT01. */
/* AF (input) REAL array, dimension (LDA,N) */
/* Details of the LQ factorization of A, as returned by SGELQF. */
/* See SGELQF for further details. */
/* Q (workspace) REAL array, dimension (LDA,N) */
/* L (workspace) REAL array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) REAL array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the LQ factorization in AF. */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
eps = slamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
i__1 = *n - 1;
slacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ 1], lda);
/* Generate the first n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)32, (ftnlen)6);
sorglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L(1:k,1:m) */
slaset_("Full", k, m, &c_b9, &c_b9, &l[l_offset], lda);
slacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
sgemm_("No transpose", "Transpose", k, m, n, &c_b14, &a[a_offset], lda, &
q[q_offset], lda, &c_b15, &l[l_offset], lda);
/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = slange_("1", k, n, &a[a_offset], lda, &rwork[1]);
resid = slange_("1", k, m, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*n) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q*Q' */
slaset_("Full", m, m, &c_b9, &c_b15, &l[l_offset], lda);
ssyrk_("Upper", "No transpose", m, n, &c_b14, &q[q_offset], lda, &c_b15, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = slansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*n) / eps;
return 0;
/* End of SLQT02 */
} /* slqt02_ */
/* Subroutine */ int slqt02_(integer *m, integer *n, integer *k, real *a,
real *af, real *q, real *l, integer *lda, real *tau, real *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
static real resid;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static real anorm;
extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
real *, real *, integer *, real *, real *, integer *);
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 *), sorglq_(
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
static real eps;
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define af_ref(a_1,a_2) af[(a_2)*af_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
=======
SLQT02 tests SORGLQ, which generates an m-by-n matrix Q with
orthonornmal rows that is defined as the product of k elementary
reflectors.
Given the LQ factorization of an m-by-n matrix A, SLQT02 generates
the orthogonal matrix Q defined by the factorization of the first k
rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and
checks that the rows of Q are orthonormal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q to be generated. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q to be generated.
N >= M >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. M >= K >= 0.
A (input) REAL array, dimension (LDA,N)
The m-by-n matrix A which was factorized by SLQT01.
AF (input) REAL array, dimension (LDA,N)
Details of the LQ factorization of A, as returned by SGELQF.
See SGELQF for further details.
Q (workspace) REAL array, dimension (LDA,N)
L (workspace) REAL array, dimension (LDA,M)
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and L. LDA >= N.
TAU (input) REAL array, dimension (M)
The scalar factors of the elementary reflectors corresponding
to the LQ factorization in AF.
WORK (workspace) REAL array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) REAL array, dimension (M)
RESULT (output) REAL array, dimension (2)
The test ratios:
RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
=====================================================================
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
eps = slamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
i__1 = *n - 1;
slacpy_("Upper", k, &i__1, &af_ref(1, 2), lda, &q_ref(1, 2), lda);
/* Generate the first n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)6, (ftnlen)6);
sorglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L(1:k,1:m) */
slaset_("Full", k, m, &c_b9, &c_b9, &l[l_offset], lda);
slacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
sgemm_("No transpose", "Transpose", k, m, n, &c_b14, &a[a_offset], lda, &
q[q_offset], lda, &c_b15, &l[l_offset], lda);
/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = slange_("1", k, n, &a[a_offset], lda, &rwork[1]);
resid = slange_("1", k, m, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*n) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q*Q' */
slaset_("Full", m, m, &c_b9, &c_b15, &l[l_offset], lda);
ssyrk_("Upper", "No transpose", m, n, &c_b14, &q[q_offset], lda, &c_b15, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = slansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*n) / eps;
return 0;
/* End of SLQT02 */
} /* slqt02_ */
/* Subroutine */ int sorgbr_(char *vect, integer *m, integer *n, integer *k,
real *a, integer *lda, real *tau, real *work, integer *lwork, integer
*info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, j, nb, mn;
extern logical lsame_(char *, char *);
integer iinfo;
logical wantq;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int sorglq_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *), sorgqr_(
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SORGBR generates one of the real orthogonal matrices Q or P**T */
/* determined by SGEBRD when reducing a real matrix A to bidiagonal */
/* form: A = Q * B * P**T. Q and P**T are defined as products of */
/* elementary reflectors H(i) or G(i) respectively. */
/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */
/* is of order M: */
/* if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n */
/* columns of Q, where m >= n >= k; */
/* if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an */
/* M-by-M matrix. */
/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T */
/* is of order N: */
/* if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m */
/* rows of P**T, where n >= m >= k; */
/* if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as */
/* an N-by-N matrix. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* Specifies whether the matrix Q or the matrix P**T is */
/* required, as defined in the transformation applied by SGEBRD: */
/* = 'Q': generate Q; */
/* = 'P': generate P**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix Q or P**T to be returned. */
/* M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q or P**T to be returned. */
/* N >= 0. */
/* If VECT = 'Q', M >= N >= min(M,K); */
/* if VECT = 'P', N >= M >= min(N,K). */
/* K (input) INTEGER */
/* If VECT = 'Q', the number of columns in the original M-by-K */
/* matrix reduced by SGEBRD. */
/* If VECT = 'P', the number of rows in the original K-by-N */
/* matrix reduced by SGEBRD. */
/* K >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the vectors which define the elementary reflectors, */
/* as returned by SGEBRD. */
/* On exit, the M-by-N matrix Q or P**T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (input) REAL array, dimension */
/* (min(M,K)) if VECT = 'Q' */
/* (min(N,K)) if VECT = 'P' */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i) or G(i), which determines Q or P**T, as */
/* returned by SGEBRD in its array argument TAUQ or TAUP. */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,min(M,N)). */
/* For optimum performance LWORK >= min(M,N)*NB, where NB */
/* is the optimal blocksize. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
wantq = lsame_(vect, "Q");
mn = min(*m,*n);
lquery = *lwork == -1;
if (! wantq && ! lsame_(vect, "P")) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
*m > *n || *m < min(*n,*k))) {
*info = -3;
} else if (*k < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else if (*lwork < max(1,mn) && ! lquery) {
*info = -9;
}
if (*info == 0) {
if (wantq) {
nb = ilaenv_(&c__1, "SORGQR", " ", m, n, k, &c_n1);
} else {
nb = ilaenv_(&c__1, "SORGLQ", " ", m, n, k, &c_n1);
}
lwkopt = max(1,mn) * nb;
work[1] = (real) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORGBR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
work[1] = 1.f;
return 0;
}
if (wantq) {
/* Form Q, determined by a call to SGEBRD to reduce an m-by-k */
/* matrix */
if (*m >= *k) {
/* If m >= k, assume m >= n >= k */
sorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo);
} else {
/* If m < k, assume m = n */
/* Shift the vectors which define the elementary reflectors one */
/* column to the right, and set the first row and column of Q */
/* to those of the unit matrix */
for (j = *m; j >= 2; --j) {
a[j * a_dim1 + 1] = 0.f;
i__1 = *m;
for (i__ = j + 1; i__ <= i__1; ++i__) {
a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
/* L10: */
}
/* L20: */
}
a[a_dim1 + 1] = 1.f;
i__1 = *m;
for (i__ = 2; i__ <= i__1; ++i__) {
a[i__ + a_dim1] = 0.f;
/* L30: */
}
if (*m > 1) {
/* Form Q(2:m,2:m) */
i__1 = *m - 1;
i__2 = *m - 1;
i__3 = *m - 1;
sorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo);
}
}
} else {
/* Form P', determined by a call to SGEBRD to reduce a k-by-n */
/* matrix */
if (*k < *n) {
/* If k < n, assume k <= m <= n */
sorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo);
} else {
/* If k >= n, assume m = n */
/* Shift the vectors which define the elementary reflectors one */
/* row downward, and set the first row and column of P' to */
/* those of the unit matrix */
a[a_dim1 + 1] = 1.f;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
a[i__ + a_dim1] = 0.f;
/* L40: */
}
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
for (i__ = j - 1; i__ >= 2; --i__) {
a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1];
/* L50: */
}
a[j * a_dim1 + 1] = 0.f;
/* L60: */
}
if (*n > 1) {
/* Form P'(2:n,2:n) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
sorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo);
}
}
}
work[1] = (real) lwkopt;
return 0;
/* End of SORGBR */
} /* sorgbr_ */
