/* 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 */
static integer info;
static real a[4] /* was [2][2] */, b[2];
static integer i__, j;
static real w[2], x[2];
extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
*, real *, real *, integer *);
static real af[4] /* was [2][2] */;
extern /* Subroutine */ int 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 };
#define a_ref(a_1,a_2) a[(a_2)*2 + a_1 - 3]
#define af_ref(a_1,a_2) af[(a_2)*2 + a_1 - 3]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
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.
===================================================================== */
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_ref(i__, j) = 1.f / (real) (i__ + j);
af_ref(i__, j) = 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)6, (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)6, (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)6, (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)6, (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)6, (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)6, (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)6, (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 sdrvgg_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, real *thrshn, integer *
nounit, real *a, integer *lda, real *b, real *s, real *t, real *s2,
real *t2, real *q, integer *ldq, real *z__, real *alphr1, real *
alphi1, real *beta1, real *alphr2, real *alphi2, real *beta2, real *
vl, real *vr, real *work, integer *lwork, real *result, integer *info)
{
/* Initialized data */
static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
2,2,2,3 };
static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
2,3,2,1 };
static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
1,1,1,1 };
static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
2,2,2,0 };
static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
0,0,0,0 };
static integer kz1[6] = { 0,1,2,1,3,3 };
static integer kz2[6] = { 0,0,1,2,1,1 };
static integer kadd[6] = { 0,0,0,0,3,2 };
static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
4,4,4,0 };
static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
8,8,8,8,8,0 };
static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
3,3,3,1 };
static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
4,4,4,1 };
static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
3,3,2,1 };
/* Format strings */
static char fmt_9999[] = "(\002 SDRVGG: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 SDRVGG: SGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9996[] = "(\002 SDRVGG: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
"ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 SDRVGG: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9995[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
"oblem driver\002)";
static char fmt_9994[] = "(\002 Matrix types (see SDRVGG for details):"
" \002)";
static char fmt_9993[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
"osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
"onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
"I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
"arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
"(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
"=(D, reversed D)\002)";
static char fmt_9992[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
"atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
" 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
"ha&beta \002,\002 20=arithmetic alpha, beta=0,"
"1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
"=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
"/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
"l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
".\002)";
static char fmt_9991[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\002l and r "
"are the appropriate left and right\002,/19x,\002eigenvectors, re"
"sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
"\002.)\002,/\002 1 = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) "
" 2 = | B - Q T Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | "
"I - QQ\002,a,\002 | / ( n ulp ) 4 = | I - ZZ\002,a"
",\002 | / ( n ulp )\002,/\002 5 = difference between (alpha,beta"
") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
"B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
"t.\002,/1x)";
static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",0p,f8.2)";
static char fmt_9989[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
",1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1,
z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
/* Builtin functions */
double r_sign(real *, real *);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer j, n, i1, n1, jc, nb, in, jr, ns, nbz;
real ulp;
integer iadd, nmax;
real temp1, temp2;
logical badnn;
real dumma[4];
integer iinfo;
real rmagn[4];
extern /* Subroutine */ int sgegs_(char *, char *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
integer *, real *, integer *, real *, integer *, integer *), sget51_(integer *, integer *, real *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *), sget52_(logical *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
real *), sgegv_(char *, char *, integer *, real *, integer *,
real *, integer *, real *, real *, real *, real *, integer *,
real *, integer *, real *, integer *, integer *),
sget53_(real *, integer *, real *, integer *, real *, real *,
real *, real *, integer *);
integer nmats, jsize, nerrs, jtype, ntest;
extern /* Subroutine */ int slatm4_(integer *, integer *, integer *,
integer *, integer *, real *, real *, real *, integer *, integer *
, real *, integer *);
logical ilabad;
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *), slabad_(real *, real *);
extern doublereal slamch_(char *);
real safmin;
integer ioldsd[4];
real safmax;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
real *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), xerbla_(char *, integer *),
slacpy_(char *, integer *, integer *, real *, integer *, real *,
integer *), slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
real ulpinv;
integer lwkopt, mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___60 = { 0, 0, 0, fmt_9989, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVGG checks the nonsymmetric generalized eigenvalue driver */
/* routines. */
/* T T T */
/* SGEGS factors A and B as Q S Z and Q T Z , where means */
/* transpose, T is upper triangular, S is in generalized Schur form */
/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
/* the 2x2 blocks corresponding to complex conjugate pairs of */
/* generalized eigenvalues), and Q and Z are orthogonal. It also */
/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) -- */
/* thus, w(j) = alpha(j)/beta(j) is a root of the generalized */
/* eigenvalue problem */
/* det( A - w(j) B ) = 0 */
/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
/* problem */
/* det( m(j) A - B ) = 0 */
/* SGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
/* (alpha(n),beta(n)), the matrix L whose columns contain the */
/* generalized left eigenvectors l, and the matrix R whose columns */
/* contain the generalized right eigenvectors r for the pair (A,B). */
/* When SDRVGG is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
/* tests will be performed and compared with the threshhold THRESH: */
/* Results from SGEGS: */
/* T */
/* (1) | A - Q S Z | / ( |A| n ulp ) */
/* T */
/* (2) | B - Q T Z | / ( |B| n ulp ) */
/* T */
/* (3) | I - QQ | / ( n ulp ) */
/* T */
/* (4) | I - ZZ | / ( n ulp ) */
/* (5) maximum over j of D(j) where: */
/* if alpha(j) is real: */
/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
/* D(j) = ------------------------ + ----------------------- */
/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
/* if alpha(j) is complex: */
/* | det( s S - w T ) | */
/* D(j) = --------------------------------------------------- */
/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
/* and S and T are here the 2 x 2 diagonal blocks of S and T */
/* corresponding to the j-th eigenvalue. */
/* Results from SGEGV: */
/* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
/* where l**H is the conjugate tranpose of l. */
/* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
/* Test Matrices */
/* ---- -------- */
/* The sizes of the test matrices are specified by an array */
/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) ( 0, 0 ) (a pair of zero matrices) */
/* (2) ( I, 0 ) (an identity and a zero matrix) */
/* (3) ( 0, I ) (an identity and a zero matrix) */
/* (4) ( I, I ) (a pair of identity matrices) */
/* t t */
/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
/* t ( I 0 ) */
/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
/* ( 0 I ) ( 0 J ) */
/* and I is a k x k identity and J a (k+1)x(k+1) */
/* Jordan block; k=(N-1)/2 */
/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
/* matrix with those diagonal entries.) */
/* (8) ( I, D ) */
/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
/* (10) ( small*D, big*I ) */
/* (11) ( big*I, small*D ) */
/* (12) ( small*I, big*D ) */
/* (13) ( big*D, big*I ) */
/* (14) ( small*D, small*I ) */
/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
/* t t */
/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
/* with random O(1) entries above the diagonal */
/* and diagonal entries diag(T1) = */
/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
/* s = machine precision. */
/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
/* N-5 */
/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
/* where r1,..., r(N-4) are random. */
/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
/* matrices. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* SDRVGG does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, SDRVGG */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to SDRVGG to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error is */
/* scaled to be O(1), so THRESH should be a reasonably small */
/* multiple of 1, e.g., 10 or 100. In particular, it should */
/* not depend on the precision (single vs. double) or the size */
/* of the matrix. It must be at least zero. */
/* THRSHN (input) REAL */
/* Threshhold for reporting eigenvector normalization error. */
/* If the normalization of any eigenvector differs from 1 by */
/* more than THRSHN*ulp, then a special error message will be */
/* printed. (This is handled separately from the other tests, */
/* since only a compiler or programming error should cause an */
/* error message, at least if THRSHN is at least 5--10.) */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) REAL array, dimension */
/* (LDA, max(NN)) */
/* Used to hold the original A matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, S, T, S2, and T2. */
/* It must be at least 1 and at least max( NN ). */
/* B (input/workspace) REAL array, dimension */
/* (LDA, max(NN)) */
/* Used to hold the original B matrix. Used as input only */
/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
/* DOTYPE(MAXTYP+1)=.TRUE. */
/* S (workspace) REAL array, dimension (LDA, max(NN)) */
/* The Schur form matrix computed from A by SGEGS. On exit, S */
/* contains the Schur form matrix corresponding to the matrix */
/* in A. */
/* T (workspace) REAL array, dimension (LDA, max(NN)) */
/* The upper triangular matrix computed from B by SGEGS. */
/* S2 (workspace) REAL array, dimension (LDA, max(NN)) */
/* The matrix computed from A by SGEGV. This will be the */
/* Schur form of some matrix related to A, but will not, in */
/* general, be the same as S. */
/* T2 (workspace) REAL array, dimension (LDA, max(NN)) */
/* The matrix computed from B by SGEGV. This will be the */
/* Schur form of some matrix related to B, but will not, in */
/* general, be the same as T. */
/* Q (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (left) orthogonal matrix computed by SGEGS. */
/* LDQ (input) INTEGER */
/* The leading dimension of Q, Z, VL, and VR. It must */
/* be at least 1 and at least max( NN ). */
/* Z (workspace) REAL array of */
/* dimension( LDQ, max(NN) ) */
/* The (right) orthogonal matrix computed by SGEGS. */
/* ALPHR1 (workspace) REAL array, dimension (max(NN)) */
/* ALPHI1 (workspace) REAL array, dimension (max(NN)) */
/* BETA1 (workspace) REAL array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by SGEGS. */
/* ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th */
/* generalized eigenvalue of the matrices in A and B. */
/* ALPHR2 (workspace) REAL array, dimension (max(NN)) */
/* ALPHI2 (workspace) REAL array, dimension (max(NN)) */
/* BETA2 (workspace) REAL array, dimension (max(NN)) */
/* The generalized eigenvalues of (A,B) computed by SGEGV. */
/* ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th */
/* generalized eigenvalue of the matrices in A and B. */
/* VL (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (block lower triangular) left eigenvector matrix for */
/* the matrices in A and B. (See STGEVC for the format.) */
/* VR (workspace) REAL array, dimension (LDQ, max(NN)) */
/* The (block upper triangular) right eigenvector matrix for */
/* the matrices in A and B. (See STGEVC for the format.) */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where */
/* "k" is the sum of the blocksize and number-of-shifts for */
/* SHGEQZ, and NB is the greatest of the blocksizes for */
/* SGEQRF, SORMQR, and SORGQR. (The blocksizes and the */
/* number-of-shifts are retrieved through calls to ILAENV.) */
/* RESULT (output) REAL array, dimension (15) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. INFO is the */
/* absolute value of the INFO value returned. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
t2_dim1 = *lda;
t2_offset = 1 + t2_dim1;
t2 -= t2_offset;
s2_dim1 = *lda;
s2_offset = 1 + s2_dim1;
s2 -= s2_offset;
t_dim1 = *lda;
t_offset = 1 + t_dim1;
t -= t_offset;
s_dim1 = *lda;
s_offset = 1 + s_dim1;
s -= s_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
vr_dim1 = *ldq;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
vl_dim1 = *ldq;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
z_dim1 = *ldq;
z_offset = 1 + z_dim1;
z__ -= z_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--alphr1;
--alphi1;
--beta1;
--alphr2;
--alphi2;
--beta2;
--work;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
*info = 0;
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Maximum blocksize and shift -- we assume that blocksize and number */
/* of shifts are monotone increasing functions of N. */
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "SGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
c__1, "SORMQR", "LT", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "SORGQR",
" ", &nmax, &nmax, &nmax, &c_n1);
nb = max(i__1,i__2);
nbz = ilaenv_(&c__1, "SHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
ns = ilaenv_(&c__4, "SHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
i1 = nbz + ns;
/* Computing MAX */
i__1 = nmax * 6, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
i1 << 1) + nmax + 1) * (i1 + 1);
lwkopt = (nmax << 1) + max(i__1,i__2);
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*lda <= 1 || *lda < nmax) {
*info = -10;
} else if (*ldq <= 1 || *ldq < nmax) {
*info = -19;
} else if (lwkopt > *lwork) {
*info = -30;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRVGG", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0) {
return 0;
}
safmin = slamch_("Safe minimum");
ulp = slamch_("Epsilon") * slamch_("Base");
safmin /= ulp;
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulpinv = 1.f / ulp;
/* The values RMAGN(2:3) depend on N, see below. */
rmagn[0] = 0.f;
rmagn[1] = 1.f;
/* Loop over sizes, types */
ntestt = 0;
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
n1 = max(1,n);
rmagn[2] = safmax * ulp / (real) n1;
rmagn[3] = safmin * ulpinv * n1;
if (*nsizes != 1) {
mtypes = min(26,*ntypes);
} else {
mtypes = min(27,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L160;
}
++nmats;
ntest = 0;
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Initialize RESULT */
for (j = 1; j <= 15; ++j) {
result[j] = 0.f;
/* L30: */
}
/* Compute A and B */
/* Description of control parameters: */
/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
/* =3 means random. */
/* KATYPE: the "type" to be passed to SLATM4 for computing A. */
/* KAZERO: the pattern of zeros on the diagonal for A: */
/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
/* non-zero entries.) */
/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
/* =2: large, =3: small. */
/* IASIGN: 1 if the diagonal elements of A are to be */
/* multiplied by a random magnitude 1 number, =2 if */
/* randomly chosen diagonal blocks are to be rotated */
/* to form 2x2 blocks. */
/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
/* RMAGN: used to implement KAMAGN and KBMAGN. */
if (mtypes > 26) {
goto L110;
}
iinfo = 0;
if (kclass[jtype - 1] < 3) {
/* Generate A (w/o rotation) */
if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
slaset_("Full", &n, &n, &c_b36, &c_b36, &a[a_offset],
lda);
}
} else {
in = n;
}
slatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
&kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
a_offset], lda);
iadd = kadd[kazero[jtype - 1] - 1];
if (iadd > 0 && iadd <= n) {
a[iadd + iadd * a_dim1] = 1.f;
}
/* Generate B (w/o rotation) */
if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
in = ((n - 1) / 2 << 1) + 1;
if (in != n) {
slaset_("Full", &n, &n, &c_b36, &c_b36, &b[b_offset],
lda);
}
} else {
in = n;
}
slatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
&kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
rmagn[kbmagn[jtype - 1]], &c_b42, &rmagn[ktrian[jtype
- 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
b_offset], lda);
iadd = kadd[kbzero[jtype - 1] - 1];
if (iadd != 0 && iadd <= n) {
b[iadd + iadd * b_dim1] = 1.f;
}
if (kclass[jtype - 1] == 2 && n > 0) {
/* Include rotations */
/* Generate Q, Z as Householder transformations times */
/* a diagonal matrix. */
i__3 = n - 1;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = jc; jr <= i__4; ++jr) {
q[jr + jc * q_dim1] = slarnd_(&c__3, &iseed[1]);
z__[jr + jc * z_dim1] = slarnd_(&c__3, &iseed[1]);
/* L40: */
}
i__4 = n + 1 - jc;
slarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
q_dim1], &c__1, &work[jc]);
work[(n << 1) + jc] = r_sign(&c_b42, &q[jc + jc *
q_dim1]);
q[jc + jc * q_dim1] = 1.f;
i__4 = n + 1 - jc;
slarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
jc * z_dim1], &c__1, &work[n + jc]);
work[n * 3 + jc] = r_sign(&c_b42, &z__[jc + jc *
z_dim1]);
z__[jc + jc * z_dim1] = 1.f;
/* L50: */
}
q[n + n * q_dim1] = 1.f;
work[n] = 0.f;
r__1 = slarnd_(&c__2, &iseed[1]);
work[n * 3] = r_sign(&c_b42, &r__1);
z__[n + n * z_dim1] = 1.f;
work[n * 2] = 0.f;
r__1 = slarnd_(&c__2, &iseed[1]);
work[n * 4] = r_sign(&c_b42, &r__1);
/* Apply the diagonal matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
n * 3 + jc] * a[jr + jc * a_dim1];
b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
n * 3 + jc] * b[jr + jc * b_dim1];
/* L60: */
}
/* L70: */
}
i__3 = n - 1;
sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &a[a_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &a[a_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
1], &b[b_offset], lda, &work[(n << 1) + 1], &
iinfo);
if (iinfo != 0) {
goto L100;
}
i__3 = n - 1;
sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
work[n + 1], &b[b_offset], lda, &work[(n << 1) +
1], &iinfo);
if (iinfo != 0) {
goto L100;
}
}
} else {
/* Random matrices */
i__3 = n;
for (jc = 1; jc <= i__3; ++jc) {
i__4 = n;
for (jr = 1; jr <= i__4; ++jr) {
a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
slarnd_(&c__2, &iseed[1]);
b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
slarnd_(&c__2, &iseed[1]);
/* L80: */
}
/* L90: */
}
}
L100:
if (iinfo != 0) {
io___42.ciunit = *nounit;
s_wsfe(&io___42);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L110:
/* Call SGEGS to compute H, T, Q, Z, alpha, and beta. */
slacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
slacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
ntest = 1;
result[1] = ulpinv;
sgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &z__[
z_offset], ldq, &work[1], lwork, &iinfo);
if (iinfo != 0) {
io___43.ciunit = *nounit;
s_wsfe(&io___43);
do_fio(&c__1, "SGEGS", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L140;
}
ntest = 4;
/* Do tests 1--4 */
sget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[1])
;
sget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[2])
;
sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
q_offset], ldq, &q[q_offset], ldq, &work[1], &result[3]);
sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
z_offset], ldq, &z__[z_offset], ldq, &work[1], &result[4])
;
/* Do test 5: compare eigenvalues with diagonals. */
/* Also check Schur form of A. */
temp1 = 0.f;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphi1[j] == 0.f) {
/* Computing MAX */
r__7 = safmin, r__8 = (r__2 = alphr1[j], dabs(r__2)),
r__7 = max(r__7,r__8), r__8 = (r__3 = s[j + j *
s_dim1], dabs(r__3));
/* Computing MAX */
r__9 = safmin, r__10 = (r__5 = beta1[j], dabs(r__5)),
r__9 = max(r__9,r__10), r__10 = (r__6 = t[j + j *
t_dim1], dabs(r__6));
temp2 = ((r__1 = alphr1[j] - s[j + j * s_dim1], dabs(r__1)
) / dmax(r__7,r__8) + (r__4 = beta1[j] - t[j + j *
t_dim1], dabs(r__4)) / dmax(r__9,r__10)) / ulp;
if (j < n) {
if (s[j + 1 + j * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
if (j > 1) {
if (s[j + (j - 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
} else {
if (alphi1[j] > 0.f) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= n) {
ilabad = TRUE_;
} else if (i1 < n - 1) {
if (s[i1 + 2 + (i1 + 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
} else if (i1 > 1) {
if (s[i1 + (i1 - 1) * s_dim1] != 0.f) {
ilabad = TRUE_;
}
}
if (! ilabad) {
sget53_(&s[i1 + i1 * s_dim1], lda, &t[i1 + i1 *
t_dim1], lda, &beta1[j], &alphr1[j], &alphi1[
j], &temp2, &iinfo);
if (iinfo >= 3) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = dmax(temp1,temp2);
if (ilabad) {
io___48.ciunit = *nounit;
s_wsfe(&io___48);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
/* L120: */
}
result[5] = temp1;
/* Call SGEGV to compute S2, T2, VL, and VR, do tests. */
/* Eigenvalues and Eigenvectors */
slacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
slacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
ntest = 6;
result[6] = ulpinv;
sgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
alphr2[1], &alphi2[1], &beta2[1], &vl[vl_offset], ldq, &
vr[vr_offset], ldq, &work[1], lwork, &iinfo);
if (iinfo != 0) {
io___49.ciunit = *nounit;
s_wsfe(&io___49);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
goto L140;
}
ntest = 7;
/* Do Tests 6 and 7 */
sget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
vl_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
1], dumma);
result[6] = dumma[0];
if (dumma[1] > *thrshn) {
io___51.ciunit = *nounit;
s_wsfe(&io___51);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
sget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
vr_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
1], dumma);
result[7] = dumma[0];
if (dumma[1] > *thresh) {
io___52.ciunit = *nounit;
s_wsfe(&io___52);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "SGEGV", (ftnlen)5);
do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
}
/* Check form of Complex eigenvalues. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphi2[j] > 0.f) {
if (j == n) {
ilabad = TRUE_;
} else if (alphi2[j + 1] >= 0.f) {
ilabad = TRUE_;
}
} else if (alphi2[j] < 0.f) {
if (j == 1) {
ilabad = TRUE_;
} else if (alphi2[j - 1] <= 0.f) {
ilabad = TRUE_;
}
}
if (ilabad) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
}
/* L130: */
}
/* End of Loop -- Check for RESULT(j) > THRESH */
L140:
ntestt += ntest;
/* Print out tests which fail. */
i__3 = ntest;
for (jr = 1; jr <= i__3; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___54.ciunit = *nounit;
s_wsfe(&io___54);
do_fio(&c__1, "SGG", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, "Orthogonal", (ftnlen)10);
e_wsfe();
/* Tests performed */
io___58.ciunit = *nounit;
s_wsfe(&io___58);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (j = 1; j <= 5; ++j) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[jr] < 1e4f) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
} else {
io___60.ciunit = *nounit;
s_wsfe(&io___60);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
}
}
/* L150: */
}
L160:
;
}
/* L170: */
}
/* Summary */
alasvm_("SGG", nounit, &nerrs, &ntestt, &c__0);
return 0;
/* End of SDRVGG */
} /* sdrvgg_ */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int psneupd_(integer *comm, logical *rvec, char *howmny,
logical *select, real *dr, real *di, real *z__, integer *ldz, real *
sigmar, real *sigmai, real *workev, char *bmat, integer *n, char *
which, integer *nev, real *tol, real *resid, integer *ncv, real *v,
integer *ldv, integer *iparam, integer *ipntr, real *workd, real *
workl, integer *lworkl, integer *info, ftnlen howmny_len, ftnlen
bmat_len, ftnlen which_len)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1;
real r__1, r__2;
doublereal d__1;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer j, k, ih, jj, np;
static real vl[1] /* was [1][1] */;
static integer ibd, ldh, ldq, iri;
static real sep;
static integer irr, wri, wrr, mode;
static real eps23;
extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *);
static integer ierr;
static real temp;
static integer iwev;
static char type__[6];
static real temp1;
extern doublereal snrm2_(integer *, real *, integer *);
static integer ihbds, iconj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real conds;
static logical reord;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *,
ftnlen);
static integer nconv, iwork[1];
static real rnorm;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer ritzi;
extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
, ftnlen, ftnlen, ftnlen, ftnlen);
static integer ritzr;
extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
*, real *, real *, integer *);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *, ftnlen, ftnlen);
static integer iheigi, iheigr, bounds, invsub, iuptri, msglvl, outncv,
ishift, numcnv;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *, ftnlen), slahqr_(logical *, logical
*, integer *, integer *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *, ftnlen), psmout_(integer *, integer *, integer *,
integer *, real *, integer *, integer *, char *, ftnlen), strevc_(
char *, char *, logical *, integer *, real *, integer *, real *,
integer *, real *, integer *, integer *, integer *, real *,
integer *, ftnlen, ftnlen), strsen_(char *, char *, logical *,
integer *, real *, integer *, real *, integer *, real *, real *,
integer *, real *, real *, real *, integer *, integer *, integer *
, integer *, ftnlen, ftnlen), psvout_(integer *, integer *,
integer *, real *, integer *, char *, ftnlen), pivout_(integer *,
integer *, integer *, integer *, integer *, char *, ftnlen);
extern doublereal pslamch_(integer *, char *, ftnlen);
extern /* Subroutine */ int psngets_(integer *, integer *, char *,
integer *, integer *, real *, real *, real *, real *, real *,
ftnlen);
/* %--------------------% */
/* | MPI Communicator | */
/* %--------------------% */
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %---------------------% */
/* | Intrinsic Functions | */
/* %---------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--workd;
--resid;
--di;
--dr;
--workev;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mneupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %---------------------------------% */
/* | Get machine dependent constant. | */
/* %---------------------------------% */
eps23 = pslamch_(comm, "Epsilon-Machine", (ftnlen)15);
d__1 = (doublereal) eps23;
eps23 = pow_dd(&d__1, &c_b3);
/* %--------------% */
/* | Quick return | */
/* %--------------% */
ierr = 0;
if (nconv <= 0) {
ierr = -14;
} else if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev + 1) {
ierr = -3;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2,
(ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0
&& s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G')
{
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + *ncv * 6) {
ierr = -7;
} else if (*(unsigned char *)howmny != 'A' && *(unsigned char *)
howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) {
ierr = -13;
} else if (*(unsigned char *)howmny == 'S') {
ierr = -12;
}
}
if (mode == 1 || mode == 2) {
s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3 && *sigmai == 0.f) {
s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
s_copy(type__, "REALPT", (ftnlen)6, (ftnlen)6);
} else if (mode == 4) {
s_copy(type__, "IMAGPT", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | */
/* | parts of ritz values | */
/* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | */
/* %--------------------------------------------------------% */
/* %-----------------------------------------------------------% */
/* | The following is used and set by PSNEUPD. | */
/* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */
/* | real part of the Ritz values. | */
/* | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | */
/* | imaginary part of the Ritz values. | */
/* | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | */
/* | error bounds of the Ritz values | */
/* | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | */
/* | quasi-triangular matrix for H | */
/* | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | */
/* | associated matrix representation of the invariant | */
/* | subspace for H. | */
/* | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | */
/* %-----------------------------------------------------------% */
ih = ipntr[5];
ritzr = ipntr[6];
ritzi = ipntr[7];
bounds = ipntr[8];
ldh = *ncv;
ldq = *ncv;
iheigr = bounds + ldh;
iheigi = iheigr + ldh;
ihbds = iheigi + ldh;
iuptri = ihbds + ldh;
invsub = iuptri + ldh * *ncv;
ipntr[9] = iheigr;
ipntr[10] = iheigi;
ipntr[11] = ihbds;
ipntr[12] = iuptri;
ipntr[13] = invsub;
wrr = 1;
wri = *ncv + 1;
iwev = wri + *ncv;
/* %-----------------------------------------% */
/* | irr points to the REAL part of the Ritz | */
/* | values computed by _neigh before | */
/* | exiting _naup2. | */
/* | iri points to the IMAGINARY part of the | */
/* | Ritz values computed by _neigh | */
/* | before exiting _naup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _neigh before exiting | */
/* | _naup2. | */
/* %-----------------------------------------% */
irr = ipntr[14] + *ncv * *ncv;
iri = irr + *ncv;
ibd = iri + *ncv;
/* %------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* %------------------------------------% */
rnorm = workl[ih + 2];
workl[ih + 2] = 0.f;
if (msglvl > 2) {
psvout_(comm, &debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit,
"_neupd: Real part of Ritz values passed in from _NAUPD.", (
ftnlen)55);
psvout_(comm, &debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit,
"_neupd: Imag part of Ritz values passed in from _NAUPD.", (
ftnlen)55);
psvout_(comm, &debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit,
"_neupd: Ritz estimates passed in from _NAUPD.", (ftnlen)45);
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
workl[bounds + j - 1] = (real) j;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(bound) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
psngets_(comm, &ishift, which, nev, &np, &workl[irr], &workl[iri], &
workl[bounds], &workl[1], &workl[np + 1], (ftnlen)2);
if (msglvl > 2) {
psvout_(comm, &debug_1.logfil, ncv, &workl[irr], &debug_1.ndigit,
"_neupd: Real part of Ritz values after calling _NGETS.",
(ftnlen)54);
psvout_(comm, &debug_1.logfil, ncv, &workl[iri], &debug_1.ndigit,
"_neupd: Imag part of Ritz values after calling _NGETS.",
(ftnlen)54);
psvout_(comm, &debug_1.logfil, ncv, &workl[bounds], &
debug_1.ndigit, "_neupd: Ritz value indices after callin"
"g _NGETS.", (ftnlen)48);
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = eps23, r__2 = slapy2_(&workl[irr + *ncv - j], &workl[iri +
*ncv - j]);
temp1 = dmax(r__1,r__2);
jj = workl[bounds + *ncv - j];
if (numcnv < nconv && workl[ibd + jj - 1] <= *tol * temp1) {
select[jj] = TRUE_;
++numcnv;
if (jj > *nev) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by dnaupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the dnaupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
pivout_(comm, &debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit,
"_neupd: Number of specified eigenvalues", (ftnlen)39);
pivout_(comm, &debug_1.logfil, &c__1, &nconv, &debug_1.ndigit,
"_neupd: Number of \"converged\" eigenvalues", (ftnlen)41)
;
}
if (numcnv != nconv) {
*info = -15;
goto L9000;
}
/* %-----------------------------------------------------------% */
/* | Call LAPACK routine slahqr to compute the real Schur form | */
/* | of the upper Hessenberg matrix returned by PSNAUPD. | */
/* | Make a copy of the upper Hessenberg matrix. | */
/* | Initialize the Schur vector matrix Q to the identity. | */
/* %-----------------------------------------------------------% */
i__1 = ldh * *ncv;
scopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1);
slaset_("All", ncv, ncv, &c_b37, &c_b38, &workl[invsub], &ldq, (
ftnlen)3);
slahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, &
workl[iheigr], &workl[iheigi], &c__1, ncv, &workl[invsub], &
ldq, &ierr);
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
psvout_(comm, &debug_1.logfil, ncv, &workl[iheigr], &
debug_1.ndigit, "_neupd: Real part of the eigenvalues of"
" H", (ftnlen)41);
psvout_(comm, &debug_1.logfil, ncv, &workl[iheigi], &
debug_1.ndigit, "_neupd: Imaginary part of the Eigenvalu"
"es of H", (ftnlen)46);
psvout_(comm, &debug_1.logfil, ncv, &workl[ihbds], &
debug_1.ndigit, "_neupd: Last row of the Schur vector ma"
"trix", (ftnlen)43);
if (msglvl > 3) {
psmout_(comm, &debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh,
&debug_1.ndigit, "_neupd: The upper quasi-triangula"
"r matrix ", (ftnlen)42);
}
}
if (reord) {
/* %-----------------------------------------------------% */
/* | Reorder the computed upper quasi-triangular matrix. | */
/* %-----------------------------------------------------% */
strsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, &
workl[invsub], &ldq, &workl[iheigr], &workl[iheigi], &
nconv, &conds, &sep, &workl[ihbds], ncv, iwork, &c__1, &
ierr, (ftnlen)4, (ftnlen)1);
if (ierr == 1) {
*info = 1;
goto L9000;
}
if (msglvl > 2) {
psvout_(comm, &debug_1.logfil, ncv, &workl[iheigr], &
debug_1.ndigit, "_neupd: Real part of the eigenvalue"
"s of H--reordered", (ftnlen)52);
psvout_(comm, &debug_1.logfil, ncv, &workl[iheigi], &
debug_1.ndigit, "_neupd: Imag part of the eigenvalue"
"s of H--reordered", (ftnlen)52);
if (msglvl > 3) {
psmout_(comm, &debug_1.logfil, ncv, ncv, &workl[iuptri], &
ldq, &debug_1.ndigit, "_neupd: Quasi-triangular "
"matrix after re-ordering", (ftnlen)49);
}
}
}
/* %---------------------------------------% */
/* | Copy the last row of the Schur vector | */
/* | into workl(ihbds). This will be used | */
/* | to compute the Ritz estimates of | */
/* | converged Ritz values. | */
/* %---------------------------------------% */
scopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
/* %----------------------------------------------------% */
/* | Place the computed eigenvalues of H into DR and DI | */
/* | if a spectral transformation was not used. | */
/* %----------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %----------------------------------------------------------% */
sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv +
1], &ierr);
/* %---------------------------------------------------------% */
/* | * Postmultiply V by Q using sorm2r. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(iheigr) and workl(iheigi) | */
/* | The first NCONV columns of V are now approximate Schur | */
/* | vectors associated with the real upper quasi-triangular | */
/* | matrix of order NCONV in workl(iuptri) | */
/* %---------------------------------------------------------% */
sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq,
&workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen)
5, (ftnlen)11);
slacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
/* %---------------------------------------------------% */
/* | Perform both a column and row scaling if the | */
/* | diagonal element of workl(invsub,ldq) is negative | */
/* | I'm lazy and don't take advantage of the upper | */
/* | quasi-triangular form of workl(iuptri,ldq) | */
/* | Note that since Q is orthogonal, R is a diagonal | */
/* | matrix consisting of plus or minus ones | */
/* %---------------------------------------------------% */
if (workl[invsub + (j - 1) * ldq + j - 1] < 0.f) {
sscal_(&nconv, &c_b64, &workl[iuptri + j - 1], &ldq);
sscal_(&nconv, &c_b64, &workl[iuptri + (j - 1) * ldq], &c__1);
}
/* L20: */
}
if (*(unsigned char *)howmny == 'A') {
/* %--------------------------------------------% */
/* | Compute the NCONV wanted eigenvectors of T | */
/* | located in workl(iuptri,ldq). | */
/* %--------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
if (j <= nconv) {
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
/* L30: */
}
strevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq,
vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1],
&ierr, (ftnlen)5, (ftnlen)6);
if (ierr != 0) {
*info = -9;
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | strevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1; | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.f) {
/* %----------------------% */
/* | real eigenvalue case | */
/* %----------------------% */
temp = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &c__1);
} else {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* | columns, we further normalize by the | */
/* | square root of two. | */
/* %-------------------------------------------% */
if (iconj == 0) {
r__1 = snrm2_(ncv, &workl[invsub + (j - 1) * ldq], &
c__1);
r__2 = snrm2_(ncv, &workl[invsub + j * ldq], &c__1);
temp = slapy2_(&r__1, &r__2);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + (j - 1) * ldq], &
c__1);
r__1 = 1.f / temp;
sscal_(ncv, &r__1, &workl[invsub + j * ldq], &c__1);
iconj = 1;
} else {
iconj = 0;
}
}
/* L40: */
}
sgemv_("T", ncv, &nconv, &c_b38, &workl[invsub], &ldq, &workl[
ihbds], &c__1, &c_b37, &workev[1], &c__1, (ftnlen)1);
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] != 0.f) {
/* %-------------------------------------------% */
/* | Complex conjugate pair case. Note that | */
/* | since the real and imaginary part of | */
/* | the eigenvector are stored in consecutive | */
/* %-------------------------------------------% */
if (iconj == 0) {
workev[j] = slapy2_(&workev[j], &workev[j + 1]);
workev[j + 1] = workev[j];
iconj = 1;
} else {
iconj = 0;
}
}
/* L45: */
}
if (msglvl > 2) {
psvout_(comm, &debug_1.logfil, ncv, &workl[ihbds], &
debug_1.ndigit, "_neupd: Last row of the eigenvector"
" matrix for T", (ftnlen)48);
if (msglvl > 3) {
psmout_(comm, &debug_1.logfil, ncv, ncv, &workl[invsub], &
ldq, &debug_1.ndigit, "_neupd: The eigenvector m"
"atrix for T", (ftnlen)36);
}
}
/* %---------------------------------------% */
/* | Copy Ritz estimates into workl(ihbds) | */
/* %---------------------------------------% */
scopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1);
/* %---------------------------------------------------------% */
/* | Compute the QR factorization of the eigenvector matrix | */
/* | associated with leading portion of T in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %---------------------------------------------------------% */
sgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*
ncv + 1], &ierr);
/* %----------------------------------------------% */
/* | * Postmultiply Z by Q. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now contains the | */
/* | Ritz vectors associated with the Ritz values | */
/* | in workl(iheigr) and workl(iheigi). | */
/* %----------------------------------------------% */
sorm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &
ldq, &workev[1], &z__[z_offset], ldz, &workd[*n + 1], &
ierr, (ftnlen)5, (ftnlen)11);
strmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, &
c_b38, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen)
5, (ftnlen)5, (ftnlen)12, (ftnlen)8);
}
} else {
/* %------------------------------------------------------% */
/* | An approximate invariant subspace is not needed. | */
/* | Place the Ritz values computed PSNAUPD into DR and DI | */
/* %------------------------------------------------------% */
scopy_(&nconv, &workl[ritzr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[ritzi], &c__1, &di[1], &c__1);
scopy_(&nconv, &workl[ritzr], &c__1, &workl[iheigr], &c__1);
scopy_(&nconv, &workl[ritzi], &c__1, &workl[iheigi], &c__1);
scopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1);
}
/* %------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors | */
/* | and corresponding error bounds of OP to those | */
/* | of A*x = lambda*B*x. | */
/* %------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
sscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
} else {
/* %---------------------------------------% */
/* | A spectral transformation was used. | */
/* | * Determine the Ritz estimates of the | */
/* | Ritz values in the original system. | */
/* %---------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
sscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[ihbds + k - 1] = (r__1 = workl[ihbds + k - 1], dabs(
r__1)) / temp / temp;
/* L50: */
}
} else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L60: */
}
} else if (s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
/* L70: */
}
}
/* %-----------------------------------------------------------% */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | For TYPE = 'REALPT' or 'IMAGPT' the user must from | */
/* | Rayleigh quotients or a projection. See remark 3 above.| */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* %-----------------------------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
temp = slapy2_(&workl[iheigr + k - 1], &workl[iheigi + k - 1])
;
workl[iheigr + k - 1] = workl[iheigr + k - 1] / temp / temp +
*sigmar;
workl[iheigi + k - 1] = -workl[iheigi + k - 1] / temp / temp
+ *sigmai;
/* L80: */
}
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
} else if (s_cmp(type__, "REALPT", (ftnlen)6, (ftnlen)6) == 0 ||
s_cmp(type__, "IMAGPT", (ftnlen)6, (ftnlen)6) == 0) {
scopy_(&nconv, &workl[iheigr], &c__1, &dr[1], &c__1);
scopy_(&nconv, &workl[iheigi], &c__1, &di[1], &c__1);
}
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0 && msglvl > 1)
{
psvout_(comm, &debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit,
"_neupd: Untransformed real part of the Ritz valuess.", (
ftnlen)52);
psvout_(comm, &debug_1.logfil, &nconv, &di[1], &debug_1.ndigit,
"_neupd: Untransformed imag part of the Ritz valuess.", (
ftnlen)52);
psvout_(comm, &debug_1.logfil, &nconv, &workl[ihbds], &
debug_1.ndigit, "_neupd: Ritz estimates of untransformed"
" Ritz values.", (ftnlen)52);
} else if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0 &&
msglvl > 1) {
psvout_(comm, &debug_1.logfil, &nconv, &dr[1], &debug_1.ndigit,
"_neupd: Real parts of converged Ritz values.", (ftnlen)
44);
psvout_(comm, &debug_1.logfil, &nconv, &di[1], &debug_1.ndigit,
"_neupd: Imag parts of converged Ritz values.", (ftnlen)
44);
psvout_(comm, &debug_1.logfil, &nconv, &workl[ihbds], &
debug_1.ndigit, "_neupd: Associated Ritz estimates.", (
ftnlen)34);
}
}
/* %-------------------------------------------------% */
/* | Eigenvector Purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 2. | */
/* %-------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", (
ftnlen)6, (ftnlen)6) == 0) {
/* %------------------------------------------------% */
/* | Purify the computed Ritz vectors by adding a | */
/* | little bit of the residual vector: | */
/* | T | */
/* | resid(:)*( e s ) / theta | */
/* | NCV | */
/* | where H s = s theta. Remember that when theta | */
/* | has nonzero imaginary part, the corresponding | */
/* | Ritz vector is stored across two columns of Z. | */
/* %------------------------------------------------% */
iconj = 0;
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
if (workl[iheigi + j - 1] == 0.f) {
workev[j] = workl[invsub + (j - 1) * ldq + *ncv - 1] / workl[
iheigr + j - 1];
} else if (iconj == 0) {
temp = slapy2_(&workl[iheigr + j - 1], &workl[iheigi + j - 1])
;
workev[j] = (workl[invsub + (j - 1) * ldq + *ncv - 1] * workl[
iheigr + j - 1] + workl[invsub + j * ldq + *ncv - 1] *
workl[iheigi + j - 1]) / temp / temp;
workev[j + 1] = (workl[invsub + j * ldq + *ncv - 1] * workl[
iheigr + j - 1] - workl[invsub + (j - 1) * ldq + *ncv
- 1] * workl[iheigi + j - 1]) / temp / temp;
iconj = 1;
} else {
iconj = 0;
}
/* L110: */
}
/* %---------------------------------------% */
/* | Perform a rank one update to Z and | */
/* | purify all the Ritz vectors together. | */
/* %---------------------------------------% */
sger_(n, &nconv, &c_b38, &resid[1], &c__1, &workev[1], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %----------------% */
/* | End of PSNEUPD | */
/* %----------------% */
} /* psneupd_ */
/* 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)
{
/* -- LAPACK 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
=======
SGGSVP computes orthogonal matrices U, V and Q such that
N-K-L K L
U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
L ( 0 0 A23 )
M-K-L ( 0 0 0 )
N-K-L K L
= K ( 0 A12 A13 ) if M-K-L < 0;
M-K ( 0 0 A23 )
N-K-L K L
V'*B*Q = L ( 0 0 B13 )
P-L ( 0 0 0 )
where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
transpose of Z.
This decomposition is the preprocessing step for computing the
Generalized Singular Value Decomposition (GSVD), see subroutine
SGGSVD.
Arguments
=========
JOBU (input) CHARACTER*1
= 'U': Orthogonal matrix U is computed;
= 'N': U is not computed.
JOBV (input) CHARACTER*1
= 'V': Orthogonal matrix V is computed;
= 'N': V is not computed.
JOBQ (input) CHARACTER*1
= 'Q': Orthogonal matrix Q is computed;
= 'N': Q is not computed.
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
P (input) INTEGER
The number of rows of the matrix B. P >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the M-by-N matrix A.
On exit, A contains the triangular (or trapezoidal) matrix
described in the Purpose section.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input/output) REAL array, dimension (LDB,N)
On entry, the P-by-N matrix B.
On exit, B contains the triangular matrix described in
the Purpose section.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,P).
TOLA (input) REAL
TOLB (input) REAL
TOLA and TOLB are the thresholds to determine the effective
numerical rank of matrix B and a subblock of A. Generally,
they are set to
TOLA = MAX(M,N)*norm(A)*MACHEPS,
TOLB = MAX(P,N)*norm(B)*MACHEPS.
The size of TOLA and TOLB may affect the size of backward
errors of the decomposition.
K (output) INTEGER
L (output) INTEGER
On exit, K and L specify the dimension of the subblocks
described in Purpose.
K + L = effective numerical rank of (A',B')'.
U (output) REAL array, dimension (LDU,M)
If JOBU = 'U', U contains the orthogonal matrix U.
If JOBU = 'N', U is not referenced.
LDU (input) INTEGER
The leading dimension of the array U. LDU >= max(1,M) if
JOBU = 'U'; LDU >= 1 otherwise.
V (output) REAL array, dimension (LDV,M)
If JOBV = 'V', V contains the orthogonal matrix V.
If JOBV = 'N', V is not referenced.
LDV (input) INTEGER
The leading dimension of the array V. LDV >= max(1,P) if
JOBV = 'V'; LDV >= 1 otherwise.
Q (output) REAL array, dimension (LDQ,N)
If JOBQ = 'Q', Q contains the orthogonal matrix Q.
If JOBQ = 'N', Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q. LDQ >= max(1,N) if
JOBQ = 'Q'; LDQ >= 1 otherwise.
IWORK (workspace) INTEGER array, dimension (N)
TAU (workspace) REAL array, dimension (N)
WORK (workspace) REAL array, dimension (max(3*N,M,P))
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
The subroutine uses LAPACK subroutine SGEQPF for the QR factorization
with column pivoting to detect the effective numerical rank of the
a matrix. It may be replaced by a better rank determination strategy.
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static real c_b12 = 0.f;
static real c_b22 = 1.f;
/* 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 */
static integer i__, j;
extern logical lsame_(char *, char *);
static 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 *);
static logical forwrd;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
#define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
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_ref(i__, i__), dabs(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_ref(2, 1), ldb, &v_ref(2, 1), 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_ref(i__, j) = 0.f;
/* L30: */
}
/* L40: */
}
if (*p > *l) {
i__1 = *p - *l;
slaset_("Full", &i__1, n, &c_b12, &c_b12, &b_ref(*l + 1, 1), 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' */
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' */
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_ref(i__, j) = 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'
( 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;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = a_ref(i__, i__), dabs(r__1)) > *tola) {
++(*k);
}
/* L80: */
}
/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
sorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &
a_ref(1, *n - *l + 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_ref(2, 1), lda, &u_ref(2, 1),
ldu);
}
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
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_ref(i__, j) = 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_ref(*k + 1, 1), 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' */
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_ref(i__, j) = 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_ref(*k + 1, *n - *l + 1), 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_ref(*k + 1, *
n - *l + 1), lda, &tau[1], &u_ref(1, *k + 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_ref(i__, j) = 0.f;
/* L130: */
}
/* L140: */
}
}
return 0;
/* End of SGGSVP */
} /* sggsvp_ */
/* Subroutine */ int sormqr_(char *side, char *trans, integer *m, integer *n,
integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc,
real *work, integer *lwork, 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
=======
SORMQR overwrites the general real M-by-N matrix C with
SIDE = 'L' SIDE = 'R'
TRANS = 'N': Q * C C * Q
TRANS = 'T': Q**T * C C * Q**T
where Q is a real orthogonal matrix defined as the product of k
elementary reflectors
Q = H(1) H(2) . . . H(k)
as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N
if SIDE = 'R'.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply Q or Q**T from the Left;
= 'R': apply Q or Q**T from the Right.
TRANS (input) CHARACTER*1
= 'N': No transpose, apply Q;
= 'T': Transpose, apply Q**T.
M (input) INTEGER
The number of rows of the matrix C. M >= 0.
N (input) INTEGER
The number of columns of the matrix C. N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines
the matrix Q.
If SIDE = 'L', M >= K >= 0;
if SIDE = 'R', N >= K >= 0.
A (input) REAL array, dimension (LDA,K)
The i-th column must contain the vector which defines the
elementary reflector H(i), for i = 1,2,...,k, as returned by
SGEQRF in the first k columns of its array argument A.
A is modified by the routine but restored on exit.
LDA (input) INTEGER
The leading dimension of the array A.
If SIDE = 'L', LDA >= max(1,M);
if SIDE = 'R', LDA >= max(1,N).
TAU (input) REAL array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by SGEQRF.
C (input/output) REAL array, dimension (LDC,N)
On entry, the M-by-N matrix C.
On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace/output) REAL array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK.
If SIDE = 'L', LWORK >= max(1,N);
if SIDE = 'R', LWORK >= max(1,M).
For optimum performance LWORK >= N*NB if SIDE = 'L', and
LWORK >= M*NB if SIDE = 'R', where NB is the optimal
blocksize.
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 */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
static integer c__65 = 65;
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static logical left;
static integer i;
static real t[4160] /* was [65][64] */;
extern logical lsame_(char *, char *);
static integer nbmin, iinfo, i1, i2, i3, ib, ic, jc, nb;
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *);
static integer mi, ni, nq, nw;
extern /* Subroutine */ int slarfb_(char *, char *, char *, char *,
integer *, integer *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
real *, integer *, real *, real *, integer *);
static logical notran;
static integer ldwork, iws;
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define C(I,J) c[(I)-1 + ((J)-1)* ( *ldc)]
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*lwork < max(1,nw)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORMQR", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
WORK(1) = 1.f;
return 0;
}
/* Determine the block size. NB may be at most NBMAX, where NBMAX
is used to define the local array T.
Computing MIN
Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
i__1 = 64, i__2 = ilaenv_(&c__1, "SORMQR", ch__1, m, n, k, &c_n1, 6L, 2L);
nb = min(i__1,i__2);
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX
Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
i__1 = 2, i__2 = ilaenv_(&c__2, "SORMQR", ch__1, m, n, k, &c_n1,
6L, 2L);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
sorm2r_(side, trans, m, n, k, &A(1,1), lda, &TAU(1), &C(1,1)
, ldc, &WORK(1), &iinfo);
} else {
/* Use blocked code */
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i = i1; i3 < 0 ? i >= i2 : i <= i2; i += i3) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector
H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = nq - i + 1;
slarft_("Forward", "Columnwise", &i__4, &ib, &A(i,i),
lda, &TAU(i), t, &c__65);
if (left) {
/* H or H' is applied to C(i:m,1:n) */
mi = *m - i + 1;
ic = i;
} else {
/* H or H' is applied to C(1:m,i:n) */
ni = *n - i + 1;
jc = i;
}
/* Apply H or H' */
slarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &A(i,i), lda, t, &c__65, &C(ic,jc), ldc,
&WORK(1), &ldwork);
/* L10: */
}
}
WORK(1) = (real) iws;
return 0;
/* End of SORMQR */
} /* sormqr_ */
/* Subroutine */ int sgeqpf_(integer *m, integer *n, real *a, integer *lda,
integer *jpvt, real *tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, ma, mn;
real aii;
integer pvt;
real temp, temp2;
extern doublereal snrm2_(integer *, real *, integer *);
real tol3z;
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *);
integer itemp;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *), sgeqr2_(integer *, integer *, real *, integer *, real
*, real *, integer *), sorm2r_(char *, char *, integer *, integer
*, integer *, real *, integer *, real *, real *, integer *, real *
, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *), slarfg_(
integer *, real *, real *, integer *, real *);
extern integer isamax_(integer *, real *, integer *);
/* -- LAPACK deprecated driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine SGEQP3. */
/* SGEQPF computes a QR factorization with column pivoting of a */
/* real M-by-N matrix A: A*P = Q*R. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0 */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of the array contains the */
/* min(M,N)-by-N upper triangular matrix R; the elements */
/* below the diagonal, together with the array TAU, */
/* represent the orthogonal matrix Q as a product of */
/* min(m,n) elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
/* to the front of A*P (a leading column); if JPVT(i) = 0, */
/* the i-th column of A is a free column. */
/* On exit, if JPVT(i) = k, then the i-th column of A*P */
/* was the k-th column of A. */
/* TAU (output) REAL array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* WORK (workspace) REAL array, dimension (3*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of elementary reflectors */
/* Q = H(1) H(2) . . . H(n) */
/* Each H(i) has the form */
/* H = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
/* The matrix P is represented in jpvt as follows: If */
/* jpvt(j) = i */
/* then the jth column of P is the ith canonical unit vector. */
/* Partial column norm updating strategy modified by */
/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
/* University of Zagreb, Croatia. */
/* June 2006. */
/* For more details see LAPACK Working Note 176. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEQPF", &i__1);
return 0;
}
mn = min(*m,*n);
tol3z = sqrt(slamch_("Epsilon"));
/* Move initial columns up front */
itemp = 1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (jpvt[i__] != 0) {
if (i__ != itemp) {
sswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
&c__1);
jpvt[i__] = jpvt[itemp];
jpvt[itemp] = i__;
} else {
jpvt[i__] = i__;
}
++itemp;
} else {
jpvt[i__] = i__;
}
/* L10: */
}
--itemp;
/* Compute the QR factorization and update remaining columns */
if (itemp > 0) {
ma = min(itemp,*m);
sgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
if (ma < *n) {
i__1 = *n - ma;
sorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, &
tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info);
}
}
if (itemp < mn) {
/* Initialize partial column norms. The first n elements of */
/* work store the exact column norms. */
i__1 = *n;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
i__2 = *m - itemp;
work[i__] = snrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
work[*n + i__] = work[i__];
/* L20: */
}
/* Compute factorization */
i__1 = mn;
for (i__ = itemp + 1; i__ <= i__1; ++i__) {
/* Determine ith pivot column and swap if necessary */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + isamax_(&i__2, &work[i__], &c__1);
if (pvt != i__) {
sswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
work[pvt] = work[i__];
work[*n + pvt] = work[*n + i__];
}
/* Generate elementary reflector H(i) */
if (i__ < *m) {
i__2 = *m - i__ + 1;
slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ *
a_dim1], &c__1, &tau[i__]);
} else {
slarfg_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], &
c__1, &tau[*m]);
}
if (i__ < *n) {
/* Apply H(i) to A(i:m,i+1:n) from the left */
aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.f;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
slarf_("LEFT", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[(*
n << 1) + 1]);
a[i__ + i__ * a_dim1] = aii;
}
/* Update partial column norms */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (work[j] != 0.f) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1)) / work[j];
/* Computing MAX */
r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp);
temp = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = work[j] / work[*n + j];
temp2 = temp * (r__1 * r__1);
if (temp2 <= tol3z) {
if (*m - i__ > 0) {
i__3 = *m - i__;
work[j] = snrm2_(&i__3, &a[i__ + 1 + j * a_dim1],
&c__1);
work[*n + j] = work[j];
} else {
work[j] = 0.f;
work[*n + j] = 0.f;
}
} else {
work[j] *= sqrt(temp);
}
}
/* L30: */
}
/* L40: */
}
}
return 0;
/* End of SGEQPF */
} /* sgeqpf_ */
/*< >*/
/* 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, ftnlen jobu_len, ftnlen jobv_len,
ftnlen jobq_len)
{
/* 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 *, ftnlen, ftnlen);
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 *, ftnlen,
ftnlen), sormr2_(char *, char *, integer *, integer *, integer *,
real *, integer *, real *, real *, integer *, real *, integer *,
ftnlen, ftnlen), xerbla_(char *, integer *, ftnlen), sgeqpf_(
integer *, integer *, real *, integer *, integer *, real *, real *
, integer *), slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *, ftnlen), slaset_(char *, integer *,
integer *, real *, real *, real *, integer *, ftnlen), slapmt_(
logical *, integer *, integer *, real *, integer *, integer *);
logical forwrd;
(void)jobu_len;
(void)jobv_len;
(void)jobq_len;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/*< CHARACTER JOBQ, JOBU, JOBV >*/
/*< INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P >*/
/*< REAL TOLA, TOLB >*/
/* .. */
/* .. Array Arguments .. */
/*< INTEGER IWORK( * ) >*/
/*< >*/
/* .. */
/* Purpose */
/* ======= */
/* SGGSVP computes orthogonal matrices U, V and Q such that */
/* N-K-L K L */
/* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */
/* L ( 0 0 A23 ) */
/* M-K-L ( 0 0 0 ) */
/* N-K-L K L */
/* = K ( 0 A12 A13 ) if M-K-L < 0; */
/* M-K ( 0 0 A23 ) */
/* N-K-L K L */
/* V'*B*Q = L ( 0 0 B13 ) */
/* P-L ( 0 0 0 ) */
/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
/* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */
/* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the */
/* transpose of Z. */
/* This decomposition is the preprocessing step for computing the */
/* Generalized Singular Value Decomposition (GSVD), see subroutine */
/* SGGSVD. */
/* Arguments */
/* ========= */
/* JOBU (input) CHARACTER*1 */
/* = 'U': Orthogonal matrix U is computed; */
/* = 'N': U is not computed. */
/* JOBV (input) CHARACTER*1 */
/* = 'V': Orthogonal matrix V is computed; */
/* = 'N': V is not computed. */
/* JOBQ (input) CHARACTER*1 */
/* = 'Q': Orthogonal matrix Q is computed; */
/* = 'N': Q is not computed. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* P (input) INTEGER */
/* The number of rows of the matrix B. P >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, A contains the triangular (or trapezoidal) matrix */
/* described in the Purpose section. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) REAL array, dimension (LDB,N) */
/* On entry, the P-by-N matrix B. */
/* On exit, B contains the triangular matrix described in */
/* the Purpose section. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,P). */
/* TOLA (input) REAL */
/* TOLB (input) REAL */
/* TOLA and TOLB are the thresholds to determine the effective */
/* numerical rank of matrix B and a subblock of A. Generally, */
/* they are set to */
/* TOLA = MAX(M,N)*norm(A)*MACHEPS, */
/* TOLB = MAX(P,N)*norm(B)*MACHEPS. */
/* The size of TOLA and TOLB may affect the size of backward */
/* errors of the decomposition. */
/* K (output) INTEGER */
/* L (output) INTEGER */
/* On exit, K and L specify the dimension of the subblocks */
/* described in Purpose. */
/* K + L = effective numerical rank of (A',B')'. */
/* U (output) REAL array, dimension (LDU,M) */
/* If JOBU = 'U', U contains the orthogonal matrix U. */
/* If JOBU = 'N', U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M) if */
/* JOBU = 'U'; LDU >= 1 otherwise. */
/* V (output) REAL array, dimension (LDV,M) */
/* If JOBV = 'V', V contains the orthogonal matrix V. */
/* If JOBV = 'N', V is not referenced. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. LDV >= max(1,P) if */
/* JOBV = 'V'; LDV >= 1 otherwise. */
/* Q (output) REAL array, dimension (LDQ,N) */
/* If JOBQ = 'Q', Q contains the orthogonal matrix Q. */
/* If JOBQ = 'N', Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N) if */
/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* TAU (workspace) REAL array, dimension (N) */
/* WORK (workspace) REAL array, dimension (max(3*N,M,P)) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The subroutine uses LAPACK subroutine SGEQPF for the QR factorization */
/* with column pivoting to detect the effective numerical rank of the */
/* a matrix. It may be replaced by a better rank determination strategy. */
/* ===================================================================== */
/* .. Parameters .. */
/*< REAL ZERO, ONE >*/
/*< PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< LOGICAL FORWRD, WANTQ, WANTU, WANTV >*/
/*< INTEGER I, J >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< EXTERNAL LSAME >*/
/* .. */
/* .. External Subroutines .. */
/*< >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, MAX, MIN >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/*< WANTU = LSAME( JOBU, 'U' ) >*/
/* 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", (ftnlen)1, (ftnlen)1);
/*< WANTV = LSAME( JOBV, 'V' ) >*/
wantv = lsame_(jobv, "V", (ftnlen)1, (ftnlen)1);
/*< WANTQ = LSAME( JOBQ, 'Q' ) >*/
wantq = lsame_(jobq, "Q", (ftnlen)1, (ftnlen)1);
/*< FORWRD = .TRUE. >*/
forwrd = TRUE_;
/*< INFO = 0 >*/
*info = 0;
/*< IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN >*/
if (! (wantu || lsame_(jobu, "N", (ftnlen)1, (ftnlen)1))) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN >*/
} else if (! (wantv || lsame_(jobv, "N", (ftnlen)1, (ftnlen)1))) {
/*< INFO = -2 >*/
*info = -2;
/*< ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN >*/
} else if (! (wantq || lsame_(jobq, "N", (ftnlen)1, (ftnlen)1))) {
/*< INFO = -3 >*/
*info = -3;
/*< ELSE IF( M.LT.0 ) THEN >*/
} else if (*m < 0) {
/*< INFO = -4 >*/
*info = -4;
/*< ELSE IF( P.LT.0 ) THEN >*/
} else if (*p < 0) {
/*< INFO = -5 >*/
*info = -5;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -6 >*/
*info = -6;
/*< ELSE IF( LDA.LT.MAX( 1, M ) ) THEN >*/
} else if (*lda < max(1,*m)) {
/*< INFO = -8 >*/
*info = -8;
/*< ELSE IF( LDB.LT.MAX( 1, P ) ) THEN >*/
} else if (*ldb < max(1,*p)) {
/*< INFO = -10 >*/
*info = -10;
/*< ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN >*/
} else if (*ldu < 1 || (wantu && *ldu < *m)) {
/*< INFO = -16 >*/
*info = -16;
/*< ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN >*/
} else if (*ldv < 1 || (wantv && *ldv < *p)) {
/*< INFO = -18 >*/
*info = -18;
/*< ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN >*/
} else if (*ldq < 1 || (wantq && *ldq < *n)) {
/*< INFO = -20 >*/
*info = -20;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'SGGSVP', -INFO ) >*/
i__1 = -(*info);
xerbla_("SGGSVP", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* QR with column pivoting of B: B*P = V*( S11 S12 ) */
/* ( 0 0 ) */
/*< DO 10 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< IWORK( I ) = 0 >*/
iwork[i__] = 0;
/*< 10 CONTINUE >*/
/* L10: */
}
/*< CALL SGEQPF( P, N, B, LDB, IWORK, TAU, WORK, INFO ) >*/
sgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info);
/* Update A := A*P */
/*< CALL SLAPMT( FORWRD, M, N, A, LDA, IWORK ) >*/
slapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
/* Determine the effective rank of matrix B. */
/*< L = 0 >*/
*l = 0;
/*< DO 20 I = 1, MIN( P, N ) >*/
i__1 = min(*p,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
/*< >*/
if ((r__1 = b[i__ + i__ * b_dim1], dabs(r__1)) > *tolb) {
++(*l);
}
/*< 20 CONTINUE >*/
/* L20: */
}
/*< IF( WANTV ) THEN >*/
if (wantv) {
/* Copy the details of V, and form V. */
/*< CALL SLASET( 'Full', P, P, ZERO, ZERO, V, LDV ) >*/
slaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv, (ftnlen)4);
/*< >*/
if (*p > 1) {
i__1 = *p - 1;
slacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2],
ldv, (ftnlen)5);
}
/*< CALL SORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO ) >*/
i__1 = min(*p,*n);
sorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
/*< END IF >*/
}
/* Clean up B */
/*< DO 40 J = 1, L - 1 >*/
i__1 = *l - 1;
for (j = 1; j <= i__1; ++j) {
/*< DO 30 I = J + 1, L >*/
i__2 = *l;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/*< B( I, J ) = ZERO >*/
b[i__ + j * b_dim1] = (float)0.;
/*< 30 CONTINUE >*/
/* L30: */
}
/*< 40 CONTINUE >*/
/* L40: */
}
/*< >*/
if (*p > *l) {
i__1 = *p - *l;
slaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb, (
ftnlen)4);
}
/*< IF( WANTQ ) THEN >*/
if (wantq) {
/* Set Q = I and Update Q := Q*P */
/*< CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) >*/
slaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq, (ftnlen)4);
/*< CALL SLAPMT( FORWRD, N, N, Q, LDQ, IWORK ) >*/
slapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
/*< END IF >*/
}
/*< IF( P.GE.L .AND. N.NE.L ) THEN >*/
if (*p >= *l && *n != *l) {
/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */
/*< CALL SGERQ2( L, N, B, LDB, TAU, WORK, INFO ) >*/
sgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
/* Update A := A*Z' */
/*< >*/
sormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[
a_offset], lda, &work[1], info, (ftnlen)5, (ftnlen)9);
/*< IF( WANTQ ) THEN >*/
if (wantq) {
/* Update Q := Q*Z' */
/*< >*/
sormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1],
&q[q_offset], ldq, &work[1], info, (ftnlen)5, (ftnlen)9);
/*< END IF >*/
}
/* Clean up B */
/*< CALL SLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB ) >*/
i__1 = *n - *l;
slaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb, (ftnlen)
4);
/*< DO 60 J = N - L + 1, N >*/
i__1 = *n;
for (j = *n - *l + 1; j <= i__1; ++j) {
/*< DO 50 I = J - N + L + 1, L >*/
i__2 = *l;
for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) {
/*< B( I, J ) = ZERO >*/
b[i__ + j * b_dim1] = (float)0.;
/*< 50 CONTINUE >*/
/* L50: */
}
/*< 60 CONTINUE >*/
/* L60: */
}
/*< END IF >*/
}
/* Let N-L L */
/* A = ( A11 A12 ) M, */
/* then the following does the complete QR decomposition of A11: */
/* A11 = U*( 0 T12 )*P1' */
/* ( 0 0 ) */
/*< DO 70 I = 1, N - L >*/
i__1 = *n - *l;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< IWORK( I ) = 0 >*/
iwork[i__] = 0;
/*< 70 CONTINUE >*/
/* L70: */
}
/*< CALL SGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, INFO ) >*/
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 >*/
*k = 0;
/*< DO 80 I = 1, MIN( M, N-L ) >*/
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
/*< >*/
if ((r__1 = a[i__ + i__ * a_dim1], dabs(r__1)) > *tola) {
++(*k);
}
/*< 80 CONTINUE >*/
/* L80: */
}
/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) */
/*< >*/
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
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, (ftnlen)4, (
ftnlen)9);
/*< IF( WANTU ) THEN >*/
if (wantu) {
/* Copy the details of U, and form U */
/*< CALL SLASET( 'Full', M, M, ZERO, ZERO, U, LDU ) >*/
slaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu, (ftnlen)4);
/*< >*/
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, (ftnlen)5);
}
/*< CALL SORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO ) >*/
/* Computing MIN */
i__2 = *m, i__3 = *n - *l;
i__1 = min(i__2,i__3);
sorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
/*< END IF >*/
}
/*< IF( WANTQ ) THEN >*/
if (wantq) {
/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
/*< CALL SLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK ) >*/
i__1 = *n - *l;
slapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
/*< END IF >*/
}
/* 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. */
/*< DO 100 J = 1, K - 1 >*/
i__1 = *k - 1;
for (j = 1; j <= i__1; ++j) {
/*< DO 90 I = J + 1, K >*/
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
/*< A( I, J ) = ZERO >*/
a[i__ + j * a_dim1] = (float)0.;
/*< 90 CONTINUE >*/
/* L90: */
}
/*< 100 CONTINUE >*/
/* 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, (ftnlen)4);
}
/*< IF( N-L.GT.K ) THEN >*/
if (*n - *l > *k) {
/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
/*< CALL SGERQ2( K, N-L, A, LDA, TAU, WORK, INFO ) >*/
i__1 = *n - *l;
sgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
/*< IF( WANTQ ) THEN >*/
if (wantq) {
/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */
/*< >*/
i__1 = *n - *l;
sormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, &
tau[1], &q[q_offset], ldq, &work[1], info, (ftnlen)5, (
ftnlen)9);
/*< END IF >*/
}
/* Clean up A */
/*< CALL SLASET( 'Full', K, N-L-K, ZERO, ZERO, A, LDA ) >*/
i__1 = *n - *l - *k;
slaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda, (ftnlen)
4);
/*< DO 120 J = N - L - K + 1, N - L >*/
i__1 = *n - *l;
for (j = *n - *l - *k + 1; j <= i__1; ++j) {
/*< DO 110 I = J - N + L + K + 1, K >*/
i__2 = *k;
for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) {
/*< A( I, J ) = ZERO >*/
a[i__ + j * a_dim1] = (float)0.;
/*< 110 CONTINUE >*/
/* L110: */
}
/*< 120 CONTINUE >*/
/* L120: */
}
/*< END IF >*/
}
/*< IF( M.GT.K ) THEN >*/
if (*m > *k) {
/* QR factorization of A( K+1:M,N-L+1:N ) */
/*< CALL SGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO ) >*/
i__1 = *m - *k;
sgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], &
work[1], info);
/*< IF( WANTU ) THEN >*/
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, (ftnlen)5, (ftnlen)12);
/*< END IF >*/
}
/* Clean up */
/*< DO 140 J = N - L + 1, N >*/
i__1 = *n;
for (j = *n - *l + 1; j <= i__1; ++j) {
/*< DO 130 I = J - N + K + L + 1, M >*/
i__2 = *m;
for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) {
/*< A( I, J ) = ZERO >*/
a[i__ + j * a_dim1] = (float)0.;
/*< 130 CONTINUE >*/
/* L130: */
}
/*< 140 CONTINUE >*/
/* L140: */
}
/*< END IF >*/
}
/*< RETURN >*/
return 0;
/* End of SGGSVP */
/*< END >*/
} /* sggsvp_ */
/* Subroutine */ int sgelsx_(integer *m, integer *n, integer *nrhs, real *a,
integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond,
integer *rank, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1;
/* Local variables */
static integer i__, j, k;
static real c1, c2, s1, s2, t1, t2;
static integer mn;
static real anrm, bnrm, smin, smax;
static integer iascl, ibscl, ismin, ismax;
extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
, ftnlen, ftnlen, ftnlen, ftnlen), slaic1_(integer *, integer *,
real *, real *, real *, real *, real *, real *, real *), sorm2r_(
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, real *, integer *, real *, integer *, ftnlen, ftnlen),
slabad_(real *, real *);
extern doublereal slamch_(char *, ftnlen), slange_(char *, integer *,
integer *, real *, integer *, real *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
ftnlen), sgeqpf_(integer *, integer *, real *, integer *, integer
*, real *, real *, integer *), slaset_(char *, integer *, integer
*, real *, real *, real *, integer *, ftnlen);
static real sminpr, smaxpr, smlnum;
extern /* Subroutine */ int slatzm_(char *, integer *, integer *, real *,
integer *, real *, real *, real *, integer *, real *, ftnlen),
stzrqf_(integer *, integer *, real *, integer *, real *, integer *
);
/* -- LAPACK driver routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine SGELSY. */
/* SGELSX computes the minimum-norm solution to a real linear least */
/* squares problem: */
/* minimize || A * X - B || */
/* using a complete orthogonal factorization of A. A is an M-by-N */
/* matrix which may be rank-deficient. */
/* Several right hand side vectors b and solution vectors x can be */
/* handled in a single call; they are stored as the columns of the */
/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
/* matrix X. */
/* The routine first computes a QR factorization with column pivoting: */
/* A * P = Q * [ R11 R12 ] */
/* [ 0 R22 ] */
/* with R11 defined as the largest leading submatrix whose estimated */
/* condition number is less than 1/RCOND. The order of R11, RANK, */
/* is the effective rank of A. */
/* Then, R22 is considered to be negligible, and R12 is annihilated */
/* by orthogonal transformations from the right, arriving at the */
/* complete orthogonal factorization: */
/* A * P = Q * [ T11 0 ] * Z */
/* [ 0 0 ] */
/* The minimum-norm solution is then */
/* X = P * Z' [ inv(T11)*Q1'*B ] */
/* [ 0 ] */
/* where Q1 consists of the first RANK columns of Q. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of */
/* columns of matrices B and X. NRHS >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, A has been overwritten by details of its */
/* complete orthogonal factorization. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) REAL array, dimension (LDB,NRHS) */
/* On entry, the M-by-NRHS right hand side matrix B. */
/* On exit, the N-by-NRHS solution matrix X. */
/* If m >= n and RANK = n, the residual sum-of-squares for */
/* the solution in the i-th column is given by the sum of */
/* squares of elements N+1:M in that column. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,M,N). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(i) .ne. 0, the i-th column of A is an */
/* initial column, otherwise it is a free column. Before */
/* the QR factorization of A, all initial columns are */
/* permuted to the leading positions; only the remaining */
/* free columns are moved as a result of column pivoting */
/* during the factorization. */
/* On exit, if JPVT(i) = k, then the i-th column of A*P */
/* was the k-th column of A. */
/* RCOND (input) REAL */
/* RCOND is used to determine the effective rank of A, which */
/* is defined as the order of the largest leading triangular */
/* submatrix R11 in the QR factorization with pivoting of A, */
/* whose estimated condition number < 1/RCOND. */
/* RANK (output) INTEGER */
/* The effective rank of A, i.e., the order of the submatrix */
/* R11. This is the same as the order of the submatrix T11 */
/* in the complete orthogonal factorization of A. */
/* WORK (workspace) REAL array, dimension */
/* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )), */
/* 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 .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--jpvt;
--work;
/* Function Body */
mn = min(*m,*n);
ismin = mn + 1;
ismax = (mn << 1) + 1;
/* Test the input arguments. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*ldb < max(i__1,*n)) {
*info = -7;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGELSX", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
/* Computing MIN */
i__1 = min(*m,*n);
if (min(i__1,*nrhs) == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters */
smlnum = slamch_("S", (ftnlen)1) / slamch_("P", (ftnlen)1);
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale A, B if max elements outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", m, n, &a[a_offset], lda, &work[1], (ftnlen)1);
iascl = 0;
if (anrm > 0.f && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info, (ftnlen)1);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info, (ftnlen)1);
iascl = 2;
} else if (anrm == 0.f) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
slaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb, (ftnlen)
1);
*rank = 0;
goto L100;
}
bnrm = slange_("M", m, nrhs, &b[b_offset], ldb, &work[1], (ftnlen)1);
ibscl = 0;
if (bnrm > 0.f && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
slascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
slascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
ibscl = 2;
}
/* Compute QR factorization with column pivoting of A: */
/* A * P = Q * R */
sgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info);
/* workspace 3*N. Details of Householder rotations stored */
/* in WORK(1:MN). */
/* Determine RANK using incremental condition estimation */
work[ismin] = 1.f;
work[ismax] = 1.f;
smax = (r__1 = a[a_dim1 + 1], dabs(r__1));
smin = smax;
if ((r__1 = a[a_dim1 + 1], dabs(r__1)) == 0.f) {
*rank = 0;
i__1 = max(*m,*n);
slaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb, (ftnlen)
1);
goto L100;
} else {
*rank = 1;
}
L10:
if (*rank < mn) {
i__ = *rank + 1;
slaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
i__ + i__ * a_dim1], &sminpr, &s1, &c1);
slaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
if (smaxpr * *rcond <= sminpr) {
i__1 = *rank;
for (i__ = 1; i__ <= i__1; ++i__) {
work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1];
work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1];
/* L20: */
}
work[ismin + *rank] = c1;
work[ismax + *rank] = c2;
smin = sminpr;
smax = smaxpr;
++(*rank);
goto L10;
}
}
/* Logically partition R = [ R11 R12 ] */
/* [ 0 R22 ] */
/* where R11 = R(1:RANK,1:RANK) */
/* [R11,R12] = [ T11, 0 ] * Y */
if (*rank < *n) {
stzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
}
/* Details of Householder rotations stored in WORK(MN+1:2*MN) */
/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
sorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], &
b[b_offset], ldb, &work[(mn << 1) + 1], info, (ftnlen)4, (ftnlen)
9);
/* workspace NRHS */
/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
strsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, &
a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (
ftnlen)12, (ftnlen)8);
i__1 = *n;
for (i__ = *rank + 1; i__ <= i__1; ++i__) {
i__2 = *nrhs;
for (j = 1; j <= i__2; ++j) {
b[i__ + j * b_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
if (*rank < *n) {
i__1 = *rank;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - *rank + 1;
slatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda,
&work[mn + i__], &b[i__ + b_dim1], &b[*rank + 1 + b_dim1],
ldb, &work[(mn << 1) + 1], (ftnlen)4);
/* L50: */
}
}
/* workspace NRHS */
/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[(mn << 1) + i__] = 1.f;
/* L60: */
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[(mn << 1) + i__] == 1.f) {
if (jpvt[i__] != i__) {
k = i__;
t1 = b[k + j * b_dim1];
t2 = b[jpvt[k] + j * b_dim1];
L70:
b[jpvt[k] + j * b_dim1] = t1;
work[(mn << 1) + k] = 0.f;
t1 = t2;
k = jpvt[k];
t2 = b[jpvt[k] + j * b_dim1];
if (jpvt[k] != i__) {
goto L70;
}
b[i__ + j * b_dim1] = t1;
work[(mn << 1) + k] = 0.f;
}
}
/* L80: */
}
/* L90: */
}
/* Undo scaling */
if (iascl == 1) {
slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
slascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
lda, info, (ftnlen)1);
} else if (iascl == 2) {
slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
slascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
lda, info, (ftnlen)1);
}
if (ibscl == 1) {
slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
} else if (ibscl == 2) {
slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info, (ftnlen)1);
}
L100:
return 0;
/* End of SGELSX */
} /* sgelsx_ */
doublereal sqrt11_(integer *m, integer *k, real *a, integer *lda, real *tau,
real *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real ret_val;
/* Local variables */
integer j, info;
real rdummy[1];
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SQRT11 computes the test ratio */
/* || Q'*Q - I || / (eps * m) */
/* where the orthogonal matrix Q is represented as a product of */
/* elementary transformations. Each transformation has the form */
/* H(k) = I - tau(k) v(k) v(k)' */
/* where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form */
/* [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored */
/* in A(k+1:m,k). */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* K (input) INTEGER */
/* The number of columns of A whose subdiagonal entries */
/* contain information about orthogonal transformations. */
/* A (input) REAL array, dimension (LDA,K) */
/* The (possibly partial) output of a QR reduction routine. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* TAU (input) REAL array, dimension (K) */
/* The scaling factors tau for the elementary transformations as */
/* computed by the QR factorization routine. */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= M*M + M. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
ret_val = 0.f;
/* Test for sufficient workspace */
if (*lwork < *m * *m + *m) {
this_xerbla_("SQRT11", &c__7);
return ret_val;
}
/* Quick return if possible */
if (*m <= 0) {
return ret_val;
}
slaset_("Full", m, m, &c_b5, &c_b6, &work[1], m);
/* Form Q */
sorm2r_("Left", "No transpose", m, m, k, &a[a_offset], lda, &tau[1], &
work[1], m, &work[*m * *m + 1], &info);
/* Form Q'*Q */
sorm2r_("Left", "Transpose", m, m, k, &a[a_offset], lda, &tau[1], &work[1]
, m, &work[*m * *m + 1], &info);
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
work[(j - 1) * *m + j] += -1.f;
/* L10: */
}
ret_val = slange_("One-norm", m, m, &work[1], m, rdummy) / ((
real) (*m) * slamch_("Epsilon"));
return ret_val;
/* End of SQRT11 */
} /* sqrt11_ */
/* 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 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 sormqr_(char *side, char *trans, integer *m, integer *n,
integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
real *work, integer *lwork, integer *info)
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__;
real t[4160] /* was [65][64] */;
integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
logical left;
extern logical lsame_(char *, char *);
integer nbmin, iinfo;
extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *, real *,
integer *), slarfb_(char *, char *, char *, char *
, integer *, integer *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
real *, integer *, real *, real *, integer *);
logical notran;
integer ldwork, lwkopt;
logical lquery;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SORMQR overwrites the general real M-by-N matrix C with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': Q * C C * Q */
/* TRANS = 'T': Q**T * C C * Q**T */
/* where Q is a real orthogonal matrix defined as the product of k */
/* elementary reflectors */
/* Q = H(1) H(2) . . . H(k) */
/* as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N */
/* if SIDE = 'R'. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q or Q**T from the Left; */
/* = 'R': apply Q or Q**T from the Right. */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, apply Q; */
/* = 'T': Transpose, apply Q**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines */
/* the matrix Q. */
/* If SIDE = 'L', M >= K >= 0; */
/* if SIDE = 'R', N >= K >= 0. */
/* A (input) REAL array, dimension (LDA,K) */
/* The i-th column must contain the vector which defines the */
/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* SGEQRF in the first k columns of its array argument A. */
/* A is modified by the routine but restored on exit. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If SIDE = 'L', LDA >= max(1,M); */
/* if SIDE = 'R', LDA >= max(1,N). */
/* TAU (input) REAL array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by SGEQRF. */
/* C (input/output) REAL array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* 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. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* LWORK >= M*NB if SIDE = 'R', 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 .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. 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;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
lquery = *lwork == -1;
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*lwork < max(1,nw) && ! lquery) {
*info = -12;
}
if (*info == 0) {
/* Determine the block size. NB may be at most NBMAX, where NBMAX */
/* is used to define the local array T. */
/* Computing MIN */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 64, i__2 = ilaenv_(&c__1, "SORMQR", ch__1, m, n, k, &c_n1);
nb = min(i__1,i__2);
lwkopt = max(1,nw) * nb;
work[1] = (real) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORMQR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
work[1] = 1.f;
return 0;
}
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
i__1 = 2, i__2 = ilaenv_(&c__2, "SORMQR", ch__1, m, n, k, &c_n1);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
sorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo);
} else {
/* Use blocked code */
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = nq - i__ + 1;
slarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], t, &c__65)
;
if (left) {
/* H or H' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H or H' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H or H' */
slarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc *
c_dim1], ldc, &work[1], &ldwork);
/* L10: */
}
}
work[1] = (real) lwkopt;
return 0;
/* End of SORMQR */
} /* sormqr_ */
