/* Subroutine */ int serrqr_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* 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;
extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
*, real *, real *, integer *), sorg2r_(integer *, integer *,
integer *, real *, integer *, real *, real *, integer *), sorm2r_(
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, real *, integer *, real *, integer *),
alaesm_(char *, logical *, integer *), chkxer_(char *,
integer *, integer *, logical *, logical *), sgeqrf_(
integer *, integer *, real *, integer *, real *, real *, integer *
, integer *), sgeqrs_(integer *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, integer *, integer *
), sorgqr_(integer *, integer *, integer *, real *, integer *,
real *, real *, integer *, integer *), sormqr_(char *, char *,
integer *, integer *, integer *, real *, integer *, real *, real *
, integer *, real *, integer *, integer *);
/* 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 */
/* ======= */
/* SERRQR tests the error exits for the REAL routines */
/* that use the QR 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 QR factorization */
/* SGEQRF */
s_copy(srnamc_1.srnamt, "SGEQRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgeqrf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
chkxer_("SGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgeqrf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
chkxer_("SGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgeqrf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
chkxer_("SGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sgeqrf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
chkxer_("SGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGEQR2 */
s_copy(srnamc_1.srnamt, "SGEQR2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgeqr2_(&c_n1, &c__0, a, &c__1, b, w, &info);
chkxer_("SGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgeqr2_(&c__0, &c_n1, a, &c__1, b, w, &info);
chkxer_("SGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sgeqr2_(&c__2, &c__1, a, &c__1, b, w, &info);
chkxer_("SGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SGEQRS */
s_copy(srnamc_1.srnamt, "SGEQRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sgeqrs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgeqrs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sgeqrs_(&c__1, &c__2, &c__0, a, &c__2, x, b, &c__2, w, &c__1, &info);
chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sgeqrs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sgeqrs_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sgeqrs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sgeqrs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORGQR */
s_copy(srnamc_1.srnamt, "SORGQR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorgqr_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorgqr_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorgqr_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorgqr_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorgqr_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorgqr_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
sorgqr_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORG2R */
s_copy(srnamc_1.srnamt, "SORG2R", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorg2r_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorg2r_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorg2r_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorg2r_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorg2r_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorg2r_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORMQR */
s_copy(srnamc_1.srnamt, "SORMQR", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sormqr_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sormqr_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sormqr_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sormqr_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormqr_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormqr_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sormqr_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sormqr_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sormqr_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sormqr_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
sormqr_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
sormqr_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
info);
chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SORM2R */
s_copy(srnamc_1.srnamt, "SORM2R", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
sorm2r_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
sorm2r_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
sorm2r_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
sorm2r_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorm2r_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorm2r_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
sorm2r_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sorm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
sorm2r_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
sorm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
chkxer_("SORM2R", &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 SERRQR */
} /* serrqr_ */
/* Subroutine */
int sggsvp_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, real *a, integer *lda, real *b, integer *ldb, real *tola, real *tolb, integer *k, integer *l, real *u, integer *ldu, real *v, integer *ldv, real *q, integer *ldq, integer *iwork, real * tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
integer i__, j;
extern logical lsame_(char *, char *);
logical wantq, wantu, wantv;
extern /* Subroutine */
int sgeqr2_(integer *, integer *, real *, integer *, real *, real *, integer *), sgerq2_(integer *, integer *, real *, integer *, real *, real *, integer *), sorg2r_(integer *, integer *, integer *, real *, integer *, real *, real *, integer * ), sorm2r_(char *, char *, integer *, integer *, integer *, real * , integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *), xerbla_(char *, integer *), sgeqpf_( integer *, integer *, real *, integer *, integer *, real *, real * , integer *), slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *), slapmt_( logical *, integer *, integer *, real *, integer *, integer *);
logical forwrd;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--iwork;
--tau;
--work;
/* Function Body */
wantu = lsame_(jobu, "U");
wantv = lsame_(jobv, "V");
wantq = lsame_(jobq, "Q");
forwrd = TRUE_;
*info = 0;
if (! (wantu || lsame_(jobu, "N")))
{
*info = -1;
}
else if (! (wantv || lsame_(jobv, "N")))
{
*info = -2;
}
else if (! (wantq || lsame_(jobq, "N")))
{
*info = -3;
}
else if (*m < 0)
{
*info = -4;
}
else if (*p < 0)
{
*info = -5;
}
else if (*n < 0)
{
*info = -6;
}
else if (*lda < max(1,*m))
{
*info = -8;
}
else if (*ldb < max(1,*p))
{
*info = -10;
}
else if (*ldu < 1 || wantu && *ldu < *m)
{
*info = -16;
}
else if (*ldv < 1 || wantv && *ldv < *p)
{
*info = -18;
}
else if (*ldq < 1 || wantq && *ldq < *n)
{
*info = -20;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SGGSVP", &i__1);
return 0;
}
/* QR with column pivoting of B: B*P = V*( S11 S12 ) */
/* ( 0 0 ) */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
iwork[i__] = 0;
/* L10: */
}
sgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info);
/* Update A := A*P */
slapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
/* Determine the effective rank of matrix B. */
*l = 0;
i__1 = min(*p,*n);
for (i__ = 1;
i__ <= i__1;
++i__)
{
if ((r__1 = b[i__ + i__ * b_dim1], f2c_abs(r__1)) > *tolb)
{
++(*l);
}
/* L20: */
}
if (wantv)
{
/* Copy the details of V, and form V. */
slaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv);
if (*p > 1)
{
i__1 = *p - 1;
slacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2], ldv);
}
i__1 = min(*p,*n);
sorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
}
/* Clean up B */
i__1 = *l - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *l;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
b[i__ + j * b_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
if (*p > *l)
{
i__1 = *p - *l;
slaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb);
}
if (wantq)
{
/* Set Q = I and Update Q := Q*P */
slaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq);
slapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
}
if (*p >= *l && *n != *l)
{
/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */
sgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
/* Update A := A*Z**T */
sormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[ a_offset], lda, &work[1], info);
if (wantq)
{
/* Update Q := Q*Z**T */
sormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1], &q[q_offset], ldq, &work[1], info);
}
/* Clean up B */
i__1 = *n - *l;
slaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb);
i__1 = *n;
for (j = *n - *l + 1;
j <= i__1;
++j)
{
i__2 = *l;
for (i__ = j - *n + *l + 1;
i__ <= i__2;
++i__)
{
b[i__ + j * b_dim1] = 0.f;
/* L50: */
}
/* L60: */
}
}
/* Let N-L L */
/* A = ( A11 A12 ) M, */
/* then the following does the complete QR decomposition of A11: */
/* A11 = U*( 0 T12 )*P1**T */
/* ( 0 0 ) */
i__1 = *n - *l;
for (i__ = 1;
i__ <= i__1;
++i__)
{
iwork[i__] = 0;
/* L70: */
}
i__1 = *n - *l;
sgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info);
/* Determine the effective rank of A11 */
*k = 0;
/* Computing MIN */
i__2 = *m;
i__3 = *n - *l; // , expr subst
i__1 = min(i__2,i__3);
for (i__ = 1;
i__ <= i__1;
++i__)
{
if ((r__1 = a[i__ + i__ * a_dim1], f2c_abs(r__1)) > *tola)
{
++(*k);
}
/* L80: */
}
/* Update A12 := U**T*A12, where A12 = A( 1:M, N-L+1:N ) */
/* Computing MIN */
i__2 = *m;
i__3 = *n - *l; // , expr subst
i__1 = min(i__2,i__3);
sorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[( *n - *l + 1) * a_dim1 + 1], lda, &work[1], info);
if (wantu)
{
/* Copy the details of U, and form U */
slaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu);
if (*m > 1)
{
i__1 = *m - 1;
i__2 = *n - *l;
slacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2] , ldu);
}
/* Computing MIN */
i__2 = *m;
i__3 = *n - *l; // , expr subst
i__1 = min(i__2,i__3);
sorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
}
if (wantq)
{
/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
i__1 = *n - *l;
slapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
}
/* Clean up A: set the strictly lower triangular part of */
/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
i__1 = *k - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *k;
for (i__ = j + 1;
i__ <= i__2;
++i__)
{
a[i__ + j * a_dim1] = 0.f;
/* L90: */
}
/* L100: */
}
if (*m > *k)
{
i__1 = *m - *k;
i__2 = *n - *l;
slaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1], lda);
}
if (*n - *l > *k)
{
/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
i__1 = *n - *l;
sgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
if (wantq)
{
/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1**T */
i__1 = *n - *l;
sormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, & tau[1], &q[q_offset], ldq, &work[1], info);
}
/* Clean up A */
i__1 = *n - *l - *k;
slaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda);
i__1 = *n - *l;
for (j = *n - *l - *k + 1;
j <= i__1;
++j)
{
i__2 = *k;
for (i__ = j - *n + *l + *k + 1;
i__ <= i__2;
++i__)
{
a[i__ + j * a_dim1] = 0.f;
/* L110: */
}
/* L120: */
}
}
if (*m > *k)
{
/* QR factorization of A( K+1:M,N-L+1:N ) */
i__1 = *m - *k;
sgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], & work[1], info);
if (wantu)
{
/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */
i__1 = *m - *k;
/* Computing MIN */
i__3 = *m - *k;
i__2 = min(i__3,*l);
sorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 + 1], ldu, &work[1], info);
}
/* Clean up */
i__1 = *n;
for (j = *n - *l + 1;
j <= i__1;
++j)
{
i__2 = *m;
for (i__ = j - *n + *k + *l + 1;
i__ <= i__2;
++i__)
{
a[i__ + j * a_dim1] = 0.f;
/* L130: */
}
/* L140: */
}
}
return 0;
/* End of SGGSVP */
}
/* Subroutine */ int sopgtr_(char *uplo, integer *n, real *ap, real *tau,
real *q, integer *ldq, real *work, 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
=======
SOPGTR generates a real orthogonal matrix Q which is defined as the
product of n-1 elementary reflectors H(i) of order n, as returned by
SSPTRD using packed storage:
if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangular packed storage used in previous
call to SSPTRD;
= 'L': Lower triangular packed storage used in previous
call to SSPTRD.
N (input) INTEGER
The order of the matrix Q. N >= 0.
AP (input) REAL array, dimension (N*(N+1)/2)
The vectors which define the elementary reflectors, as
returned by SSPTRD.
TAU (input) REAL array, dimension (N-1)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by SSPTRD.
Q (output) REAL array, dimension (LDQ,N)
The N-by-N orthogonal matrix Q.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N).
WORK (workspace) REAL array, dimension (N-1)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2, i__3;
/* Local variables */
static integer i, j;
extern logical lsame_(char *, char *);
static integer iinfo;
static logical upper;
extern /* Subroutine */ int sorg2l_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *), sorg2r_(integer *,
integer *, integer *, real *, integer *, real *, real *, integer *
);
static integer ij;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define AP(I) ap[(I)-1]
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define Q(I,J) q[(I)-1 + ((J)-1)* ( *ldq)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SOPGTR", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Q was determined by a call to SSPTRD with UPLO = 'U'
Unpack the vectors which define the elementary reflectors an
d
set the last row and column of Q equal to those of the unit
matrix */
ij = 2;
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
i__2 = j - 1;
for (i = 1; i <= j-1; ++i) {
Q(i,j) = AP(ij);
++ij;
/* L10: */
}
ij += 2;
Q(*n,j) = 0.f;
/* L20: */
}
i__1 = *n - 1;
for (i = 1; i <= *n-1; ++i) {
Q(i,*n) = 0.f;
/* L30: */
}
Q(*n,*n) = 1.f;
/* Generate Q(1:n-1,1:n-1) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
sorg2l_(&i__1, &i__2, &i__3, &Q(1,1), ldq, &TAU(1), &WORK(1), &
iinfo);
} else {
/* Q was determined by a call to SSPTRD with UPLO = 'L'.
Unpack the vectors which define the elementary reflectors an
d
set the first row and column of Q equal to those of the unit
matrix */
Q(1,1) = 1.f;
i__1 = *n;
for (i = 2; i <= *n; ++i) {
Q(i,1) = 0.f;
/* L40: */
}
ij = 3;
i__1 = *n;
for (j = 2; j <= *n; ++j) {
Q(1,j) = 0.f;
i__2 = *n;
for (i = j + 1; i <= *n; ++i) {
Q(i,j) = AP(ij);
++ij;
/* L50: */
}
ij += 2;
/* L60: */
}
if (*n > 1) {
/* Generate Q(2:n,2:n) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
sorg2r_(&i__1, &i__2, &i__3, &Q(2,2), ldq, &TAU(1),
&WORK(1), &iinfo);
}
}
return 0;
/* End of SOPGTR */
} /* sopgtr_ */
