/* 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_ */