/* Subroutine */ int sorg2l_(int *m, int *n, int *k, real *a,
int *lda, real *tau, real *work, int *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SORG2L generates an m by n real matrix Q with orthonormal columns,
which is defined as the last n columns of a product of k elementary
reflectors of order m
Q = H(k) . . . H(2) H(1)
as returned by SGEQLF.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q. M >= N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. N >= K >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the (n-k+i)-th column must contain the vector which
defines the elementary reflector H(i), for i = 1,2,...,k, as
returned by SGEQLF in the last k columns of its array
argument A.
On exit, the m by n matrix Q.
LDA (input) INTEGER
The first dimension of the array A. LDA >= max(1,M).
TAU (input) REAL array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by SGEQLF.
WORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument has an illegal value
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static int c__1 = 1;
/* System generated locals */
/* Unused variables commented out by MDG on 03-09-05
int a_dim1, a_offset;
*/
int i__1, i__2, i__3;
real r__1;
/* Local variables */
static int i, j, l;
extern /* Subroutine */ int sscal_(int *, real *, real *, int *),
slarf_(char *, int *, int *, real *, int *, real *,
real *, int *, real *);
static int ii;
extern /* Subroutine */ int xerbla_(char *, int *);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0 || *n > *m) {
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORG2L", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns 1:n-k to columns of the unit matrix */
i__1 = *n - *k;
for (j = 1; j <= *n-*k; ++j) {
i__2 = *m;
for (l = 1; l <= *m; ++l) {
A(l,j) = 0.f;
/* L10: */
}
A(*m-*n+j,j) = 1.f;
/* L20: */
}
i__1 = *k;
for (i = 1; i <= *k; ++i) {
ii = *n - *k + i;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
A(*m-*n+ii,ii) = 1.f;
i__2 = *m - *n + ii;
i__3 = ii - 1;
slarf_("Left", &i__2, &i__3, &A(1,ii), &c__1, &TAU(i), &A(1,1), lda, &WORK(1));
i__2 = *m - *n + ii - 1;
r__1 = -(doublereal)TAU(i);
sscal_(&i__2, &r__1, &A(1,ii), &c__1);
A(*m-*n+ii,ii) = 1.f - TAU(i);
/* Set A(m-k+i+1:m,n-k+i) to zero */
i__2 = *m;
for (l = *m - *n + ii + 1; l <= *m; ++l) {
A(l,ii) = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of SORG2L */
} /* sorg2l_ */
/* Subroutine */ int slaqr2_(logical *wantt, logical *wantz, integer *n,
integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh,
integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns,
integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh,
real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real *
work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
wv_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;
/* Local variables */
integer i__, j, k;
real s, aa, bb, cc, dd, cs, sn;
integer jw;
real evi, evk, foo;
integer kln;
real tau, ulp;
integer lwk1, lwk2;
real beta;
integer kend, kcol, info, ifst, ilst, ltop, krow;
logical bulge;
integer infqr;
integer kwtop;
real safmin;
real safmax;
logical sorted;
real smlnum;
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.2.1) -- */
/* -- April 2009 -- */
/* This subroutine is identical to SLAQR3 except that it avoids */
/* recursion by calling SLAHQR instead of SLAQR4. */
/* ****************************************************************** */
/* Aggressive early deflation: */
/* This subroutine accepts as input an upper Hessenberg matrix */
/* H and performs an orthogonal similarity transformation */
/* designed to detect and deflate fully converged eigenvalues from */
/* a trailing principal submatrix. On output H has been over- */
/* written by a new Hessenberg matrix that is a perturbation of */
/* an orthogonal similarity transformation of H. It is to be */
/* hoped that the final version of H has many zero subdiagonal */
/* entries. */
/* ****************************************************************** */
/* WANTT (input) LOGICAL */
/* If .TRUE., then the Hessenberg matrix H is fully updated */
/* so that the quasi-triangular Schur factor may be */
/* computed (in cooperation with the calling subroutine). */
/* If .FALSE., then only enough of H is updated to preserve */
/* the eigenvalues. */
/* WANTZ (input) LOGICAL */
/* If .TRUE., then the orthogonal matrix Z is updated so */
/* so that the orthogonal Schur factor may be computed */
/* (in cooperation with the calling subroutine). */
/* If .FALSE., then Z is not referenced. */
/* N (input) INTEGER */
/* The order of the matrix H and (if WANTZ is .TRUE.) the */
/* order of the orthogonal matrix Z. */
/* KTOP (input) INTEGER */
/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
/* KBOT and KTOP together determine an isolated block */
/* along the diagonal of the Hessenberg matrix. */
/* KBOT (input) INTEGER */
/* It is assumed without a check that either */
/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
/* determine an isolated block along the diagonal of the */
/* Hessenberg matrix. */
/* NW (input) INTEGER */
/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On input the initial N-by-N section of H stores the */
/* Hessenberg matrix undergoing aggressive early deflation. */
/* On output H has been transformed by an orthogonal */
/* similarity transformation, perturbed, and the returned */
/* to Hessenberg form that (it is to be hoped) has some */
/* zero subdiagonal entries. */
/* LDH (input) integer */
/* Leading dimension of H just as declared in the calling */
/* subroutine. N .LE. LDH */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* IF WANTZ is .TRUE., then on output, the orthogonal */
/* similarity transformation mentioned above has been */
/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
/* If WANTZ is .FALSE., then Z is unreferenced. */
/* LDZ (input) integer */
/* The leading dimension of Z just as declared in the */
/* calling subroutine. 1 .LE. LDZ. */
/* NS (output) integer */
/* The number of unconverged (ie approximate) eigenvalues */
/* returned in SR and SI that may be used as shifts by the */
/* calling subroutine. */
/* ND (output) integer */
/* The number of converged eigenvalues uncovered by this */
/* subroutine. */
/* SR (output) REAL array, dimension KBOT */
/* SI (output) REAL array, dimension KBOT */
/* On output, the real and imaginary parts of approximate */
/* eigenvalues that may be used for shifts are stored in */
/* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */
/* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */
/* The real and imaginary parts of converged eigenvalues */
/* are stored in SR(KBOT-ND+1) through SR(KBOT) and */
/* SI(KBOT-ND+1) through SI(KBOT), respectively. */
/* V (workspace) REAL array, dimension (LDV,NW) */
/* An NW-by-NW work array. */
/* LDV (input) integer scalar */
/* The leading dimension of V just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* NH (input) integer scalar */
/* The number of columns of T. NH.GE.NW. */
/* T (workspace) REAL array, dimension (LDT,NW) */
/* LDT (input) integer */
/* The leading dimension of T just as declared in the */
/* calling subroutine. NW .LE. LDT */
/* NV (input) integer */
/* The number of rows of work array WV available for */
/* workspace. NV.GE.NW. */
/* WV (workspace) REAL array, dimension (LDWV,NW) */
/* LDWV (input) integer */
/* The leading dimension of W just as declared in the */
/* calling subroutine. NW .LE. LDV */
/* WORK (workspace) REAL array, dimension LWORK. */
/* On exit, WORK(1) is set to an estimate of the optimal value */
/* of LWORK for the given values of N, NW, KTOP and KBOT. */
/* LWORK (input) integer */
/* The dimension of the work array WORK. LWORK = 2*NW */
/* suffices, but greater efficiency may result from larger */
/* values of LWORK. */
/* If LWORK = -1, then a workspace query is assumed; SLAQR2 */
/* only estimates the optimal workspace size for the given */
/* values of N, NW, KTOP and KBOT. The estimate is returned */
/* in WORK(1). No error message related to LWORK is issued */
/* by XERBLA. Neither H nor Z are accessed. */
/* ================================================================ */
/* Based on contributions by */
/* Karen Braman and Ralph Byers, Department of Mathematics, */
/* University of Kansas, USA */
/* ================================================================ */
/* ==== Estimate optimal workspace. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sr;
--si;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
if (jw <= 2) {
lwkopt = 1;
} else {
/* ==== Workspace query call to SGEHRD ==== */
i__1 = jw - 1;
sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
c_n1, &info);
lwk1 = (integer) work[1];
/* ==== Workspace query call to SORMHR ==== */
i__1 = jw - 1;
sormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1];
/* ==== Optimal workspace ==== */
lwkopt = jw + max(lwk1,lwk2);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1) {
work[1] = (real) lwkopt;
return 0;
}
*ns = 0;
*nd = 0;
work[1] = 1.f;
if (*ktop > *kbot) {
return 0;
}
if (*nw < 1) {
return 0;
}
/* ==== Machine constants ==== */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) (*n) / ulp);
/* ==== Setup deflation window ==== */
/* Computing MIN */
i__1 = *nw, i__2 = *kbot - *ktop + 1;
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop) {
s = 0.f;
} else {
s = h__[kwtop + (kwtop - 1) * h_dim1];
}
if (*kbot == kwtop) {
/* ==== 1-by-1 deflation window: not much to do ==== */
sr[kwtop] = h__[kwtop + kwtop * h_dim1];
si[kwtop] = 0.f;
*ns = 1;
*nd = 0;
/* Computing MAX */
r__2 = smlnum, r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], dabs(
r__1));
if (dabs(s) <= dmax(r__2,r__3)) {
*ns = 0;
*nd = 1;
if (kwtop > *ktop) {
h__[kwtop + (kwtop - 1) * h_dim1] = 0.f;
}
}
work[1] = 1.f;
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a */
/* . rare QR failure, this routine continues to do */
/* . aggressive early deflation using that part of */
/* . the deflation window that converged using INFQR */
/* . here and there to keep track.) ==== */
slacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
i__3);
slaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv);
slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop],
&si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
/* ==== STREXC needs a clean margin near the diagonal ==== */
i__1 = jw - 3;
for (j = 1; j <= i__1; ++j) {
t[j + 2 + j * t_dim1] = 0.f;
t[j + 3 + j * t_dim1] = 0.f;
}
if (jw > 2) {
t[jw + (jw - 2) * t_dim1] = 0.f;
}
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
L20:
if (ilst <= *ns) {
if (*ns == 1) {
bulge = FALSE_;
} else {
bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f;
}
/* ==== Small spike tip test for deflation ==== */
if (! bulge) {
/* ==== Real eigenvalue ==== */
foo = (r__1 = t[*ns + *ns * t_dim1], dabs(r__1));
if (foo == 0.f) {
foo = dabs(s);
}
/* Computing MAX */
r__2 = smlnum, r__3 = ulp * foo;
if ((r__1 = s * v[*ns * v_dim1 + 1], dabs(r__1)) <= dmax(r__2,
r__3)) {
/* ==== Deflatable ==== */
--(*ns);
} else {
/* ==== Undeflatable. Move it up out of the way. */
/* . (STREXC can not fail in this case.) ==== */
ifst = *ns;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &work[1], &info);
++ilst;
}
} else {
/* ==== Complex conjugate pair ==== */
foo = (r__3 = t[*ns + *ns * t_dim1], dabs(r__3)) + sqrt((r__1 = t[
*ns + (*ns - 1) * t_dim1], dabs(r__1))) * sqrt((r__2 = t[*
ns - 1 + *ns * t_dim1], dabs(r__2)));
if (foo == 0.f) {
foo = dabs(s);
}
/* Computing MAX */
r__3 = (r__1 = s * v[*ns * v_dim1 + 1], dabs(r__1)), r__4 = (r__2
= s * v[(*ns - 1) * v_dim1 + 1], dabs(r__2));
/* Computing MAX */
r__5 = smlnum, r__6 = ulp * foo;
if (dmax(r__3,r__4) <= dmax(r__5,r__6)) {
/* ==== Deflatable ==== */
*ns += -2;
} else {
/* ==== Undeflatable. Move them up out of the way. */
/* . Fortunately, STREXC does the right thing with */
/* . ILST in case of a rare exchange failure. ==== */
ifst = *ns;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &work[1], &info);
ilst += 2;
}
}
/* ==== End deflation detection loop ==== */
goto L20;
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0) {
s = 0.f;
}
if (*ns < jw) {
/* ==== sorting diagonal blocks of T improves accuracy for */
/* . graded matrices. Bubble sort deals well with */
/* . exchange failures. ==== */
sorted = FALSE_;
i__ = *ns + 1;
L30:
if (sorted) {
goto L50;
}
sorted = TRUE_;
kend = i__ - 1;
i__ = infqr + 1;
if (i__ == *ns) {
k = i__ + 1;
} else if (t[i__ + 1 + i__ * t_dim1] == 0.f) {
k = i__ + 1;
} else {
k = i__ + 2;
}
L40:
if (k <= kend) {
if (k == i__ + 1) {
evi = (r__1 = t[i__ + i__ * t_dim1], dabs(r__1));
} else {
evi = (r__3 = t[i__ + i__ * t_dim1], dabs(r__3)) + sqrt((r__1
= t[i__ + 1 + i__ * t_dim1], dabs(r__1))) * sqrt((
r__2 = t[i__ + (i__ + 1) * t_dim1], dabs(r__2)));
}
if (k == kend) {
evk = (r__1 = t[k + k * t_dim1], dabs(r__1));
} else if (t[k + 1 + k * t_dim1] == 0.f) {
evk = (r__1 = t[k + k * t_dim1], dabs(r__1));
} else {
evk = (r__3 = t[k + k * t_dim1], dabs(r__3)) + sqrt((r__1 = t[
k + 1 + k * t_dim1], dabs(r__1))) * sqrt((r__2 = t[k
+ (k + 1) * t_dim1], dabs(r__2)));
}
if (evi >= evk) {
i__ = k;
} else {
sorted = FALSE_;
ifst = i__;
ilst = k;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
&ilst, &work[1], &info);
if (info == 0) {
i__ = ilst;
} else {
i__ = k;
}
}
if (i__ == kend) {
k = i__ + 1;
} else if (t[i__ + 1 + i__ * t_dim1] == 0.f) {
k = i__ + 1;
} else {
k = i__ + 2;
}
goto L40;
}
goto L30;
L50:
;
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__ = jw;
L60:
if (i__ >= infqr + 1) {
if (i__ == infqr + 1) {
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.f;
--i__;
} else if (t[i__ + (i__ - 1) * t_dim1] == 0.f) {
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.f;
--i__;
} else {
aa = t[i__ - 1 + (i__ - 1) * t_dim1];
cc = t[i__ + (i__ - 1) * t_dim1];
bb = t[i__ - 1 + i__ * t_dim1];
dd = t[i__ + i__ * t_dim1];
slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__
- 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, &
sn);
i__ += -2;
}
goto L60;
}
if (*ns < jw || s == 0.f) {
if (*ns > 1 && s != 0.f) {
/* ==== Reflect spike back into lower triangle ==== */
scopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
beta = work[1];
slarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1] = 1.f;
i__1 = jw - 2;
i__2 = jw - 2;
slaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt);
slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, &
work[jw + 1]);
slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
work[jw + 1]);
slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
work[jw + 1]);
i__1 = *lwork - jw;
sgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
, &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1) {
h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
}
slacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
, ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
scopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
&i__3);
/* ==== Accumulate orthogonal matrix in order update */
/* . H and Z, if requested. ==== */
if (*ns > 1 && s != 0.f) {
i__1 = *lwork - jw;
sormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
&v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt) {
ltop = 1;
} else {
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = kwtop - krow;
kln = min(i__3,i__4);
sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop *
h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset],
ldwv);
slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
h_dim1], ldh);
}
/* ==== Update horizontal slab in H ==== */
if (*wantt) {
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1) {
/* Computing MIN */
i__3 = *nh, i__4 = *n - kcol + 1;
kln = min(i__3,i__4);
sgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, &
h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset],
ldt);
slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
h_dim1], ldh);
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz) {
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
i__2) {
/* Computing MIN */
i__3 = *nv, i__4 = *ihiz - krow + 1;
kln = min(i__3,i__4);
sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop *
z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[
wv_offset], ldwv);
slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
kwtop * z_dim1], ldz);
}
}
}
*nd = jw - *ns;
/* . INFQR from the spike length takes care */
/* . of the case of a rare QR failure while */
/* . calculating eigenvalues of the deflation */
/* . window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
work[1] = (real) lwkopt;
/* ==== End of SLAQR2 ==== */
return 0;
} /* slaqr2_ */
/* Subroutine */ int sorm2l_(char *side, char *trans, integer *m, integer *n,
integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
integer i__, i1, i2, i3, mi, ni, nq;
real aii;
logical left;
logical notran;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SORM2L overwrites the general real m by n matrix C with */
/* Q * C if SIDE = 'L' and TRANS = 'N', or */
/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
/* C * Q if SIDE = 'R' and TRANS = 'N', or */
/* C * Q' if SIDE = 'R' and TRANS = 'T', */
/* where Q is a real orthogonal matrix defined as the product of k */
/* elementary reflectors */
/* Q = H(k) . . . H(2) H(1) */
/* as returned by SGEQLF. 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' from the Left */
/* = 'R': apply Q or Q' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply Q (No transpose) */
/* = 'T': apply Q' (Transpose) */
/* 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 */
/* SGEQLF in the last 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 SGEQLF. */
/* 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'*C or C*Q' or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) REAL array, dimension */
/* (N) if SIDE = 'L', */
/* (M) if SIDE = 'R' */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* 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");
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
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;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORM2L", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && notran || ! left && ! notran) {
i1 = 1;
i2 = *k;
i3 = 1;
} else {
i1 = *k;
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
} else {
mi = *m;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) is applied to C(1:m-k+i,1:n) */
mi = *m - *k + i__;
} else {
/* H(i) is applied to C(1:m,1:n-k+i) */
ni = *n - *k + i__;
}
/* Apply H(i) */
aii = a[nq - *k + i__ + i__ * a_dim1];
a[nq - *k + i__ + i__ * a_dim1] = 1.f;
slarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[
c_offset], ldc, &work[1]);
a[nq - *k + i__ + i__ * a_dim1] = aii;
}
return 0;
/* End of SORM2L */
} /* sorm2l_ */
/* Subroutine */ int sorml2_(char *side, char *trans, integer *m, integer *n,
integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc,
real *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SORML2 overwrites the general real m by n matrix C with
Q * C if SIDE = 'L' and TRANS = 'N', or
Q'* C if SIDE = 'L' and TRANS = 'T', or
C * Q if SIDE = 'R' and TRANS = 'N', or
C * Q' if SIDE = 'R' and TRANS = 'T',
where Q is a real orthogonal matrix defined as the product of k
elementary reflectors
Q = H(k) . . . H(2) H(1)
as returned by SGELQF. 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' from the Left
= 'R': apply Q or Q' from the Right
TRANS (input) CHARACTER*1
= 'N': apply Q (No transpose)
= 'T': apply Q' (Transpose)
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,M) if SIDE = 'L',
(LDA,N) if SIDE = 'R'
The i-th row must contain the vector which defines the
elementary reflector H(i), for i = 1,2,...,k, as returned by
SGELQF in the first k rows 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. LDA >= max(1,K).
TAU (input) REAL array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by SGELQF.
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'*C or C*Q' or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace) REAL array, dimension
(N) if SIDE = 'L',
(M) if SIDE = 'R'
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
static logical left;
static integer i;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *);
static integer i1, i2, i3, ic, jc, mi, ni, nq;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static real aii;
#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 */
if (left) {
nq = *m;
} else {
nq = *n;
}
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,*k)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORML2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && notran || ! left && ! notran) {
i1 = 1;
i2 = *k;
i3 = 1;
} else {
i1 = *k;
i2 = 1;
i3 = -1;
}
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) {
if (left) {
/* H(i) is applied to C(i:m,1:n) */
mi = *m - i + 1;
ic = i;
} else {
/* H(i) is applied to C(1:m,i:n) */
ni = *n - i + 1;
jc = i;
}
/* Apply H(i) */
aii = A(i,i);
A(i,i) = 1.f;
slarf_(side, &mi, &ni, &A(i,i), lda, &TAU(i), &C(ic,jc), ldc, &WORK(1));
A(i,i) = aii;
/* L10: */
}
return 0;
/* End of SORML2 */
} /* sorml2_ */
/* Subroutine */
int sgehd2_(integer *n, integer *ilo, integer *ihi, real *a, integer *lda, real *tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
real aii;
extern /* Subroutine */
int slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *), xerbla_( char *, integer *), slarfg_(integer *, real *, real *, integer *, real *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*n < 0)
{
*info = -1;
}
else if (*ilo < 1 || *ilo > max(1,*n))
{
*info = -2;
}
else if (*ihi < min(*ilo,*n) || *ihi > *n)
{
*info = -3;
}
else if (*lda < max(1,*n))
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SGEHD2", &i__1);
return 0;
}
i__1 = *ihi - 1;
for (i__ = *ilo;
i__ <= i__1;
++i__)
{
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
i__2 = *ihi - i__;
/* Computing MIN */
i__3 = i__ + 2;
slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__]);
aii = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.f;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i__;
slarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i__;
i__3 = *n - i__;
slarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
a[i__ + 1 + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of SGEHD2 */
}
/* Subroutine */ int sgehd2_(integer *n, integer *ilo, integer *ihi, real *a,
integer *lda, 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
October 31, 1992
Purpose
=======
SGEHD2 reduces a real general matrix A to upper Hessenberg form H by
an orthogonal similarity transformation: Q' * A * Q = H .
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
It is assumed that A is already upper triangular in rows
and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
set by a previous call to SGEBAL; otherwise they should be
set to 1 and N respectively. See Further Details.
1 <= ILO <= IHI <= max(1,N).
A (input/output) REAL array, dimension (LDA,N)
On entry, the n by n general matrix to be reduced.
On exit, the upper triangle and the first subdiagonal of A
are overwritten with the upper Hessenberg matrix H, and the
elements below the first subdiagonal, with the array TAU,
represent the orthogonal matrix Q as a product of elementary
reflectors. See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
TAU (output) REAL array, dimension (N-1)
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace) REAL array, dimension (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 (ihi-ilo) elementary
reflectors
Q = H(ilo) H(ilo+1) . . . H(ihi-1).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
exit in A(i+2:ihi,i), and tau in TAU(i).
The contents of A are illustrated by the following example, with
n = 7, ilo = 2 and ihi = 6:
on entry, on exit,
( a a a a a a a ) ( a a h h h h a )
( a a a a a a ) ( a h h h h a )
( a a a a a a ) ( h h h h h h )
( a a a a a a ) ( v2 h h h h h )
( a a a a a a ) ( v2 v3 h h h h )
( a a a a a a ) ( v2 v3 v4 h h h )
( a ) ( a )
where a denotes an element of the original matrix A, h denotes a
modified element of the upper Hessenberg matrix H, and vi denotes an
element of the vector defining H(i).
=====================================================================
Test the input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__;
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *), xerbla_(
char *, integer *), slarfg_(integer *, real *, real *,
integer *, real *);
static real aii;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -2;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEHD2", &i__1);
return 0;
}
i__1 = *ihi - 1;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
Computing MIN */
i__2 = i__ + 2;
i__3 = *ihi - i__;
slarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*n), i__), &c__1,
&tau[i__]);
aii = a_ref(i__ + 1, i__);
a_ref(i__ + 1, i__) = 1.f;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i__;
slarf_("Right", ihi, &i__2, &a_ref(i__ + 1, i__), &c__1, &tau[i__], &
a_ref(1, i__ + 1), lda, &work[1]);
/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i__;
i__3 = *n - i__;
slarf_("Left", &i__2, &i__3, &a_ref(i__ + 1, i__), &c__1, &tau[i__], &
a_ref(i__ + 1, i__ + 1), lda, &work[1]);
a_ref(i__ + 1, i__) = aii;
/* L10: */
}
return 0;
/* End of SGEHD2 */
} /* sgehd2_ */
int slaqp2_(int *m, int *n, int *offset, float *a,
int *lda, int *jpvt, float *tau, float *vn1, float *vn2, float *
work)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3;
float r__1, r__2;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j, mn;
float aii;
int pvt;
float temp, temp2;
extern double snrm2_(int *, float *, int *);
float tol3z;
int offpi;
extern int slarf_(char *, int *, int *, float *,
int *, float *, float *, int *, float *);
int itemp;
extern int sswap_(int *, float *, int *, float *,
int *);
extern double slamch_(char *);
extern int isamax_(int *, float *, int *);
extern int slarfp_(int *, float *, float *, int *,
float *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAQP2 computes a QR factorization with column pivoting of */
/* the block A(OFFSET+1:M,1:N). */
/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* 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. */
/* OFFSET (input) INTEGER */
/* The number of rows of the matrix A that must be pivoted */
/* but no factorized. OFFSET >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */
/* the triangular factor obtained; the elements in block */
/* A(OFFSET+1:M,1:N) below the diagonal, together with the */
/* array TAU, represent the orthogonal matrix Q as a product of */
/* elementary reflectors. Block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* 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. */
/* VN1 (input/output) REAL array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) REAL array, dimension (N) */
/* The vector with the exact column norms. */
/* WORK (workspace) REAL array, dimension (N) */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* 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 .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *m - *offset;
mn = MIN(i__1,*n);
tol3z = sqrt(slamch_("Epsilon"));
/* Compute factorization. */
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
offpi = *offset + i__;
/* Determine ith pivot column and swap if necessary. */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + isamax_(&i__2, &vn1[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;
vn1[pvt] = vn1[i__];
vn2[pvt] = vn2[i__];
}
/* Generate elementary reflector H(i). */
if (offpi < *m) {
i__2 = *m - offpi + 1;
slarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ *
a_dim1], &c__1, &tau[i__]);
} else {
slarfp_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], &
c__1, &tau[i__]);
}
if (i__ < *n) {
/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
aii = a[offpi + i__ * a_dim1];
a[offpi + i__ * a_dim1] = 1.f;
i__2 = *m - offpi + 1;
i__3 = *n - i__;
slarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, &
tau[i__], &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]);
a[offpi + i__ * a_dim1] = aii;
}
/* Update partial column norms. */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (vn1[j] != 0.f) {
/* NOTE: The following 4 lines follow from the analysis in */
/* Lapack Working Note 176. */
/* Computing 2nd power */
r__2 = (r__1 = a[offpi + j * a_dim1], ABS(r__1)) / vn1[j];
temp = 1.f - r__2 * r__2;
temp = MAX(temp,0.f);
/* Computing 2nd power */
r__1 = vn1[j] / vn2[j];
temp2 = temp * (r__1 * r__1);
if (temp2 <= tol3z) {
if (offpi < *m) {
i__3 = *m - offpi;
vn1[j] = snrm2_(&i__3, &a[offpi + 1 + j * a_dim1], &
c__1);
vn2[j] = vn1[j];
} else {
vn1[j] = 0.f;
vn2[j] = 0.f;
}
} else {
vn1[j] *= sqrt(temp);
}
}
/* L10: */
}
/* L20: */
}
return 0;
/* End of SLAQP2 */
} /* slaqp2_ */
/* Subroutine */ int slaqp2_(integer *m, integer *n, integer *offset, real *a,
integer *lda, integer *jpvt, real *tau, real *vn1, real *vn2, real *
work)
{
/* 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 */
static integer i__, j, mn;
static real aii;
static integer pvt;
static real temp, temp2;
extern doublereal snrm2_(integer *, real *, integer *);
static integer offpi;
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, ftnlen);
static integer itemp;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *), slarfg_(integer *, real *, real *, integer *, real *);
extern integer isamax_(integer *, real *, integer *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAQP2 computes a QR factorization with column pivoting of */
/* the block A(OFFSET+1:M,1:N). */
/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* 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. */
/* OFFSET (input) INTEGER */
/* The number of rows of the matrix A that must be pivoted */
/* but no factorized. OFFSET >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */
/* the triangular factor obtained; the elements in block */
/* A(OFFSET+1:M,1:N) below the diagonal, together with the */
/* array TAU, represent the orthogonal matrix Q as a product of */
/* elementary reflectors. Block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* 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. */
/* VN1 (input/output) REAL array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) REAL array, dimension (N) */
/* The vector with the exact column norms. */
/* WORK (workspace) REAL array, dimension (N) */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *m - *offset;
mn = min(i__1,*n);
/* Compute factorization. */
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
offpi = *offset + i__;
/* Determine ith pivot column and swap if necessary. */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + isamax_(&i__2, &vn1[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;
vn1[pvt] = vn1[i__];
vn2[pvt] = vn2[i__];
}
/* Generate elementary reflector H(i). */
if (offpi < *m) {
i__2 = *m - offpi + 1;
slarfg_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ *
a_dim1], &c__1, &tau[i__]);
} else {
slarfg_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], &
c__1, &tau[i__]);
}
if (i__ < *n) {
/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
aii = a[offpi + i__ * a_dim1];
a[offpi + i__ * a_dim1] = 1.f;
i__2 = *m - offpi + 1;
i__3 = *n - i__;
slarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, &
tau[i__], &a[offpi + (i__ + 1) * a_dim1], lda, &work[1], (
ftnlen)4);
a[offpi + i__ * a_dim1] = aii;
}
/* Update partial column norms. */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (vn1[j] != 0.f) {
/* Computing 2nd power */
r__2 = (r__1 = a[offpi + j * a_dim1], dabs(r__1)) / vn1[j];
temp = 1.f - r__2 * r__2;
temp = dmax(temp,0.f);
/* Computing 2nd power */
r__1 = vn1[j] / vn2[j];
temp2 = temp * .05f * (r__1 * r__1) + 1.f;
if (temp2 == 1.f) {
if (offpi < *m) {
i__3 = *m - offpi;
vn1[j] = snrm2_(&i__3, &a[offpi + 1 + j * a_dim1], &
c__1);
vn2[j] = vn1[j];
} else {
vn1[j] = 0.f;
vn2[j] = 0.f;
}
} else {
vn1[j] *= sqrt(temp);
}
}
/* L10: */
}
/* L20: */
}
return 0;
/* End of SLAQP2 */
} /* slaqp2_ */
/* Subroutine */ int sorgr2_(integer *m, integer *n, integer *k, real *a,
integer *lda, 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
February 29, 1992
Purpose
=======
SORGR2 generates an m by n real matrix Q with orthonormal rows,
which is defined as the last m rows of a product of k elementary
reflectors of order n
Q = H(1) H(2) . . . H(k)
as returned by SGERQF.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q. N >= M.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. M >= K >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the (m-k+i)-th row must contain the vector which
defines the elementary reflector H(i), for i = 1,2,...,k, as
returned by SGERQF in the last k rows of its array argument
A.
On exit, the m by n matrix Q.
LDA (input) INTEGER
The first dimension of the array A. LDA >= max(1,M).
TAU (input) REAL array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by SGERQF.
WORK (workspace) REAL array, dimension (M)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument has an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
static integer i__, j, l;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *);
static integer ii;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORGR2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows 1:m-k to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m - *k;
for (l = 1; l <= i__2; ++l) {
a_ref(l, j) = 0.f;
/* L10: */
}
if (j > *n - *m && j <= *n - *k) {
a_ref(*m - *n + j, j) = 1.f;
}
/* L20: */
}
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
ii = *m - *k + i__;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right */
a_ref(ii, *n - *m + ii) = 1.f;
i__2 = ii - 1;
i__3 = *n - *m + ii;
slarf_("Right", &i__2, &i__3, &a_ref(ii, 1), lda, &tau[i__], &a[
a_offset], lda, &work[1]);
i__2 = *n - *m + ii - 1;
r__1 = -tau[i__];
sscal_(&i__2, &r__1, &a_ref(ii, 1), lda);
a_ref(ii, *n - *m + ii) = 1.f - tau[i__];
/* Set A(m-k+i,n-k+i+1:n) to zero */
i__2 = *n;
for (l = *n - *m + ii + 1; l <= i__2; ++l) {
a_ref(ii, l) = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of SORGR2 */
} /* sorgr2_ */
/* Subroutine */
int sorg2r_fla(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1;
/* Local variables */
integer i__, j, l;
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *), slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *), xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0 || *n > *m)
{
*info = -2;
}
else if (*k < 0 || *k > *n)
{
*info = -3;
}
else if (*lda < max(1,*m))
{
*info = -5;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SORG2R", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0)
{
return 0;
}
/* Initialise columns k+1:n to columns of the unit matrix */
i__1 = *n;
for (j = *k + 1;
j <= i__1;
++j)
{
i__2 = *m;
for (l = 1;
l <= i__2;
++l)
{
a[l + j * a_dim1] = 0.f;
/* L10: */
}
a[j + j * a_dim1] = 1.f;
/* L20: */
}
for (i__ = *k;
i__ >= 1;
--i__)
{
/* Apply H(i) to A(i:m,i:n) from the left */
if (i__ < *n)
{
a[i__ + i__ * a_dim1] = 1.f;
i__1 = *m - i__ + 1;
i__2 = *n - i__;
slarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
}
if (i__ < *m)
{
i__1 = *m - i__;
r__1 = -tau[i__];
sscal_(&i__1, &r__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
}
a[i__ + i__ * a_dim1] = 1.f - tau[i__];
/* Set A(1:i-1,i) to zero */
i__1 = i__ - 1;
for (l = 1;
l <= i__1;
++l)
{
a[l + i__ * a_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of SORG2R */
}
/* Subroutine */ int snapps_(integer *n, integer *kev, integer *np, real *
shiftr, real *shifti, real *v, integer *ldv, real *h__, integer *ldh,
real *resid, real *q, integer *ldq, real *workl, real *workd)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer h_dim1, h_offset, v_dim1, v_offset, q_dim1, q_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
/* Local variables */
static real c__, f, g;
static integer i__, j;
static real r__, s, t, u[3], t0, t1, h11, h12, h21, h22, h32;
static integer jj, ir, nr;
static real tau, ulp, tst1;
static integer iend;
static real unfl, ovfl;
static logical cconj;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *, ftnlen), sgemv_(char *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *, ftnlen), scopy_(integer *, real *, integer *,
real *, integer *), saxpy_(integer *, real *, real *, integer *,
real *, integer *), ivout_(integer *, integer *, integer *,
integer *, char *, ftnlen), smout_(integer *, integer *, integer *
, real *, integer *, integer *, char *, ftnlen), svout_(integer *,
integer *, real *, integer *, char *, ftnlen);
extern doublereal slapy2_(real *, real *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *, ftnlen);
static real sigmai;
extern /* Subroutine */ int second_(real *);
static real sigmar;
static integer istart, kplusp, msglvl;
static real smlnum;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *, ftnlen), slarfg_(integer *, real *,
real *, integer *, real *), slaset_(char *, integer *, integer *,
real *, real *, real *, integer *, ftnlen), slartg_(real *, real *
, real *, real *, real *);
extern doublereal slanhs_(char *, integer *, real *, integer *, real *,
ftnlen);
/* %----------------------------------------------------% */
/* | 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 & Arrays | */
/* %------------------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %----------------------% */
/* | Intrinsics Functions | */
/* %----------------------% */
/* %----------------% */
/* | Data statments | */
/* %----------------% */
/* Parameter adjustments */
--workd;
--resid;
--workl;
--shifti;
--shiftr;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
/* Function Body */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
if (first) {
/* %-----------------------------------------------% */
/* | Set machine-dependent constants for the | */
/* | stopping criterion. If norm(H) <= sqrt(OVFL), | */
/* | overflow should not occur. | */
/* | REFERENCE: LAPACK subroutine slahqr | */
/* %-----------------------------------------------% */
unfl = slamch_("safe minimum", (ftnlen)12);
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("precision", (ftnlen)9);
smlnum = unfl * (*n / ulp);
first = FALSE_;
}
/* %-------------------------------% */
/* | Initialize timing statistics | */
/* | & message level for debugging | */
/* %-------------------------------% */
second_(&t0);
msglvl = debug_1.mnapps;
kplusp = *kev + *np;
/* %--------------------------------------------% */
/* | Initialize Q to the identity to accumulate | */
/* | the rotations and reflections | */
/* %--------------------------------------------% */
slaset_("All", &kplusp, &kplusp, &c_b5, &c_b6, &q[q_offset], ldq, (ftnlen)
3);
/* %----------------------------------------------% */
/* | Quick return if there are no shifts to apply | */
/* %----------------------------------------------% */
if (*np == 0) {
goto L9000;
}
/* %----------------------------------------------% */
/* | Chase the bulge with the application of each | */
/* | implicit shift. Each shift is applied to the | */
/* | whole matrix including each block. | */
/* %----------------------------------------------% */
cconj = FALSE_;
i__1 = *np;
for (jj = 1; jj <= i__1; ++jj) {
sigmar = shiftr[jj];
sigmai = shifti[jj];
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit, "_napps: sh"
"ift number.", (ftnlen)21);
svout_(&debug_1.logfil, &c__1, &sigmar, &debug_1.ndigit, "_napps"
": The real part of the shift ", (ftnlen)35);
svout_(&debug_1.logfil, &c__1, &sigmai, &debug_1.ndigit, "_napps"
": The imaginary part of the shift ", (ftnlen)40);
}
/* %-------------------------------------------------% */
/* | The following set of conditionals is necessary | */
/* | in order that complex conjugate pairs of shifts | */
/* | are applied together or not at all. | */
/* %-------------------------------------------------% */
if (cconj) {
/* %-----------------------------------------% */
/* | cconj = .true. means the previous shift | */
/* | had non-zero imaginary part. | */
/* %-----------------------------------------% */
cconj = FALSE_;
goto L110;
} else if (jj < *np && dabs(sigmai) > 0.f) {
/* %------------------------------------% */
/* | Start of a complex conjugate pair. | */
/* %------------------------------------% */
cconj = TRUE_;
} else if (jj == *np && dabs(sigmai) > 0.f) {
/* %----------------------------------------------% */
/* | The last shift has a nonzero imaginary part. | */
/* | Don't apply it; thus the order of the | */
/* | compressed H is order KEV+1 since only np-1 | */
/* | were applied. | */
/* %----------------------------------------------% */
++(*kev);
goto L110;
}
istart = 1;
L20:
/* %--------------------------------------------------% */
/* | if sigmai = 0 then | */
/* | Apply the jj-th shift ... | */
/* | else | */
/* | Apply the jj-th and (jj+1)-th together ... | */
/* | (Note that jj < np at this point in the code) | */
/* | end | */
/* | to the current block of H. The next do loop | */
/* | determines the current block ; | */
/* %--------------------------------------------------% */
i__2 = kplusp - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* %----------------------------------------% */
/* | Check for splitting and deflation. Use | */
/* | a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine slahqr | */
/* %----------------------------------------% */
tst1 = (r__1 = h__[i__ + i__ * h_dim1], dabs(r__1)) + (r__2 = h__[
i__ + 1 + (i__ + 1) * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
i__3 = kplusp - jj + 1;
tst1 = slanhs_("1", &i__3, &h__[h_offset], ldh, &workl[1], (
ftnlen)1);
}
/* Computing MAX */
r__2 = ulp * tst1;
if ((r__1 = h__[i__ + 1 + i__ * h_dim1], dabs(r__1)) <= dmax(r__2,
smlnum)) {
if (msglvl > 0) {
ivout_(&debug_1.logfil, &c__1, &i__, &debug_1.ndigit,
"_napps: matrix splitting at row/column no.", (
ftnlen)42);
ivout_(&debug_1.logfil, &c__1, &jj, &debug_1.ndigit,
"_napps: matrix splitting with shift number.", (
ftnlen)43);
svout_(&debug_1.logfil, &c__1, &h__[i__ + 1 + i__ *
h_dim1], &debug_1.ndigit, "_napps: off diagonal "
"element.", (ftnlen)29);
}
iend = i__;
h__[i__ + 1 + i__ * h_dim1] = 0.f;
goto L40;
}
/* L30: */
}
iend = kplusp;
L40:
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &istart, &debug_1.ndigit, "_napps"
": Start of current block ", (ftnlen)31);
ivout_(&debug_1.logfil, &c__1, &iend, &debug_1.ndigit, "_napps: "
"End of current block ", (ftnlen)29);
}
/* %------------------------------------------------% */
/* | No reason to apply a shift to block of order 1 | */
/* %------------------------------------------------% */
if (istart == iend) {
goto L100;
}
/* %------------------------------------------------------% */
/* | If istart + 1 = iend then no reason to apply a | */
/* | complex conjugate pair of shifts on a 2 by 2 matrix. | */
/* %------------------------------------------------------% */
if (istart + 1 == iend && dabs(sigmai) > 0.f) {
goto L100;
}
h11 = h__[istart + istart * h_dim1];
h21 = h__[istart + 1 + istart * h_dim1];
if (dabs(sigmai) <= 0.f) {
/* %---------------------------------------------% */
/* | Real-valued shift ==> apply single shift QR | */
/* %---------------------------------------------% */
f = h11 - sigmar;
g = h21;
i__2 = iend - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* %-----------------------------------------------------% */
/* | Contruct the plane rotation G to zero out the bulge | */
/* %-----------------------------------------------------% */
slartg_(&f, &g, &c__, &s, &r__);
if (i__ > istart) {
/* %-------------------------------------------% */
/* | The following ensures that h(1:iend-1,1), | */
/* | the first iend-2 off diagonal of elements | */
/* | H, remain non negative. | */
/* %-------------------------------------------% */
if (r__ < 0.f) {
r__ = -r__;
c__ = -c__;
s = -s;
}
h__[i__ + (i__ - 1) * h_dim1] = r__;
h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.f;
}
/* %---------------------------------------------% */
/* | Apply rotation to the left of H; H <- G'*H | */
/* %---------------------------------------------% */
i__3 = kplusp;
for (j = i__; j <= i__3; ++j) {
t = c__ * h__[i__ + j * h_dim1] + s * h__[i__ + 1 + j *
h_dim1];
h__[i__ + 1 + j * h_dim1] = -s * h__[i__ + j * h_dim1] +
c__ * h__[i__ + 1 + j * h_dim1];
h__[i__ + j * h_dim1] = t;
/* L50: */
}
/* %---------------------------------------------% */
/* | Apply rotation to the right of H; H <- H*G | */
/* %---------------------------------------------% */
/* Computing MIN */
i__4 = i__ + 2;
i__3 = min(i__4,iend);
for (j = 1; j <= i__3; ++j) {
t = c__ * h__[j + i__ * h_dim1] + s * h__[j + (i__ + 1) *
h_dim1];
h__[j + (i__ + 1) * h_dim1] = -s * h__[j + i__ * h_dim1]
+ c__ * h__[j + (i__ + 1) * h_dim1];
h__[j + i__ * h_dim1] = t;
/* L60: */
}
/* %----------------------------------------------------% */
/* | Accumulate the rotation in the matrix Q; Q <- Q*G | */
/* %----------------------------------------------------% */
/* Computing MIN */
i__4 = i__ + jj;
i__3 = min(i__4,kplusp);
for (j = 1; j <= i__3; ++j) {
t = c__ * q[j + i__ * q_dim1] + s * q[j + (i__ + 1) *
q_dim1];
q[j + (i__ + 1) * q_dim1] = -s * q[j + i__ * q_dim1] +
c__ * q[j + (i__ + 1) * q_dim1];
q[j + i__ * q_dim1] = t;
/* L70: */
}
/* %---------------------------% */
/* | Prepare for next rotation | */
/* %---------------------------% */
if (i__ < iend - 1) {
f = h__[i__ + 1 + i__ * h_dim1];
g = h__[i__ + 2 + i__ * h_dim1];
}
/* L80: */
}
/* %-----------------------------------% */
/* | Finished applying the real shift. | */
/* %-----------------------------------% */
} else {
/* %----------------------------------------------------% */
/* | Complex conjugate shifts ==> apply double shift QR | */
/* %----------------------------------------------------% */
h12 = h__[istart + (istart + 1) * h_dim1];
h22 = h__[istart + 1 + (istart + 1) * h_dim1];
h32 = h__[istart + 2 + (istart + 1) * h_dim1];
/* %---------------------------------------------------------% */
/* | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | */
/* %---------------------------------------------------------% */
s = sigmar * 2.f;
t = slapy2_(&sigmar, &sigmai);
u[0] = (h11 * (h11 - s) + t * t) / h21 + h12;
u[1] = h11 + h22 - s;
u[2] = h32;
i__2 = iend - 1;
for (i__ = istart; i__ <= i__2; ++i__) {
/* Computing MIN */
i__3 = 3, i__4 = iend - i__ + 1;
nr = min(i__3,i__4);
/* %-----------------------------------------------------% */
/* | Construct Householder reflector G to zero out u(1). | */
/* | G is of the form I - tau*( 1 u )' * ( 1 u' ). | */
/* %-----------------------------------------------------% */
slarfg_(&nr, u, &u[1], &c__1, &tau);
if (i__ > istart) {
h__[i__ + (i__ - 1) * h_dim1] = u[0];
h__[i__ + 1 + (i__ - 1) * h_dim1] = 0.f;
if (i__ < iend - 1) {
h__[i__ + 2 + (i__ - 1) * h_dim1] = 0.f;
}
}
u[0] = 1.f;
/* %--------------------------------------% */
/* | Apply the reflector to the left of H | */
/* %--------------------------------------% */
i__3 = kplusp - i__ + 1;
slarf_("Left", &nr, &i__3, u, &c__1, &tau, &h__[i__ + i__ *
h_dim1], ldh, &workl[1], (ftnlen)4);
/* %---------------------------------------% */
/* | Apply the reflector to the right of H | */
/* %---------------------------------------% */
/* Computing MIN */
i__3 = i__ + 3;
ir = min(i__3,iend);
slarf_("Right", &ir, &nr, u, &c__1, &tau, &h__[i__ * h_dim1 +
1], ldh, &workl[1], (ftnlen)5);
/* %-----------------------------------------------------% */
/* | Accumulate the reflector in the matrix Q; Q <- Q*G | */
/* %-----------------------------------------------------% */
slarf_("Right", &kplusp, &nr, u, &c__1, &tau, &q[i__ * q_dim1
+ 1], ldq, &workl[1], (ftnlen)5);
/* %----------------------------% */
/* | Prepare for next reflector | */
/* %----------------------------% */
if (i__ < iend - 1) {
u[0] = h__[i__ + 1 + i__ * h_dim1];
u[1] = h__[i__ + 2 + i__ * h_dim1];
if (i__ < iend - 2) {
u[2] = h__[i__ + 3 + i__ * h_dim1];
}
}
/* L90: */
}
/* %--------------------------------------------% */
/* | Finished applying a complex pair of shifts | */
/* | to the current block | */
/* %--------------------------------------------% */
}
L100:
/* %---------------------------------------------------------% */
/* | Apply the same shift to the next block if there is any. | */
/* %---------------------------------------------------------% */
istart = iend + 1;
if (iend < kplusp) {
goto L20;
}
/* %---------------------------------------------% */
/* | Loop back to the top to get the next shift. | */
/* %---------------------------------------------% */
L110:
;
}
/* %--------------------------------------------------% */
/* | Perform a similarity transformation that makes | */
/* | sure that H will have non negative sub diagonals | */
/* %--------------------------------------------------% */
i__1 = *kev;
for (j = 1; j <= i__1; ++j) {
if (h__[j + 1 + j * h_dim1] < 0.f) {
i__2 = kplusp - j + 1;
sscal_(&i__2, &c_b43, &h__[j + 1 + j * h_dim1], ldh);
/* Computing MIN */
i__3 = j + 2;
i__2 = min(i__3,kplusp);
sscal_(&i__2, &c_b43, &h__[(j + 1) * h_dim1 + 1], &c__1);
/* Computing MIN */
i__3 = j + *np + 1;
i__2 = min(i__3,kplusp);
sscal_(&i__2, &c_b43, &q[(j + 1) * q_dim1 + 1], &c__1);
}
/* L120: */
}
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
/* %--------------------------------------------% */
/* | Final check for splitting and deflation. | */
/* | Use a standard test as in the QR algorithm | */
/* | REFERENCE: LAPACK subroutine slahqr | */
/* %--------------------------------------------% */
tst1 = (r__1 = h__[i__ + i__ * h_dim1], dabs(r__1)) + (r__2 = h__[i__
+ 1 + (i__ + 1) * h_dim1], dabs(r__2));
if (tst1 == 0.f) {
tst1 = slanhs_("1", kev, &h__[h_offset], ldh, &workl[1], (ftnlen)
1);
}
/* Computing MAX */
r__1 = ulp * tst1;
if (h__[i__ + 1 + i__ * h_dim1] <= dmax(r__1,smlnum)) {
h__[i__ + 1 + i__ * h_dim1] = 0.f;
}
/* L130: */
}
/* %-------------------------------------------------% */
/* | Compute the (kev+1)-st column of (V*Q) and | */
/* | temporarily store the result in WORKD(N+1:2*N). | */
/* | This is needed in the residual update since we | */
/* | cannot GUARANTEE that the corresponding entry | */
/* | of H would be zero as in exact arithmetic. | */
/* %-------------------------------------------------% */
if (h__[*kev + 1 + *kev * h_dim1] > 0.f) {
sgemv_("N", n, &kplusp, &c_b6, &v[v_offset], ldv, &q[(*kev + 1) *
q_dim1 + 1], &c__1, &c_b5, &workd[*n + 1], &c__1, (ftnlen)1);
}
/* %----------------------------------------------------------% */
/* | Compute column 1 to kev of (V*Q) in backward order | */
/* | taking advantage of the upper Hessenberg structure of Q. | */
/* %----------------------------------------------------------% */
i__1 = *kev;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = kplusp - i__ + 1;
sgemv_("N", n, &i__2, &c_b6, &v[v_offset], ldv, &q[(*kev - i__ + 1) *
q_dim1 + 1], &c__1, &c_b5, &workd[1], &c__1, (ftnlen)1);
scopy_(n, &workd[1], &c__1, &v[(kplusp - i__ + 1) * v_dim1 + 1], &
c__1);
/* L140: */
}
/* %-------------------------------------------------% */
/* | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | */
/* %-------------------------------------------------% */
slacpy_("A", n, kev, &v[(kplusp - *kev + 1) * v_dim1 + 1], ldv, &v[
v_offset], ldv, (ftnlen)1);
/* %--------------------------------------------------------------% */
/* | Copy the (kev+1)-st column of (V*Q) in the appropriate place | */
/* %--------------------------------------------------------------% */
if (h__[*kev + 1 + *kev * h_dim1] > 0.f) {
scopy_(n, &workd[*n + 1], &c__1, &v[(*kev + 1) * v_dim1 + 1], &c__1);
}
/* %-------------------------------------% */
/* | Update the residual vector: | */
/* | r <- sigmak*r + betak*v(:,kev+1) | */
/* | where | */
/* | sigmak = (e_{kplusp}'*Q)*e_{kev} | */
/* | betak = e_{kev+1}'*H*e_{kev} | */
/* %-------------------------------------% */
sscal_(n, &q[kplusp + *kev * q_dim1], &resid[1], &c__1);
if (h__[*kev + 1 + *kev * h_dim1] > 0.f) {
saxpy_(n, &h__[*kev + 1 + *kev * h_dim1], &v[(*kev + 1) * v_dim1 + 1],
&c__1, &resid[1], &c__1);
}
if (msglvl > 1) {
svout_(&debug_1.logfil, &c__1, &q[kplusp + *kev * q_dim1], &
debug_1.ndigit, "_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}", (
ftnlen)40);
svout_(&debug_1.logfil, &c__1, &h__[*kev + 1 + *kev * h_dim1], &
debug_1.ndigit, "_napps: betak = e_{kev+1}^T*H*e_{kev}", (
ftnlen)37);
ivout_(&debug_1.logfil, &c__1, kev, &debug_1.ndigit, "_napps: Order "
"of the final Hessenberg matrix ", (ftnlen)45);
if (msglvl > 2) {
smout_(&debug_1.logfil, kev, kev, &h__[h_offset], ldh, &
debug_1.ndigit, "_napps: updated Hessenberg matrix H for"
" next iteration", (ftnlen)54);
}
}
L9000:
second_(&t1);
timing_1.tnapps += t1 - t0;
return 0;
/* %---------------% */
/* | End of snapps | */
/* %---------------% */
} /* snapps_ */
/* 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 sgerq2_(integer *m, integer *n, real *a, integer *lda,
real *tau, real *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SGERQ2 computes an RQ factorization of a real m by n matrix A:
A = R * 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.
A (input/output) REAL array, dimension (LDA,N)
On entry, the m by n matrix A.
On exit, if m <= n, the upper triangle of the subarray
A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
if m >= n, the elements on and above the (m-n)-th subdiagonal
contain the m by n upper trapezoidal matrix R; the remaining
elements, with the array TAU, represent the orthogonal matrix
Q as a product of elementary reflectors (see Further
Details).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
TAU (output) REAL array, dimension (min(M,N))
The scalar factors of the elementary reflectors (see Further
Details).
WORK (workspace) REAL array, dimension (M)
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(k), where k = min(m,n).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a real scalar, and v is a real vector with
v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
A(m-k+i,1:n-k+i-1), and tau in TAU(i).
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer i, k;
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *), xerbla_(
char *, integer *), slarfg_(integer *, real *, real *,
integer *, real *);
static real aii;
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*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_("SGERQ2", &i__1);
return 0;
}
k = min(*m,*n);
for (i = k; i >= 1; --i) {
/* Generate elementary reflector H(i) to annihilate
A(m-k+i,1:n-k+i-1) */
i__1 = *n - k + i;
slarfg_(&i__1, &A(*m-k+i,*n-k+i), &A(*m-k+i,1), lda, &TAU(i));
/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */
aii = A(*m-k+i,*n-k+i);
A(*m-k+i,*n-k+i) = 1.f;
i__1 = *m - k + i - 1;
i__2 = *n - k + i;
slarf_("Right", &i__1, &i__2, &A(*m-k+i,1), lda, &TAU(i), &
A(1,1), lda, &WORK(1));
A(*m-k+i,*n-k+i) = aii;
/* L10: */
}
return 0;
/* End of SGERQ2 */
} /* sgerq2_ */
int sorgr2_(int *m, int *n, int *k, float *a,
int *lda, float *tau, float *work, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2, i__3;
float r__1;
/* Local variables */
int i__, j, l, ii;
extern int sscal_(int *, float *, float *, int *),
slarf_(char *, int *, int *, float *, int *, float *,
float *, int *, float *), xerbla_(char *, int *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SORGR2 generates an m by n float matrix Q with orthonormal rows, */
/* which is defined as the last m rows of a product of k elementary */
/* reflectors of order n */
/* Q = H(1) H(2) . . . H(k) */
/* as returned by SGERQF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q. N >= M. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the (m-k+i)-th row must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* returned by SGERQF in the last k rows of its array argument */
/* A. */
/* On exit, the m by n matrix Q. */
/* LDA (input) INTEGER */
/* The first dimension of the array A. LDA >= MAX(1,M). */
/* TAU (input) REAL array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by SGERQF. */
/* WORK (workspace) REAL array, dimension (M) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < MAX(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORGR2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows 1:m-k to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m - *k;
for (l = 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.f;
/* L10: */
}
if (j > *n - *m && j <= *n - *k) {
a[*m - *n + j + j * a_dim1] = 1.f;
}
/* L20: */
}
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
ii = *m - *k + i__;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right */
a[ii + (*n - *m + ii) * a_dim1] = 1.f;
i__2 = ii - 1;
i__3 = *n - *m + ii;
slarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &tau[i__], &a[
a_offset], lda, &work[1]);
i__2 = *n - *m + ii - 1;
r__1 = -tau[i__];
sscal_(&i__2, &r__1, &a[ii + a_dim1], lda);
a[ii + (*n - *m + ii) * a_dim1] = 1.f - tau[i__];
/* Set A(m-k+i,n-k+i+1:n) to zero */
i__2 = *n;
for (l = *n - *m + ii + 1; l <= i__2; ++l) {
a[ii + l * a_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of SORGR2 */
} /* sorgr2_ */
/* Subroutine */ int sgehd2_(integer *n, integer *ilo, integer *ihi, real *a,
integer *lda, real *tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
real aii;
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *), xerbla_(
char *, integer *), slarfg_(integer *, real *, real *,
integer *, real *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEHD2 reduces a real general matrix A to upper Hessenberg form H by */
/* an orthogonal similarity transformation: Q' * A * Q = H . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that A is already upper triangular in rows */
/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
/* set by a previous call to SGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= max(1,N). */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the n by n general matrix to be reduced. */
/* On exit, the upper triangle and the first subdiagonal of A */
/* are overwritten with the upper Hessenberg matrix H, and the */
/* elements below the first subdiagonal, with the array TAU, */
/* represent the orthogonal matrix Q as a product of elementary */
/* reflectors. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) REAL array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) REAL array, dimension (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 (ihi-ilo) elementary */
/* reflectors */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
/* exit in A(i+2:ihi,i), and tau in TAU(i). */
/* The contents of A are illustrated by the following example, with */
/* n = 7, ilo = 2 and ihi = 6: */
/* on entry, on exit, */
/* ( a a a a a a a ) ( a a h h h h a ) */
/* ( a a a a a a ) ( a h h h h a ) */
/* ( a a a a a a ) ( h h h h h h ) */
/* ( a a a a a a ) ( v2 h h h h h ) */
/* ( a a a a a a ) ( v2 v3 h h h h ) */
/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
/* ( a ) ( a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -2;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGEHD2", &i__1);
return 0;
}
i__1 = *ihi - 1;
for (i__ = *ilo; i__ <= i__1; ++i__) {
/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
i__2 = *ihi - i__;
/* Computing MIN */
i__3 = i__ + 2;
slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
aii = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.f;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i__;
slarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i__;
i__3 = *n - i__;
slarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
a[i__ + 1 + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of SGEHD2 */
} /* sgehd2_ */
/* Subroutine */ int sqrt15_(integer *scale, integer *rksel, integer *m,
integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *
ldb, real *s, integer *rank, real *norma, real *normb, integer *iseed,
real *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1;
/* Local variables */
static integer info;
static real temp;
extern doublereal snrm2_(integer *, real *, integer *);
static integer j;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *), sgemm_(char *, char *,
integer *, integer *, integer *, real *, real *, integer *, real *
, integer *, real *, real *, integer *);
extern doublereal sasum_(integer *, real *, integer *);
static real dummy[1];
static integer mn;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int slaord_(char *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *), slaror_(char *, char *, integer *,
integer *, real *, integer *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
static real smlnum, eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SQRT15 generates a matrix with full or deficient rank and of various
norms.
Arguments
=========
SCALE (input) INTEGER
SCALE = 1: normally scaled matrix
SCALE = 2: matrix scaled up
SCALE = 3: matrix scaled down
RKSEL (input) INTEGER
RKSEL = 1: full rank matrix
RKSEL = 2: rank-deficient matrix
M (input) INTEGER
The number of rows of the matrix A.
N (input) INTEGER
The number of columns of A.
NRHS (input) INTEGER
The number of columns of B.
A (output) REAL array, dimension (LDA,N)
The M-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A.
B (output) REAL array, dimension (LDB, NRHS)
A matrix that is in the range space of matrix A.
LDB (input) INTEGER
The leading dimension of the array B.
S (output) REAL array, dimension MIN(M,N)
Singular values of A.
RANK (output) INTEGER
number of nonzero singular values of A.
NORMA (output) REAL
one-norm of A.
NORMB (output) REAL
one-norm of B.
ISEED (input/output) integer array, dimension (4)
seed for random number generator.
WORK (workspace) REAL array, dimension (LWORK)
LWORK (input) INTEGER
length of work space required.
LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--s;
--iseed;
--work;
/* Function Body */
mn = min(*m,*n);
/* Computing MAX */
i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
+ *m;
if (*lwork < max(i__1,i__2)) {
xerbla_("SQRT15", &c__16);
return 0;
}
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
eps = slamch_("Epsilon");
smlnum = smlnum / eps / eps;
bignum = 1.f / smlnum;
/* Determine rank and (unscaled) singular values */
if (*rksel == 1) {
*rank = mn;
} else if (*rksel == 2) {
*rank = mn * 3 / 4;
i__1 = mn;
for (j = *rank + 1; j <= i__1; ++j) {
s[j] = 0.f;
/* L10: */
}
} else {
xerbla_("SQRT15", &c__2);
}
if (*rank > 0) {
/* Nontrivial case */
s[1] = 1.f;
i__1 = *rank;
for (j = 2; j <= i__1; ++j) {
L20:
temp = slarnd_(&c__1, &iseed[1]);
if (temp > .1f) {
s[j] = dabs(temp);
} else {
goto L20;
}
/* L30: */
}
slaord_("Decreasing", rank, &s[1], &c__1);
/* Generate 'rank' columns of a random orthogonal matrix in A */
slarnv_(&c__2, &iseed[1], m, &work[1]);
r__1 = 1.f / snrm2_(m, &work[1], &c__1);
sscal_(m, &r__1, &work[1], &c__1);
slaset_("Full", m, rank, &c_b18, &c_b19, &a[a_offset], lda)
;
slarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
work[*m + 1]);
/* workspace used: m+mn
Generate consistent rhs in the range space of A */
i__1 = *rank * *nrhs;
slarnv_(&c__2, &iseed[1], &i__1, &work[1]);
sgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b19, &a[
a_offset], lda, &work[1], rank, &c_b18, &b[b_offset], ldb);
/* work space used: <= mn *nrhs
generate (unscaled) matrix A */
i__1 = *rank;
for (j = 1; j <= i__1; ++j) {
sscal_(m, &s[j], &a_ref(1, j), &c__1);
/* L40: */
}
if (*rank < *n) {
i__1 = *n - *rank;
slaset_("Full", m, &i__1, &c_b18, &c_b18, &a_ref(1, *rank + 1),
lda);
}
slaror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
1], &work[1], &info);
} else {
/* work space used 2*n+m
Generate null matrix and rhs */
i__1 = mn;
for (j = 1; j <= i__1; ++j) {
s[j] = 0.f;
/* L50: */
}
slaset_("Full", m, n, &c_b18, &c_b18, &a[a_offset], lda);
slaset_("Full", m, nrhs, &c_b18, &c_b18, &b[b_offset], ldb)
;
}
/* Scale the matrix */
if (*scale != 1) {
*norma = slange_("Max", m, n, &a[a_offset], lda, dummy);
if (*norma != 0.f) {
if (*scale == 2) {
/* matrix scaled up */
slascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
s[1], &mn, &info);
slascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
b_offset], ldb, &info);
} else if (*scale == 3) {
/* matrix scaled down */
slascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
s[1], &mn, &info);
slascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
b_offset], ldb, &info);
} else {
xerbla_("SQRT15", &c__1);
return 0;
}
}
}
*norma = sasum_(&mn, &s[1], &c__1);
*normb = slange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
;
return 0;
/* End of SQRT15 */
} /* sqrt15_ */
/* Subroutine */ int slarfx_(char *side, integer *m, integer *n, real *v,
real *tau, real *c__, integer *ldc, real *work)
{
/* System generated locals */
integer c_dim1, c_offset, i__1;
/* Local variables */
integer j;
real t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, v7, v8,
v9, t10, v10, sum;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLARFX applies a real elementary reflector H to a real m by n */
/* matrix C, from either the left or the right. H is represented in the */
/* form */
/* H = I - tau * v * v' */
/* where tau is a real scalar and v is a real vector. */
/* If tau = 0, then H is taken to be the unit matrix */
/* This version uses inline code if H has order < 11. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': form H * C */
/* = 'R': form C * H */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* V (input) REAL array, dimension (M) if SIDE = 'L' */
/* or (N) if SIDE = 'R' */
/* The vector v in the representation of H. */
/* TAU (input) REAL */
/* The value tau in the representation of H. */
/* C (input/output) REAL array, dimension (LDC,N) */
/* On entry, the m by n matrix C. */
/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
/* or C * H if SIDE = 'R'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDA >= (1,M). */
/* WORK (workspace) REAL array, dimension */
/* (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* WORK is not referenced if H has order < 11. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
if (*tau == 0.f) {
return 0;
}
if (lsame_(side, "L")) {
/* Form H * C, where H has order m. */
switch (*m) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L70;
case 5: goto L90;
case 6: goto L110;
case 7: goto L130;
case 8: goto L150;
case 9: goto L170;
case 10: goto L190;
}
/* Code for general M */
slarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]);
goto L410;
L10:
/* Special code for 1 x 1 Householder */
t1 = 1.f - *tau * v[1] * v[1];
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
c__[j * c_dim1 + 1] = t1 * c__[j * c_dim1 + 1];
/* L20: */
}
goto L410;
L30:
/* Special code for 2 x 2 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
/* L40: */
}
goto L410;
L50:
/* Special code for 3 x 3 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
/* L60: */
}
goto L410;
L70:
/* Special code for 4 x 4 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
/* L80: */
}
goto L410;
L90:
/* Special code for 5 x 5 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
/* L100: */
}
goto L410;
L110:
/* Special code for 6 x 6 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
/* L120: */
}
goto L410;
L130:
/* Special code for 7 x 7 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
/* L140: */
}
goto L410;
L150:
/* Special code for 8 x 8 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7] + v8 * c__[j * c_dim1 + 8];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
/* L160: */
}
goto L410;
L170:
/* Special code for 9 x 9 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j *
c_dim1 + 9];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
c__[j * c_dim1 + 9] -= sum * t9;
/* L180: */
}
goto L410;
L190:
/* Special code for 10 x 10 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
v10 = v[10];
t10 = *tau * v10;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j *
c_dim1 + 9] + v10 * c__[j * c_dim1 + 10];
c__[j * c_dim1 + 1] -= sum * t1;
c__[j * c_dim1 + 2] -= sum * t2;
c__[j * c_dim1 + 3] -= sum * t3;
c__[j * c_dim1 + 4] -= sum * t4;
c__[j * c_dim1 + 5] -= sum * t5;
c__[j * c_dim1 + 6] -= sum * t6;
c__[j * c_dim1 + 7] -= sum * t7;
c__[j * c_dim1 + 8] -= sum * t8;
c__[j * c_dim1 + 9] -= sum * t9;
c__[j * c_dim1 + 10] -= sum * t10;
/* L200: */
}
goto L410;
} else {
/* Form C * H, where H has order n. */
switch (*n) {
case 1: goto L210;
case 2: goto L230;
case 3: goto L250;
case 4: goto L270;
case 5: goto L290;
case 6: goto L310;
case 7: goto L330;
case 8: goto L350;
case 9: goto L370;
case 10: goto L390;
}
/* Code for general N */
slarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]);
goto L410;
L210:
/* Special code for 1 x 1 Householder */
t1 = 1.f - *tau * v[1] * v[1];
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
c__[j + c_dim1] = t1 * c__[j + c_dim1];
/* L220: */
}
goto L410;
L230:
/* Special code for 2 x 2 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
/* L240: */
}
goto L410;
L250:
/* Special code for 3 x 3 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
/* L260: */
}
goto L410;
L270:
/* Special code for 4 x 4 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
/* L280: */
}
goto L410;
L290:
/* Special code for 5 x 5 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
/* L300: */
}
goto L410;
L310:
/* Special code for 6 x 6 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
/* L320: */
}
goto L410;
L330:
/* Special code for 7 x 7 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
/* L340: */
}
goto L410;
L350:
/* Special code for 8 x 8 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
/* L360: */
}
goto L410;
L370:
/* Special code for 9 x 9 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[
j + c_dim1 * 9];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
c__[j + c_dim1 * 9] -= sum * t9;
/* L380: */
}
goto L410;
L390:
/* Special code for 10 x 10 Householder */
v1 = v[1];
t1 = *tau * v1;
v2 = v[2];
t2 = *tau * v2;
v3 = v[3];
t3 = *tau * v3;
v4 = v[4];
t4 = *tau * v4;
v5 = v[5];
t5 = *tau * v5;
v6 = v[6];
t6 = *tau * v6;
v7 = v[7];
t7 = *tau * v7;
v8 = v[8];
t8 = *tau * v8;
v9 = v[9];
t9 = *tau * v9;
v10 = v[10];
t10 = *tau * v10;
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[
j + c_dim1 * 9] + v10 * c__[j + c_dim1 * 10];
c__[j + c_dim1] -= sum * t1;
c__[j + (c_dim1 << 1)] -= sum * t2;
c__[j + c_dim1 * 3] -= sum * t3;
c__[j + (c_dim1 << 2)] -= sum * t4;
c__[j + c_dim1 * 5] -= sum * t5;
c__[j + c_dim1 * 6] -= sum * t6;
c__[j + c_dim1 * 7] -= sum * t7;
c__[j + (c_dim1 << 3)] -= sum * t8;
c__[j + c_dim1 * 9] -= sum * t9;
c__[j + c_dim1 * 10] -= sum * t10;
/* L400: */
}
goto L410;
}
L410:
return 0;
/* End of SLARFX */
} /* slarfx_ */
/* Subroutine */
int sormr2_(char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
integer i__, i1, i2, i3, mi, ni, nq;
real aii;
logical left;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *), xerbla_( char *, integer *);
logical notran;
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
/* NQ is the order of Q */
if (left)
{
nq = *m;
}
else
{
nq = *n;
}
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,*k))
{
*info = -7;
}
else if (*ldc < max(1,*m))
{
*info = -10;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("SORMR2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0)
{
return 0;
}
if (left && ! notran || ! left && notran)
{
i1 = 1;
i2 = *k;
i3 = 1;
}
else
{
i1 = *k;
i2 = 1;
i3 = -1;
}
if (left)
{
ni = *n;
}
else
{
mi = *m;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1;
i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
i__ += i__2)
{
if (left)
{
/* H(i) is applied to C(1:m-k+i,1:n) */
mi = *m - *k + i__;
}
else
{
/* H(i) is applied to C(1:m,1:n-k+i) */
ni = *n - *k + i__;
}
/* Apply H(i) */
aii = a[i__ + (nq - *k + i__) * a_dim1];
a[i__ + (nq - *k + i__) * a_dim1] = 1.f;
slarf_(side, &mi, &ni, &a[i__ + a_dim1], lda, &tau[i__], &c__[ c_offset], ldc, &work[1]);
a[i__ + (nq - *k + i__) * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of SORMR2 */
}
/* Subroutine */ int sormr2_(char *side, char *trans, integer *m, integer *n,
integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
real *work, integer *info, ftnlen side_len, ftnlen trans_len)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
static integer i__, i1, i2, i3, mi, ni, nq;
static real aii;
static logical left;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, ftnlen), xerbla_(
char *, integer *, ftnlen);
static logical notran;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SORMR2 overwrites the general real m by n matrix C with */
/* Q * C if SIDE = 'L' and TRANS = 'N', or */
/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
/* C * Q if SIDE = 'R' and TRANS = 'N', or */
/* C * Q' if SIDE = 'R' and TRANS = '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 SGERQF. 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' from the Left */
/* = 'R': apply Q or Q' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply Q (No transpose) */
/* = 'T': apply Q' (Transpose) */
/* 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,M) if SIDE = 'L', */
/* (LDA,N) if SIDE = 'R' */
/* The i-th row must contain the vector which defines the */
/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
/* SGERQF in the last k rows 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. LDA >= max(1,K). */
/* TAU (input) REAL array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by SGERQF. */
/* 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'*C or C*Q' or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) REAL array, dimension */
/* (N) if SIDE = 'L', */
/* (M) if SIDE = 'R' */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1);
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1)) {
*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,*k)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORMR2", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = 1;
} else {
i1 = *k;
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
} else {
mi = *m;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) is applied to C(1:m-k+i,1:n) */
mi = *m - *k + i__;
} else {
/* H(i) is applied to C(1:m,1:n-k+i) */
ni = *n - *k + i__;
}
/* Apply H(i) */
aii = a[i__ + (nq - *k + i__) * a_dim1];
a[i__ + (nq - *k + i__) * a_dim1] = 1.f;
slarf_(side, &mi, &ni, &a[i__ + a_dim1], lda, &tau[i__], &c__[
c_offset], ldc, &work[1], (ftnlen)1);
a[i__ + (nq - *k + i__) * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of SORMR2 */
} /* sormr2_ */
/*< >*/
/* Subroutine */ int sorm2r_(char *side, char *trans, integer *m, integer *n,
integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
real *work, integer *info, ftnlen side_len, ftnlen trans_len)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
integer i__, i1, i2, i3, ic=0, jc=0, mi, ni, nq;
real aii;
logical left;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *, ftnlen), xerbla_(
char *, integer *, ftnlen);
logical notran;
(void)side_len;
(void)trans_len;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/*< CHARACTER SIDE, TRANS >*/
/*< INTEGER INFO, K, LDA, LDC, M, N >*/
/* .. */
/* .. Array Arguments .. */
/*< REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* SORM2R overwrites the general real m by n matrix C with */
/* Q * C if SIDE = 'L' and TRANS = 'N', or */
/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
/* C * Q if SIDE = 'R' and TRANS = 'N', or */
/* C * Q' if SIDE = 'R' and TRANS = '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' from the Left */
/* = 'R': apply Q or Q' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply Q (No transpose) */
/* = 'T': apply Q' (Transpose) */
/* 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'*C or C*Q' or C*Q. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) REAL array, dimension */
/* (N) if SIDE = 'L', */
/* (M) if SIDE = 'R' */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/*< REAL ONE >*/
/*< PARAMETER ( ONE = 1.0E+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< LOGICAL LEFT, NOTRAN >*/
/*< INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ >*/
/*< REAL AII >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< EXTERNAL LSAME >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL SLARF, XERBLA >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC MAX >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/*< INFO = 0 >*/
/* 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' ) >*/
left = lsame_(side, "L", (ftnlen)1, (ftnlen)1);
/*< NOTRAN = LSAME( TRANS, 'N' ) >*/
notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1);
/* NQ is the order of Q */
/*< IF( LEFT ) THEN >*/
if (left) {
/*< NQ = M >*/
nq = *m;
/*< ELSE >*/
} else {
/*< NQ = N >*/
nq = *n;
/*< END IF >*/
}
/*< IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN >*/
if (! left && ! lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN >*/
} else if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1)) {
/*< INFO = -2 >*/
*info = -2;
/*< ELSE IF( M.LT.0 ) THEN >*/
} else if (*m < 0) {
/*< INFO = -3 >*/
*info = -3;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -4 >*/
*info = -4;
/*< ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN >*/
} else if (*k < 0 || *k > nq) {
/*< INFO = -5 >*/
*info = -5;
/*< ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN >*/
} else if (*lda < max(1,nq)) {
/*< INFO = -7 >*/
*info = -7;
/*< ELSE IF( LDC.LT.MAX( 1, M ) ) THEN >*/
} else if (*ldc < max(1,*m)) {
/*< INFO = -10 >*/
*info = -10;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'SORM2R', -INFO ) >*/
i__1 = -(*info);
xerbla_("SORM2R", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Quick return if possible */
/*< >*/
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
/*< >*/
if ((left && ! notran) || (! left && notran)) {
/*< I1 = 1 >*/
i1 = 1;
/*< I2 = K >*/
i2 = *k;
/*< I3 = 1 >*/
i3 = 1;
/*< ELSE >*/
} else {
/*< I1 = K >*/
i1 = *k;
/*< I2 = 1 >*/
i2 = 1;
/*< I3 = -1 >*/
i3 = -1;
/*< END IF >*/
}
/*< IF( LEFT ) THEN >*/
if (left) {
/*< NI = N >*/
ni = *n;
/*< JC = 1 >*/
jc = 1;
/*< ELSE >*/
} else {
/*< MI = M >*/
mi = *m;
/*< IC = 1 >*/
ic = 1;
/*< END IF >*/
}
/*< DO 10 I = I1, I2, I3 >*/
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/*< IF( LEFT ) THEN >*/
if (left) {
/* H(i) is applied to C(i:m,1:n) */
/*< MI = M - I + 1 >*/
mi = *m - i__ + 1;
/*< IC = I >*/
ic = i__;
/*< ELSE >*/
} else {
/* H(i) is applied to C(1:m,i:n) */
/*< NI = N - I + 1 >*/
ni = *n - i__ + 1;
/*< JC = I >*/
jc = i__;
/*< END IF >*/
}
/* Apply H(i) */
/*< AII = A( I, I ) >*/
aii = a[i__ + i__ * a_dim1];
/*< A( I, I ) = ONE >*/
a[i__ + i__ * a_dim1] = (float)1.;
/*< >*/
slarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[
ic + jc * c_dim1], ldc, &work[1], (ftnlen)1);
/*< A( I, I ) = AII >*/
a[i__ + i__ * a_dim1] = aii;
/*< 10 CONTINUE >*/
/* L10: */
}
/*< RETURN >*/
return 0;
/* End of SORM2R */
/*< END >*/
} /* sorm2r_ */
/* Subroutine */ int sgerq2_(integer *m, integer *n, real *a, integer *lda,
real *tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer i__, k;
real aii;
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *), xerbla_(
char *, integer *), slarfg_(integer *, real *, real *,
integer *, real *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGERQ2 computes an RQ factorization of a real m by n matrix A: */
/* A = R * 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. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, if m <= n, the upper triangle of the subarray */
/* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */
/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
/* contain the m by n upper trapezoidal matrix R; the remaining */
/* elements, with the array TAU, represent the orthogonal matrix */
/* Q as a product of elementary reflectors (see Further */
/* Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) REAL array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) REAL array, dimension (M) */
/* 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(k), where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a real scalar, and v is a real vector with */
/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */
/* A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
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_("SGERQ2", &i__1);
return 0;
}
k = min(*m,*n);
for (i__ = k; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* A(m-k+i,1:n-k+i-1) */
i__1 = *n - k + i__;
slarfg_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[*m - k
+ i__ + a_dim1], lda, &tau[i__]);
/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */
aii = a[*m - k + i__ + (*n - k + i__) * a_dim1];
a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.f;
i__1 = *m - k + i__ - 1;
i__2 = *n - k + i__;
slarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[
i__], &a[a_offset], lda, &work[1]);
a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of SGERQ2 */
} /* sgerq2_ */
/* Subroutine */
int slaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns, integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real * work, integer *lwork)
{
/* System generated locals */
integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, wv_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;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real s, aa, bb, cc, dd, cs, sn;
integer jw;
real evi, evk, foo;
integer kln;
real tau, ulp;
integer lwk1, lwk2;
real beta;
integer kend, kcol, info, ifst, ilst, ltop, krow;
logical bulge;
extern /* Subroutine */
int slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *), sgemm_( char *, char *, integer *, integer *, integer *, real *, real *, integer *, real *, integer *, real *, real *, integer *);
integer infqr;
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *);
integer kwtop;
extern /* Subroutine */
int slanv2_(real *, real *, real *, real *, real * , real *, real *, real *, real *, real *), slabad_(real *, real *) ;
extern real slamch_(char *);
extern /* Subroutine */
int sgehrd_(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *);
real safmin;
extern /* Subroutine */
int slarfg_(integer *, real *, real *, integer *, real *);
real safmax;
extern /* Subroutine */
int slahqr_(logical *, logical *, integer *, integer *, integer *, real *, integer *, real *, real *, integer * , integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *, real *, integer *);
logical sorted;
extern /* Subroutine */
int strexc_(char *, integer *, real *, integer *, real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, integer *);
real smlnum;
integer lwkopt;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ================================================================ */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* ==== Estimate optimal workspace. ==== */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--sr;
--si;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
wv_dim1 = *ldwv;
wv_offset = 1 + wv_dim1;
wv -= wv_offset;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *nw;
i__2 = *kbot - *ktop + 1; // , expr subst
jw = min(i__1,i__2);
if (jw <= 2)
{
lwkopt = 1;
}
else
{
/* ==== Workspace query call to SGEHRD ==== */
i__1 = jw - 1;
sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info);
lwk1 = (integer) work[1];
/* ==== Workspace query call to SORMHR ==== */
i__1 = jw - 1;
sormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[1], &c_n1, &info);
lwk2 = (integer) work[1];
/* ==== Optimal workspace ==== */
lwkopt = jw + max(lwk1,lwk2);
}
/* ==== Quick return in case of workspace query. ==== */
if (*lwork == -1)
{
work[1] = (real) lwkopt;
return 0;
}
/* ==== Nothing to do ... */
/* ... for an empty active block ... ==== */
*ns = 0;
*nd = 0;
work[1] = 1.f;
if (*ktop > *kbot)
{
return 0;
}
/* ... nor for an empty deflation window. ==== */
if (*nw < 1)
{
return 0;
}
/* ==== Machine constants ==== */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) (*n) / ulp);
/* ==== Setup deflation window ==== */
/* Computing MIN */
i__1 = *nw;
i__2 = *kbot - *ktop + 1; // , expr subst
jw = min(i__1,i__2);
kwtop = *kbot - jw + 1;
if (kwtop == *ktop)
{
s = 0.f;
}
else
{
s = h__[kwtop + (kwtop - 1) * h_dim1];
}
if (*kbot == kwtop)
{
/* ==== 1-by-1 deflation window: not much to do ==== */
sr[kwtop] = h__[kwtop + kwtop * h_dim1];
si[kwtop] = 0.f;
*ns = 1;
*nd = 0;
/* Computing MAX */
r__2 = smlnum;
r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], abs( r__1)); // , expr subst
if (abs(s) <= max(r__2,r__3))
{
*ns = 0;
*nd = 1;
if (kwtop > *ktop)
{
h__[kwtop + (kwtop - 1) * h_dim1] = 0.f;
}
}
work[1] = 1.f;
return 0;
}
/* ==== Convert to spike-triangular form. (In case of a */
/* . rare QR failure, this routine continues to do */
/* . aggressive early deflation using that part of */
/* . the deflation window that converged using INFQR */
/* . here and there to keep track.) ==== */
slacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], ldt);
i__1 = jw - 1;
i__2 = *ldh + 1;
i__3 = *ldt + 1;
scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3);
slaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv);
slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
/* ==== STREXC needs a clean margin near the diagonal ==== */
i__1 = jw - 3;
for (j = 1;
j <= i__1;
++j)
{
t[j + 2 + j * t_dim1] = 0.f;
t[j + 3 + j * t_dim1] = 0.f;
/* L10: */
}
if (jw > 2)
{
t[jw + (jw - 2) * t_dim1] = 0.f;
}
/* ==== Deflation detection loop ==== */
*ns = jw;
ilst = infqr + 1;
L20:
if (ilst <= *ns)
{
if (*ns == 1)
{
bulge = FALSE_;
}
else
{
bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f;
}
/* ==== Small spike tip test for deflation ==== */
if (! bulge)
{
/* ==== Real eigenvalue ==== */
foo = (r__1 = t[*ns + *ns * t_dim1], abs(r__1));
if (foo == 0.f)
{
foo = abs(s);
}
/* Computing MAX */
r__2 = smlnum;
r__3 = ulp * foo; // , expr subst
if ((r__1 = s * v[*ns * v_dim1 + 1], abs(r__1)) <= max(r__2,r__3))
{
/* ==== Deflatable ==== */
--(*ns);
}
else
{
/* ==== Undeflatable. Move it up out of the way. */
/* . (STREXC can not fail in this case.) ==== */
ifst = *ns;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info);
++ilst;
}
}
else
{
/* ==== Complex conjugate pair ==== */
foo = (r__3 = t[*ns + *ns * t_dim1], abs(r__3)) + sqrt((r__1 = t[* ns + (*ns - 1) * t_dim1], abs(r__1))) * sqrt((r__2 = t[* ns - 1 + *ns * t_dim1], abs(r__2)));
if (foo == 0.f)
{
foo = abs(s);
}
/* Computing MAX */
r__3 = (r__1 = s * v[*ns * v_dim1 + 1], abs(r__1));
r__4 = (r__2 = s * v[(*ns - 1) * v_dim1 + 1], abs(r__2)); // , expr subst
/* Computing MAX */
r__5 = smlnum;
r__6 = ulp * foo; // , expr subst
if (max(r__3,r__4) <= max(r__5,r__6))
{
/* ==== Deflatable ==== */
*ns += -2;
}
else
{
/* ==== Undeflatable. Move them up out of the way. */
/* . Fortunately, STREXC does the right thing with */
/* . ILST in case of a rare exchange failure. ==== */
ifst = *ns;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info);
ilst += 2;
}
}
/* ==== End deflation detection loop ==== */
goto L20;
}
/* ==== Return to Hessenberg form ==== */
if (*ns == 0)
{
s = 0.f;
}
if (*ns < jw)
{
/* ==== sorting diagonal blocks of T improves accuracy for */
/* . graded matrices. Bubble sort deals well with */
/* . exchange failures. ==== */
sorted = FALSE_;
i__ = *ns + 1;
L30:
if (sorted)
{
goto L50;
}
sorted = TRUE_;
kend = i__ - 1;
i__ = infqr + 1;
if (i__ == *ns)
{
k = i__ + 1;
}
else if (t[i__ + 1 + i__ * t_dim1] == 0.f)
{
k = i__ + 1;
}
else
{
k = i__ + 2;
}
L40:
if (k <= kend)
{
if (k == i__ + 1)
{
evi = (r__1 = t[i__ + i__ * t_dim1], abs(r__1));
}
else
{
evi = (r__3 = t[i__ + i__ * t_dim1], abs(r__3)) + sqrt((r__1 = t[i__ + 1 + i__ * t_dim1], abs(r__1))) * sqrt((r__2 = t[i__ + (i__ + 1) * t_dim1], abs(r__2)));
}
if (k == kend)
{
evk = (r__1 = t[k + k * t_dim1], abs(r__1));
}
else if (t[k + 1 + k * t_dim1] == 0.f)
{
evk = (r__1 = t[k + k * t_dim1], abs(r__1));
}
else
{
evk = (r__3 = t[k + k * t_dim1], abs(r__3)) + sqrt((r__1 = t[ k + 1 + k * t_dim1], abs(r__1))) * sqrt((r__2 = t[k + (k + 1) * t_dim1], abs(r__2)));
}
if (evi >= evk)
{
i__ = k;
}
else
{
sorted = FALSE_;
ifst = i__;
ilst = k;
strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info);
if (info == 0)
{
i__ = ilst;
}
else
{
i__ = k;
}
}
if (i__ == kend)
{
k = i__ + 1;
}
else if (t[i__ + 1 + i__ * t_dim1] == 0.f)
{
k = i__ + 1;
}
else
{
k = i__ + 2;
}
goto L40;
}
goto L30;
L50:
;
}
/* ==== Restore shift/eigenvalue array from T ==== */
i__ = jw;
L60:
if (i__ >= infqr + 1)
{
if (i__ == infqr + 1)
{
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.f;
--i__;
}
else if (t[i__ + (i__ - 1) * t_dim1] == 0.f)
{
sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
si[kwtop + i__ - 1] = 0.f;
--i__;
}
else
{
aa = t[i__ - 1 + (i__ - 1) * t_dim1];
cc = t[i__ + (i__ - 1) * t_dim1];
bb = t[i__ - 1 + i__ * t_dim1];
dd = t[i__ + i__ * t_dim1];
slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & sn);
i__ += -2;
}
goto L60;
}
if (*ns < jw || s == 0.f)
{
if (*ns > 1 && s != 0.f)
{
/* ==== Reflect spike back into lower triangle ==== */
scopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
beta = work[1];
slarfg_(ns, &beta, &work[2], &c__1, &tau);
work[1] = 1.f;
i__1 = jw - 2;
i__2 = jw - 2;
slaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt);
slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]);
slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]);
slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]);
i__1 = *lwork - jw;
sgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] , &i__1, &info);
}
/* ==== Copy updated reduced window into place ==== */
if (kwtop > 1)
{
h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
}
slacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] , ldh);
i__1 = jw - 1;
i__2 = *ldt + 1;
i__3 = *ldh + 1;
scopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], &i__3);
/* ==== Accumulate orthogonal matrix in order update */
/* . H and Z, if requested. ==== */
if (*ns > 1 && s != 0.f)
{
i__1 = *lwork - jw;
sormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
}
/* ==== Update vertical slab in H ==== */
if (*wantt)
{
ltop = 1;
}
else
{
ltop = *ktop;
}
i__1 = kwtop - 1;
i__2 = *nv;
for (krow = ltop;
i__2 < 0 ? krow >= i__1 : krow <= i__1;
krow += i__2)
{
/* Computing MIN */
i__3 = *nv;
i__4 = kwtop - krow; // , expr subst
kln = min(i__3,i__4);
sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset], ldwv);
slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh);
/* L70: */
}
/* ==== Update horizontal slab in H ==== */
if (*wantt)
{
i__2 = *n;
i__1 = *nh;
for (kcol = *kbot + 1;
i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
kcol += i__1)
{
/* Computing MIN */
i__3 = *nh;
i__4 = *n - kcol + 1; // , expr subst
kln = min(i__3,i__4);
sgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset], ldt);
slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh);
/* L80: */
}
}
/* ==== Update vertical slab in Z ==== */
if (*wantz)
{
i__1 = *ihiz;
i__2 = *nv;
for (krow = *iloz;
i__2 < 0 ? krow >= i__1 : krow <= i__1;
krow += i__2)
{
/* Computing MIN */
i__3 = *nv;
i__4 = *ihiz - krow + 1; // , expr subst
kln = min(i__3,i__4);
sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[ wv_offset], ldwv);
slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz);
/* L90: */
}
}
}
/* ==== Return the number of deflations ... ==== */
*nd = jw - *ns;
/* ==== ... and the number of shifts. (Subtracting */
/* . INFQR from the spike length takes care */
/* . of the case of a rare QR failure while */
/* . calculating eigenvalues of the deflation */
/* . window.) ==== */
*ns -= infqr;
/* ==== Return optimal workspace. ==== */
work[1] = (real) lwkopt;
/* ==== End of SLAQR2 ==== */
return 0;
}
/* Subroutine */ int sgebd2_(integer *m, integer *n, real *a, integer *lda,
real *d__, real *e, real *tauq, real *taup, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__;
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *), xerbla_(
char *, integer *), slarfg_(integer *, real *, real *,
integer *, real *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEBD2 reduces a real general m by n matrix A to upper or lower */
/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */
/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the m by n general matrix to be reduced. */
/* On exit, */
/* if m >= n, the diagonal and the first superdiagonal are */
/* overwritten with the upper bidiagonal matrix B; the */
/* elements below the diagonal, with the array TAUQ, represent */
/* the orthogonal matrix Q as a product of elementary */
/* reflectors, and the elements above the first superdiagonal, */
/* with the array TAUP, represent the orthogonal matrix P as */
/* a product of elementary reflectors; */
/* if m < n, the diagonal and the first subdiagonal are */
/* overwritten with the lower bidiagonal matrix B; the */
/* elements below the first subdiagonal, with the array TAUQ, */
/* represent the orthogonal matrix Q as a product of */
/* elementary reflectors, and the elements above the diagonal, */
/* with the array TAUP, represent the orthogonal matrix P as */
/* a product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* D (output) REAL array, dimension (min(M,N)) */
/* The diagonal elements of the bidiagonal matrix B: */
/* D(i) = A(i,i). */
/* E (output) REAL array, dimension (min(M,N)-1) */
/* The off-diagonal elements of the bidiagonal matrix B: */
/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
/* TAUQ (output) REAL array dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix Q. See Further Details. */
/* TAUP (output) REAL array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix P. See Further Details. */
/* WORK (workspace) REAL array, dimension (max(M,N)) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* If m >= n, */
/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are real scalars, and v and u are real vectors; */
/* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */
/* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */
/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* If m < n, */
/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
/* Each H(i) and G(i) has the form: */
/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
/* where tauq and taup are real scalars, and v and u are real vectors; */
/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The contents of A on exit are illustrated by the following examples: */
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
/* ( v1 v2 v3 v4 v5 ) */
/* where d and e denote diagonal and off-diagonal elements of B, vi */
/* denotes an element of the vector defining H(i), and ui an element of */
/* the vector defining G(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
--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_("SGEBD2", &i__1);
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ *
a_dim1], &c__1, &tauq[i__]);
d__[i__] = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.f;
/* Apply H(i) to A(i:m,i+1:n) from the left */
if (i__ < *n) {
i__2 = *m - i__ + 1;
i__3 = *n - i__;
slarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]
);
}
a[i__ + i__ * a_dim1] = d__[i__];
if (i__ < *n) {
/* Generate elementary reflector G(i) to annihilate */
/* A(i,i+2:n) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
slarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
i__3, *n)* a_dim1], lda, &taup[i__]);
e[i__] = a[i__ + (i__ + 1) * a_dim1];
a[i__ + (i__ + 1) * a_dim1] = 1.f;
/* Apply G(i) to A(i+1:m,i+1:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__;
slarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1]);
a[i__ + (i__ + 1) * a_dim1] = e[i__];
} else {
taup[i__] = 0.f;
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)*
a_dim1], lda, &taup[i__]);
d__[i__] = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.f;
/* Apply G(i) to A(i+1:m,i:n) from the right */
if (i__ < *m) {
i__2 = *m - i__;
i__3 = *n - i__ + 1;
slarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &
taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
}
a[i__ + i__ * a_dim1] = d__[i__];
if (i__ < *m) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:m,i) */
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m)+
i__ * a_dim1], &c__1, &tauq[i__]);
e[i__] = a[i__ + 1 + i__ * a_dim1];
a[i__ + 1 + i__ * a_dim1] = 1.f;
/* Apply H(i) to A(i+1:m,i+1:n) from the left */
i__2 = *m - i__;
i__3 = *n - i__;
slarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1]);
a[i__ + 1 + i__ * a_dim1] = e[i__];
} else {
tauq[i__] = 0.f;
}
/* L20: */
}
}
return 0;
/* End of SGEBD2 */
} /* sgebd2_ */
/* Subroutine */ int sgeqr2_(integer *m, integer *n, real *a, integer *lda,
real *tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
integer i__, k;
real aii;
extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
integer *, real *, real *, integer *, real *), xerbla_(
char *, integer *), slarfp_(integer *, real *, real *,
integer *, real *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGEQR2 computes a QR factorization of a real m by n matrix A: */
/* A = 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 elements on and above the diagonal of the array */
/* contain the min(m,n) by n upper trapezoidal matrix R (R is */
/* upper triangular if m >= n); the elements below the diagonal, */
/* with the array TAU, represent the orthogonal matrix Q as a */
/* product of elementary reflectors (see Further Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) REAL array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further */
/* Details). */
/* WORK (workspace) REAL array, dimension (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(k), where k = min(m,n). */
/* Each H(i) has the form */
/* H(i) = 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), */
/* and tau in TAU(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
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_("SGEQR2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
slarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ * a_dim1]
, &c__1, &tau[i__]);
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[1]);
a[i__ + i__ * a_dim1] = aii;
}
/* L10: */
}
return 0;
/* End of SGEQR2 */
} /* sgeqr2_ */
/* Subroutine */ int sorgl2_(integer *m, integer *n, integer *k, real *a,
integer *lda, real *tau, real *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SORGL2 generates an m by n real matrix Q with orthonormal rows,
which is defined as the first m rows of a product of k elementary
reflectors of order n
Q = H(k) . . . H(2) H(1)
as returned by SGELQF.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q. N >= M.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. M >= K >= 0.
A (input/output) REAL array, dimension (LDA,N)
On entry, the i-th row must contain the vector which defines
the elementary reflector H(i), for i = 1,2,...,k, as returned
by SGELQF in the first k rows of its array argument A.
On exit, the m-by-n matrix Q.
LDA (input) INTEGER
The first dimension of the array A. LDA >= max(1,M).
TAU (input) REAL array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by SGELQF.
WORK (workspace) REAL array, dimension (M)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument has an illegal value
=====================================================================
Test the input arguments
Parameter adjustments
Function Body */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1;
/* Local variables */
static integer i, j, l;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *), xerbla_(char *, integer *);
#define TAU(I) tau[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORGL2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows k+1:m to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *m;
for (l = *k + 1; l <= *m; ++l) {
A(l,j) = 0.f;
/* L10: */
}
if (j > *k && j <= *m) {
A(j,j) = 1.f;
}
/* L20: */
}
}
for (i = *k; i >= 1; --i) {
/* Apply H(i) to A(i:m,i:n) from the right */
if (i < *n) {
if (i < *m) {
A(i,i) = 1.f;
i__1 = *m - i;
i__2 = *n - i + 1;
slarf_("Right", &i__1, &i__2, &A(i,i), lda, &TAU(i)
, &A(i+1,i), lda, &WORK(1));
}
i__1 = *n - i;
r__1 = -(doublereal)TAU(i);
sscal_(&i__1, &r__1, &A(i,i+1), lda);
}
A(i,i) = 1.f - TAU(i);
/* Set A(1:i-1,i) to zero */
i__1 = i - 1;
for (l = 1; l <= i-1; ++l) {
A(i,l) = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of SORGL2 */
} /* sorgl2_ */
/* Subroutine */ int sorgl2_(integer *m, integer *n, integer *k, real *a,
integer *lda, real *tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1;
/* Local variables */
integer i__, j, l;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SORGL2 generates an m by n real matrix Q with orthonormal rows, */
/* which is defined as the first m rows of a product of k elementary */
/* reflectors of order n */
/* Q = H(k) . . . H(2) H(1) */
/* as returned by SGELQF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q. N >= M. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the i-th row must contain the vector which defines */
/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
/* by SGELQF in the first k rows of its array argument A. */
/* On exit, the m-by-n matrix Q. */
/* LDA (input) INTEGER */
/* The first dimension of the array A. LDA >= max(1,M). */
/* TAU (input) REAL array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by SGELQF. */
/* WORK (workspace) REAL array, dimension (M) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORGL2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows k+1:m to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (l = *k + 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.f;
/* L10: */
}
if (j > *k && j <= *m) {
a[j + j * a_dim1] = 1.f;
}
/* L20: */
}
}
for (i__ = *k; i__ >= 1; --i__) {
/* Apply H(i) to A(i:m,i:n) from the right */
if (i__ < *n) {
if (i__ < *m) {
a[i__ + i__ * a_dim1] = 1.f;
i__1 = *m - i__;
i__2 = *n - i__ + 1;
slarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
}
i__1 = *n - i__;
r__1 = -tau[i__];
sscal_(&i__1, &r__1, &a[i__ + (i__ + 1) * a_dim1], lda);
}
a[i__ + i__ * a_dim1] = 1.f - tau[i__];
/* Set A(i,1:i-1) to zero */
i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) {
a[i__ + l * a_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of SORGL2 */
} /* sorgl2_ */
/* Subroutine */ int sorg2l_(integer *m, integer *n, integer *k, real *a,
integer *lda, real *tau, real *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
/* Local variables */
static integer i__, j, l, ii;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *, ftnlen), xerbla_(char *, integer *,
ftnlen);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SORG2L generates an m by n real matrix Q with orthonormal columns, */
/* which is defined as the last n columns of a product of k elementary */
/* reflectors of order m */
/* Q = H(k) . . . H(2) H(1) */
/* as returned by SGEQLF. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q. M >= N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. N >= K >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the (n-k+i)-th column must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
/* returned by SGEQLF in the last k columns of its array */
/* argument A. */
/* On exit, the m by n matrix Q. */
/* LDA (input) INTEGER */
/* The first dimension of the array A. LDA >= max(1,M). */
/* TAU (input) REAL array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by SGEQLF. */
/* WORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument has an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0 || *n > *m) {
*info = -2;
} else if (*k < 0 || *k > *n) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SORG2L", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
return 0;
}
/* Initialise columns 1:n-k to columns of the unit matrix */
i__1 = *n - *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (l = 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.f;
/* L10: */
}
a[*m - *n + j + j * a_dim1] = 1.f;
/* L20: */
}
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
ii = *n - *k + i__;
/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
a[*m - *n + ii + ii * a_dim1] = 1.f;
i__2 = *m - *n + ii;
i__3 = ii - 1;
slarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
a[a_offset], lda, &work[1], (ftnlen)4);
i__2 = *m - *n + ii - 1;
r__1 = -tau[i__];
sscal_(&i__2, &r__1, &a[ii * a_dim1 + 1], &c__1);
a[*m - *n + ii + ii * a_dim1] = 1.f - tau[i__];
/* Set A(m-k+i+1:m,n-k+i) to zero */
i__2 = *m;
for (l = *m - *n + ii + 1; l <= i__2; ++l) {
a[l + ii * a_dim1] = 0.f;
/* L30: */
}
/* L40: */
}
return 0;
/* End of SORG2L */
} /* sorg2l_ */