#include "f2c.h"
static integer c__1 = 1;
static integer c__0 = 0;
static integer c__6 = 6;
static integer c__4 = 4;
static integer c__8 = 8;
static integer c_n1 = -1;
static integer c__65 = 65;
static integer c__15 = 15;
static integer c__3 = 3;
static integer c__2 = 2;
static logical c_true = TRUE_;
static logical c_false = FALSE_;
static doublereal c_b21 = -1.;
static doublereal c_b3 = 2.;
static doublereal c_b38 = 0.;
static doublereal c_b26 = 0.;
static doublereal c_b10 = 1.;
static doublereal c_b15 = -.125;
static doublereal c_b8 = .125;
static doublereal c_b9 = 0.;
static doublereal c_b14 = 1.;
static doublereal c_b12 = 1.;
static doublereal c_b32 = 0.;
static doublereal c_b19 = -1.;
static doublereal c_b5a = 0.;
static doublereal c_b438 = 1.;
static doublereal c_b25 = -1.;
static doublereal c_b416 = 0.;
static doublereal c_b4a = .7;
static doublereal c_b4b = -1.;
static doublereal c_b3a = 1.;
static doublereal c_b8a = 0.;
static doublereal c_b71 = -1.;
static doublereal c_b108 = 1.;
static doublereal c_b74 = 0.;
static doublereal c_b16a = 1.;
static doublereal c_b23 = 1.;
static doublereal c_b4 = 1.;
static doublereal c_b5 = 1.;
static doublereal c_b6 = -1.;
static doublereal c_b22 = 1.;
static doublereal c_b16 = 0.;
static doublereal c_b48 = 1.;
/* dlahqr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dlahqr_(wantt, wantz, n, ilo, ihi, h__, ldh, wr, wi,
iloz, ihiz, z__, ldz, info)
logical *wantt, *wantz;
integer *n, *ilo, *ihi;
doublereal *h__;
integer *ldh;
doublereal *wr, *wi;
integer *iloz, *ihiz;
doublereal *z__;
integer *ldz, *info;
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Local variables */
static doublereal h43h34, unfl, ovfl;
extern /* Subroutine */ int drot_();
static doublereal work[1];
static integer i__, j, k, l, m;
static doublereal s, v[3];
extern /* Subroutine */ int dcopy_();
static integer i1, i2;
static doublereal t1, t2, t3, v1, v2, v3;
extern /* Subroutine */ int dlanv2_(), dlabad_();
static doublereal h00, h10, h11, h12, h21, h22, h33, h44;
static integer nh;
static doublereal cs;
extern doublereal dlamch_();
extern /* Subroutine */ int dlarfg_();
static integer nr;
static doublereal sn;
static integer nz;
extern doublereal dlanhs_();
static doublereal smlnum, h33s, h44s;
static integer itn, its;
static doublereal ulp, sum, tst1;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAHQR is an auxiliary routine called by DHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by DHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to IHI.
*/
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper quasi-triangular in */
/* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */
/* ILO = 1). DLAHQR works primarily with the Hessenberg */
/* submatrix in rows and columns ILO to IHI, but applies */
/* transformations to all of H if WANTT is .TRUE.. */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if WANTT is .TRUE., H is upper quasi-triangular in */
/* rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in
*/
/* standard form. If WANTT is .FALSE., the contents of H are */
/* unspecified on exit. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* WR (output) DOUBLE PRECISION array, dimension (N) */
/* WI (output) DOUBLE PRECISION array, dimension (N) */
/* The real and imaginary parts, respectively, of the computed */
/* eigenvalues ILO to IHI are stored in the corresponding */
/* elements of WR and WI. If two eigenvalues are computed as a */
/* complex conjugate pair, they are stored in consecutive */
/* elements of WR and WI, say the i-th and (i+1)th, with */
/* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the */
/* eigenvalues are stored in the same order as on the diagonal */
/* of the Schur form returned in H, with WR(i) = H(i,i), and, if
*/
/* H(i:i+1,i:i+1) is a 2-by-2 diagonal block, */
/* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. */
/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by DHSEQR, and on */
/* exit Z has been updated; transformations are applied only to
*/
/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/* If WANTZ is .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: DLAHQR failed to compute all the eigenvalues ILO to IHI
*/
/* in a total of 30*(IHI-ILO+1) iterations; if INFO = i, */
/* elements i+1:ihi of WR and WI contain those eigenvalues
*/
/* which have been successfully computed. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = h_dim1 + 1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = z_dim1 + 1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.;
return 0;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion. */
/* If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = dlamch_("Safe minimum", 12L);
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision", 9L);
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are
*/
/* being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
*/
/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L10:
l = *ilo;
if (i__ < *ilo) {
goto L150;
}
/* Perform QR iterations on rows and columns ILO to I until a */
/* submatrix of order 1 or 2 splits off at the bottom because a */
/* subdiagonal element has become negligible. */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 =
h__[k + k * h_dim1], abs(d__2));
if (tst1 == 0.) {
i__3 = i__ - l + 1;
tst1 = dlanhs_("1", &i__3, &h__[l + l * h_dim1], ldh, work,
1L);
}
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= max(d__2,
smlnum)) {
goto L30;
}
/* L20: */
}
L30:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible */
h__[l + (l - 1) * h_dim1] = 0.;
}
/* Exit from loop if a submatrix of order 1 or 2 has split off.
*/
if (l >= i__ - 1) {
goto L140;
}
/* Now the active submatrix is in rows and columns L to I. If
*/
/* eigenvalues only are being computed, only the active submatr
ix */
/* need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10 || its == 20) {
/* Exceptional shift. */
s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 =
h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2));
h44 = s * .75;
h33 = h44;
h43h34 = s * -.4375 * s;
} else {
/* Prepare to use Wilkinson's double shift */
h44 = h__[i__ + i__ * h_dim1];
h33 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h43h34 = h__[i__ + (i__ - 1) * h_dim1] * h__[i__ - 1 + i__ *
h_dim1];
}
/* Look for two consecutive small subdiagonal elements. */
i__2 = l;
for (m = i__ - 2; m >= i__2; --m) {
/* Determine the effect of starting the double-shift QR
*/
/* iteration at row M, and see if this would make H(M,M-
1) */
/* negligible. */
h11 = h__[m + m * h_dim1];
h22 = h__[m + 1 + (m + 1) * h_dim1];
h21 = h__[m + 1 + m * h_dim1];
h12 = h__[m + (m + 1) * h_dim1];
h44s = h44 - h11;
h33s = h33 - h11;
v1 = (h33s * h44s - h43h34) / h21 + h12;
v2 = h22 - h11 - h33s - h44s;
v3 = h__[m + 2 + (m + 1) * h_dim1];
s = abs(v1) + abs(v2) + abs(v3);
v1 /= s;
v2 /= s;
v3 /= s;
v[0] = v1;
v[1] = v2;
v[2] = v3;
if (m == l) {
goto L50;
}
h00 = h__[m - 1 + (m - 1) * h_dim1];
h10 = h__[m + (m - 1) * h_dim1];
tst1 = abs(v1) * (abs(h00) + abs(h11) + abs(h22));
if (abs(h10) * (abs(v2) + abs(v3)) <= ulp * tst1) {
goto L50;
}
/* L40: */
}
L50:
/* Double-shift QR step */
i__2 = i__ - 1;
for (k = m; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflect
ion G */
/* from the vector V and applies it from left and right
to H, */
/* thus creating a nonzero bulge below the subdiagonal.
*/
/* Each subsequent iteration determines a reflection G t
o */
/* restore the Hessenberg form in the (K-1)th column, an
d thus */
/* chases the bulge one step toward the bottom of the ac
tive */
/* submatrix. NR is the order of G. */
/* Computing MIN */
i__3 = 3, i__4 = i__ - k + 1;
nr = min(i__3,i__4);
if (k > m) {
dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
dlarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.;
}
} else if (m > l) {
h__[k + (k - 1) * h_dim1] = -h__[k + (k - 1) * h_dim1];
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* Apply G from the left to transform the rows of
the matrix */
/* in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
/* L60: */
}
/* Apply G from the right to transform the column
s of the */
/* matrix in rows I1 to min(K+3,I). */
/* Computing MIN */
i__4 = k + 3;
i__3 = min(i__4,i__);
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
/* L70: */
}
if (*wantz) {
/* Accumulate transformations in the matri
x Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1] + v3 * z__[j + (k + 2) * z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
z__[j + (k + 2) * z_dim1] -= sum * t3;
/* L80: */
}
}
} else if (nr == 2) {
/* Apply G from the left to transform the rows of
the matrix */
/* in columns K to I2. */
i__3 = i2;
for (j = k; j <= i__3; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
/* L90: */
}
/* Apply G from the right to transform the column
s of the */
/* matrix in rows I1 to min(K+3,I). */
i__3 = i__;
for (j = i1; j <= i__3; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
;
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
/* L100: */
}
if (*wantz) {
/* Accumulate transformations in the matri
x Z */
i__3 = *ihiz;
for (j = *iloz; j <= i__3; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
/* L110: */
}
}
}
/* L120: */
}
/* L130: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L140:
if (l == i__) {
/* H(I,I-1) is negligible: one eigenvalue has converged. */
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
} else if (l == i__ - 1) {
/* H(I-1,I-2) is negligible: a pair of eigenvalues have converg
ed. */
/* Transform the 2-by-2 submatrix to standard Schur form, */
/* and compute and store the eigenvalues. */
dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
&sn);
if (*wantt) {
/* Apply the transformation to the rest of H. */
if (i2 > i__) {
i__1 = i2 - i__;
drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
h_dim1], &c__1, &cs, &sn);
}
if (*wantz) {
/* Apply the transformation to Z. */
drot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz +
i__ * z_dim1], &c__1, &cs, &sn);
}
}
/* Decrement number of remaining iterations, and return to start of */
/* the main loop with new value of I. */
itn -= its;
i__ = l - 1;
goto L10;
L150:
return 0;
/* End of DLAHQR */
} /* dlahqr_ */
/* dorg2r.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dorg2r_(m, n, k, a, lda, tau, work, info)
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
static integer i__, j, l;
extern /* Subroutine */ int dscal_(), dlarf_(), xerbla_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORG2R generates an m by n real matrix Q with orthonormal columns, */
/* which is defined as the first n columns of a product of k elementary
*/
/* reflectors of order m */
/* Q = H(1) H(2) . . . H(k) */
/* as returned by DGEQRF. */
/* 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the i-th column must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as
*/
/* returned by DGEQRF in the first 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) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DGEQRF. */
/* WORK (workspace) DOUBLE PRECISION 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 = a_dim1 + 1;
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_("DORG2R", &i__1, 6L);
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.;
/* L10: */
}
a[j + j * a_dim1] = 1.;
/* 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.;
i__1 = *m - i__ + 1;
i__2 = *n - i__;
dlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L);
}
if (i__ < *m) {
i__1 = *m - i__;
d__1 = -tau[i__];
dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
}
a[i__ + i__ * a_dim1] = 1. - 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.;
/* L30: */
}
/* L40: */
}
return 0;
/* End of DORG2R */
} /* dorg2r_ */
/* dlaset.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlaset_(uplo, m, n, alpha, beta, a, lda, uplo_len)
char *uplo;
integer *m, *n;
doublereal *alpha, *beta, *a;
integer *lda;
ftnlen uplo_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j;
extern logical lsame_();
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASET initializes an m-by-n matrix A to BETA on the diagonal and */
/* ALPHA on the offdiagonals. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies the part of the matrix A to be set. */
/* = 'U': Upper triangular part is set; the strictly lower
*/
/* triangular part of A is not changed. */
/* = 'L': Lower triangular part is set; the strictly upper
*/
/* triangular part of A is not changed. */
/* Otherwise: All of the matrix A is set. */
/* 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. */
/* ALPHA (input) DOUBLE PRECISION */
/* The constant to which the offdiagonal elements are to be set.
*/
/* BETA (input) DOUBLE PRECISION */
/* The constant to which the diagonal elements are to be set. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On exit, the leading m-by-n submatrix of A is set as follows:
*/
/* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, */
/* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, */
/* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, */
/* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
if (lsame_(uplo, "U", 1L, 1L)) {
/* Set the strictly upper triangular or trapezoidal part of the
*/
/* array to ALPHA. */
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j - 1;
i__2 = min(i__3,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L10: */
}
/* L20: */
}
} else if (lsame_(uplo, "L", 1L, 1L)) {
/* Set the strictly lower triangular or trapezoidal part of the
*/
/* array to ALPHA. */
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L30: */
}
/* L40: */
}
} else {
/* Set the leading m-by-n submatrix to ALPHA. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = *alpha;
/* L50: */
}
/* L60: */
}
}
/* Set the first min(M,N) diagonal elements to BETA. */
i__1 = min(*m,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
a[i__ + i__ * a_dim1] = *beta;
/* L70: */
}
return 0;
/* End of DLASET */
} /* dlaset_ */
/* dlanhs.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
doublereal dlanhs_(norm, n, a, lda, work, norm_len)
char *norm;
integer *n;
doublereal *a;
integer *lda;
doublereal *work;
ftnlen norm_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt();
/* Local variables */
static integer i__, j;
static doublereal scale;
extern logical lsame_();
static doublereal value;
extern /* Subroutine */ int dlassq_();
static doublereal sum;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANHS returns the value of the one norm, or the Frobenius norm, or
*/
/* the infinity norm, or the element of largest absolute value of a
*/
/* Hessenberg matrix A. */
/* Description */
/* =========== */
/* DLANHS returns the value */
/* DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum),
*/
/* normI denotes the infinity norm of a matrix (maximum row sum) and
*/
/* normF denotes the Frobenius norm of a matrix (square root of sum of
*/
/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANHS as described */
/* above. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. When N = 0, DLANHS is */
/* set to zero. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The n by n upper Hessenberg matrix A; the part of A below the
*/
/* first sub-diagonal is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(N,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */
/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--work;
/* Function Body */
if (*n == 0) {
value = 0.;
} else if (lsame_(norm, "M", 1L, 1L)) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
value = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I", 1L, 1L)) {
/* Find normI(A). */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = *n, i__4 = j + 1;
i__2 = min(i__3,i__4);
dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANHS */
} /* dlanhs_ */
/* dgeqr2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dgeqr2_(m, n, a, lda, tau, work, info)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, k;
extern /* Subroutine */ int dlarf_(), dlarfg_(), xerbla_();
static doublereal aii;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEQR2 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). */
/* WORK (workspace) DOUBLE PRECISION 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 = a_dim1 + 1;
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_("DGEQR2", &i__1, 6L);
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;
dlarfg_(&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.;
i__2 = *m - i__ + 1;
i__3 = *n - i__;
dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L);
a[i__ + i__ * a_dim1] = aii;
}
/* L10: */
}
return 0;
/* End of DGEQR2 */
} /* dgeqr2_ */
/* dlarfg.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlarfg_(n, alpha, x, incx, tau)
integer *n;
doublereal *alpha, *x;
integer *incx;
doublereal *tau;
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double d_sign();
/* Local variables */
static doublereal beta;
extern doublereal dnrm2_();
static integer j;
extern /* Subroutine */ int dscal_();
static doublereal xnorm;
extern doublereal dlapy2_(), dlamch_();
static doublereal safmin, rsafmn;
static integer knt;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARFG generates a real elementary reflector H of order n, such */
/* that */
/* H * ( alpha ) = ( beta ), H' * H = I. */
/* ( x ) ( 0 ) */
/* where alpha and beta are scalars, and x is an (n-1)-element real */
/* vector. H is represented in the form */
/* H = I - tau * ( 1 ) * ( 1 v' ) , */
/* ( v ) */
/* where tau is a real scalar and v is a real (n-1)-element */
/* vector. */
/* If the elements of x are all zero, then tau = 0 and H is taken to be
*/
/* the unit matrix. */
/* Otherwise 1 <= tau <= 2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the elementary reflector. */
/* ALPHA (input/output) DOUBLE PRECISION */
/* On entry, the value alpha. */
/* On exit, it is overwritten with the value beta. */
/* X (input/output) DOUBLE PRECISION array, dimension */
/* (1+(N-2)*abs(INCX)) */
/* On entry, the vector x. */
/* On exit, it is overwritten with the vector v. */
/* INCX (input) INTEGER */
/* The increment between elements of X. INCX > 0. */
/* TAU (output) DOUBLE PRECISION */
/* The value tau. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n <= 1) {
*tau = 0.;
return 0;
}
i__1 = *n - 1;
xnorm = dnrm2_(&i__1, &x[1], incx);
if (xnorm == 0.) {
/* H = I */
*tau = 0.;
} else {
/* general case */
d__1 = dlapy2_(alpha, &xnorm);
beta = -d_sign(&d__1, alpha);
safmin = dlamch_("S", 1L) / dlamch_("E", 1L);
if (abs(beta) < safmin) {
/* XNORM, BETA may be inaccurate; scale X and recompute
them */
rsafmn = 1. / safmin;
knt = 0;
L10:
++knt;
i__1 = *n - 1;
dscal_(&i__1, &rsafmn, &x[1], incx);
beta *= rsafmn;
*alpha *= rsafmn;
if (abs(beta) < safmin) {
goto L10;
}
/* New BETA is at most 1, at least SAFMIN */
i__1 = *n - 1;
xnorm = dnrm2_(&i__1, &x[1], incx);
d__1 = dlapy2_(alpha, &xnorm);
beta = -d_sign(&d__1, alpha);
*tau = (beta - *alpha) / beta;
i__1 = *n - 1;
d__1 = 1. / (*alpha - beta);
dscal_(&i__1, &d__1, &x[1], incx);
/* If ALPHA is subnormal, it may lose relative accuracy
*/
*alpha = beta;
i__1 = knt;
for (j = 1; j <= i__1; ++j) {
*alpha *= safmin;
/* L20: */
}
} else {
*tau = (beta - *alpha) / beta;
i__1 = *n - 1;
d__1 = 1. / (*alpha - beta);
dscal_(&i__1, &d__1, &x[1], incx);
*alpha = beta;
}
}
return 0;
/* End of DLARFG */
} /* dlarfg_ */
/* dgelqf.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dgelqf_(m, n, a, lda, tau, work, lwork, info)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__, k, nbmin, iinfo;
extern /* Subroutine */ int dgelq2_();
static integer ib, nb;
extern /* Subroutine */ int dlarfb_();
static integer nx;
extern /* Subroutine */ int dlarft_(), xerbla_();
extern integer ilaenv_();
static integer ldwork, iws;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGELQF computes an LQ factorization of a real M-by-N matrix A: */
/* A = L * 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the elements on and below the diagonal of the array
*/
/* contain the m-by-min(m,n) lower trapezoidal matrix L (L is */
/* lower triangular if m <= n); the elements above 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) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,M). */
/* For optimum performance LWORK >= M*NB, where NB is the */
/* optimal blocksize. */
/* 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(k) . . . H(2) H(1), 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:n) is stored on exit in A(i,i+1:n),
*/
/* and tau in TAU(i). */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
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;
} else if (*lwork < max(1,*m)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGELQF", &i__1, 6L);
return 0;
}
/* Quick return if possible */
k = min(*m,*n);
if (k == 0) {
work[1] = 1.;
return 0;
}
/* Determine the block size. */
nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
nbmin = 2;
nx = 0;
iws = *m;
if (nb > 1 && nb < k) {
/* Determine when to cross over from blocked to unblocked code.
*/
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "DGELQF", " ", m, n, &c_n1, &c_n1, 6L,
1L);
nx = max(i__1,i__2);
if (nx < k) {
/* Determine if workspace is large enough for blocked co
de. */
ldwork = *m;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduc
e NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "DGELQF", " ", m, n, &c_n1, &
c_n1, 6L, 1L);
nbmin = max(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */
i__1 = k - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = k - i__ + 1;
ib = min(i__3,nb);
/* Compute the LQ factorization of the current block */
/* A(i:i+ib-1,i:n) */
i__3 = *n - i__ + 1;
dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
1], &iinfo);
if (i__ + ib <= *m) {
/* Form the triangular factor of the block reflec
tor */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__3 = *n - i__ + 1;
dlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 7L);
/* Apply H to A(i+ib:m,i:n) from the right */
i__3 = *m - i__ - ib + 1;
i__4 = *n - i__ + 1;
dlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3,
&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
1], &ldwork, 5L, 12L, 7L, 7L);
}
/* L10: */
}
} else {
i__ = 1;
}
/* Use unblocked code to factor the last or only block. */
if (i__ <= k) {
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo);
}
work[1] = (doublereal) iws;
return 0;
/* End of DGELQF */
} /* dgelqf_ */
/* dlange.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
doublereal dlange_(norm, m, n, a, lda, work, norm_len)
char *norm;
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *work;
ftnlen norm_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt();
/* Local variables */
static integer i__, j;
static doublereal scale;
extern logical lsame_();
static doublereal value;
extern /* Subroutine */ int dlassq_();
static doublereal sum;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANGE returns the value of the one norm, or the Frobenius norm, or
*/
/* the infinity norm, or the element of largest absolute value of a
*/
/* real matrix A. */
/* Description */
/* =========== */
/* DLANGE returns the value */
/* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
/* ( */
/* ( norm1(A), NORM = '1', 'O' or 'o' */
/* ( */
/* ( normI(A), NORM = 'I' or 'i' */
/* ( */
/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
/* where norm1 denotes the one norm of a matrix (maximum column sum),
*/
/* normI denotes the infinity norm of a matrix (maximum row sum) and
*/
/* normF denotes the Frobenius norm of a matrix (square root of sum of
*/
/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies the value to be returned in DLANGE as described */
/* above. */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. When M = 0, */
/* DLANGE is set to zero. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. When N = 0,
*/
/* DLANGE is set to zero. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The m by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(M,1). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */
/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
/* referenced. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0) {
value = 0.;
} else if (lsame_(norm, "M", 1L, 1L)) {
/* Find max(abs(A(i,j))). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
value = max(d__2,d__3);
/* L10: */
}
/* L20: */
}
} else if (lsame_(norm, "O", 1L, 1L) || *(unsigned char *)norm == '1') {
/* Find norm1(A). */
value = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sum = 0.;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L30: */
}
value = max(value,sum);
/* L40: */
}
} else if (lsame_(norm, "I", 1L, 1L)) {
/* Find normI(A). */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.;
/* L50: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
/* L60: */
}
/* L70: */
}
value = 0.;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = value, d__2 = work[i__];
value = max(d__1,d__2);
/* L80: */
}
} else if (lsame_(norm, "F", 1L, 1L) || lsame_(norm, "E", 1L, 1L)) {
/* Find normF(A). */
scale = 0.;
sum = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
/* L90: */
}
value = scale * sqrt(sum);
}
ret_val = value;
return ret_val;
/* End of DLANGE */
} /* dlange_ */
/* dgehrd.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b21
#undef c_b21
#endif
#define c_b21 c_b21
#ifdef c_b22
#undef c_b22
#endif
#define c_b22 c_b22
/* Subroutine */ int dgehrd_(n, ilo, ihi, a, lda, tau, work, lwork, info)
integer *n, *ilo, *ihi;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__;
static doublereal t[4160] /* was [65][64] */;
extern /* Subroutine */ int dgemm_();
static integer nbmin, iinfo;
extern /* Subroutine */ int dgehd2_();
static integer ib;
static doublereal ei;
static integer nb, nh;
extern /* Subroutine */ int dlarfb_(), dlahrd_();
static integer nx;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
static integer ldwork, iws;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEHRD 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 DGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* A (input/output) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */
/* zero. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,N). */
/* For optimum performance LWORK >= N*NB, where NB is the */
/* optimal blocksize. */
/* 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 .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 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;
} else if (*lwork < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEHRD", &i__1, 6L);
return 0;
}
/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
tau[i__] = 0.;
/* L10: */
}
i__1 = *n - 1;
for (i__ = max(1,*ihi); i__ <= i__1; ++i__) {
tau[i__] = 0.;
/* L20: */
}
/* Quick return if possible */
nh = *ihi - *ilo + 1;
if (nh <= 1) {
work[1] = 1.;
return 0;
}
/* Determine the block size. */
/* Computing MIN */
i__1 = 64, i__2 = ilaenv_(&c__1, "DGEHRD", " ", n, ilo, ihi, &c_n1, 6L,
1L);
nb = min(i__1,i__2);
nbmin = 2;
iws = 1;
if (nb > 1 && nb < nh) {
/* Determine when to cross over from blocked to unblocked code
*/
/* (last block is always handled by unblocked code). */
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "DGEHRD", " ", n, ilo, ihi, &c_n1,
6L, 1L);
nx = max(i__1,i__2);
if (nx < nh) {
/* Determine if workspace is large enough for blocked co
de. */
iws = *n * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: deter
mine the */
/* minimum value of NB, and reduce NB or force us
e of */
/* unblocked code. */
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "DGEHRD", " ", n, ilo, ihi, &
c_n1, 6L, 1L);
nbmin = max(i__1,i__2);
if (*lwork >= *n * nbmin) {
nb = *lwork / *n;
} else {
nb = 1;
}
}
}
}
ldwork = *n;
if (nb < nbmin || nb >= nh) {
/* Use unblocked code below */
i__ = *ilo;
} else {
/* Use blocked code */
i__1 = *ihi - 1 - nx;
i__2 = nb;
for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *ihi - i__;
ib = min(i__3,i__4);
/* Reduce columns i:i+ib-1 to Hessenberg form, returning
the */
/* matrices V and T of the block reflector H = I - V*T*V
' */
/* which performs the reduction, and also the matrix Y =
A*V*T */
dlahrd_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, &
c__65, &work[1], &ldwork);
/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from
the */
/* right, computing A := A - Y * V'. V(i+ib,ib-1) must
be set */
/* to 1. */
ei = a[i__ + ib + (i__ + ib - 1) * a_dim1];
a[i__ + ib + (i__ + ib - 1) * a_dim1] = 1.;
i__3 = *ihi - i__ - ib + 1;
dgemm_("No transpose", "Transpose", ihi, &i__3, &ib, &c_b21, &
work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, &
c_b22, &a[(i__ + ib) * a_dim1 + 1], lda, 12L, 9L);
a[i__ + ib + (i__ + ib - 1) * a_dim1] = ei;
/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from
the */
/* left */
i__3 = *ihi - i__;
i__4 = *n - i__ - ib + 1;
dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &c__65, &a[
i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &ldwork,
4L, 9L, 7L, 10L);
/* L30: */
}
}
/* Use unblocked code to reduce the rest of the matrix */
dgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
work[1] = (doublereal) iws;
return 0;
/* End of DGEHRD */
} /* dgehrd_ */
/* dlasq1.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b8
#undef c_b8
#endif
#define c_b8 c_b8
/* Subroutine */ int dlasq1_(n, d__, e, work, info)
integer *n;
doublereal *d__, *e, *work;
integer *info;
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(), sqrt();
/* Local variables */
static integer kend, ierr;
extern /* Subroutine */ int dlas2_();
static integer i__, j, m;
static doublereal sfmin, sigmn;
extern /* Subroutine */ int dcopy_();
static doublereal sigmx;
extern /* Subroutine */ int dlasq2_();
static doublereal small2;
static integer ke;
static doublereal dm;
extern doublereal dlamch_();
static doublereal dx;
extern /* Subroutine */ int dlascl_();
static integer ny;
extern /* Subroutine */ int xerbla_(), dlasrt_();
static doublereal thresh, tolmul;
static logical restrt;
static doublereal scl, eps, tol, sig1, sig2, tol2;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASQ1 computes the singular values of a real N-by-N bidiagonal */
/* matrix with diagonal D and off-diagonal E. The singular values are
*/
/* computed to high relative accuracy, barring over/underflow or */
/* denormalization. The algorithm is described in */
/* "Accurate singular values and differential qd algorithms," by */
/* K. V. Fernando and B. N. Parlett, */
/* Numer. Math., Vol-67, No. 2, pp. 191-230,1994. */
/* See also */
/* "Implementation of differential qd algorithms," by */
/* K. V. Fernando and B. N. Parlett, Technical Report, */
/* Department of Mathematics, University of California at Berkeley, */
/* 1994 (Under preparation). */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of rows and columns in the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, D contains the diagonal elements of the */
/* bidiagonal matrix whose SVD is desired. On normal exit, */
/* D contains the singular values in decreasing order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, elements E(1:N-1) contain the off-diagonal elements
*/
/* of the bidiagonal matrix whose SVD is desired. */
/* On exit, E is overwritten. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the algorithm did not converge; i */
/* specifies how many superdiagonals did not converge. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--work;
--e;
--d__;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -2;
i__1 = -(*info);
xerbla_("DLASQ1", &i__1, 6L);
return 0;
} else if (*n == 0) {
return 0;
} else if (*n == 1) {
d__[1] = abs(d__[1]);
return 0;
} else if (*n == 2) {
dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx);
d__[1] = sigmx;
d__[2] = sigmn;
return 0;
}
/* Estimate the largest singular value */
sigmx = 0.;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1));
sigmx = max(d__2,d__3);
/* L10: */
}
/* Early return if sigmx is zero (matrix is already diagonal) */
if (sigmx == 0.) {
goto L70;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = (d__1 = d__[i__], abs(d__1));
/* Computing MAX */
d__1 = sigmx, d__2 = d__[i__];
sigmx = max(d__1,d__2);
/* L20: */
}
/* Get machine parameters */
eps = dlamch_("EPSILON", 7L);
sfmin = dlamch_("SAFE MINIMUM", 12L);
/* Compute singular values to relative accuracy TOL */
/* It is assumed that tol**2 does not underflow. */
/* Computing MAX */
/* Computing MIN */
d__3 = 100., d__4 = pow_dd(&eps, &c_b8);
d__1 = 10., d__2 = min(d__3,d__4);
tolmul = max(d__1,d__2);
tol = tolmul * eps;
/* Computing 2nd power */
d__1 = tol;
tol2 = d__1 * d__1;
thresh = sigmx * sqrt(sfmin) * tol;
/* Scale matrix so the square of the largest element is */
/* 1 / ( 256 * SFMIN ) */
scl = sqrt(1. / (sfmin * 256.));
/* Computing 2nd power */
d__1 = tolmul;
small2 = 1. / (d__1 * d__1 * 256.);
dcopy_(n, &d__[1], &c__1, &work[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &work[*n + 1], &c__1);
dlascl_("G", &c__0, &c__0, &sigmx, &scl, n, &c__1, &work[1], n, &ierr, 1L)
;
i__1 = *n - 1;
i__2 = *n - 1;
dlascl_("G", &c__0, &c__0, &sigmx, &scl, &i__1, &c__1, &work[*n + 1], &
i__2, &ierr, 1L);
/* Square D and E (the input for the qd algorithm) */
i__1 = (*n << 1) - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing 2nd power */
d__1 = work[j];
work[j] = d__1 * d__1;
/* L30: */
}
/* Apply qd algorithm */
m = 0;
e[*n] = 0.;
dx = work[1];
dm = dx;
ke = 0;
restrt = FALSE_;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((d__1 = e[i__], abs(d__1)) <= thresh || work[*n + i__] <= tol2 * (
dm / (doublereal) (i__ - m))) {
ny = i__ - m;
if (ny == 1) {
goto L50;
} else if (ny == 2) {
dlas2_(&d__[m + 1], &e[m + 1], &d__[m + 2], &sig1, &sig2);
d__[m + 1] = sig1;
d__[m + 2] = sig2;
} else {
kend = ke + 1 - m;
dlasq2_(&ny, &d__[m + 1], &e[m + 1], &work[m + 1], &work[m + *
n + 1], &eps, &tol2, &small2, &dm, &kend, info);
/* Return, INFO = number of unconverged superd
iagonals */
if (*info != 0) {
*info += i__;
return 0;
}
/* Undo scaling */
i__2 = m + ny;
for (j = m + 1; j <= i__2; ++j) {
d__[j] = sqrt(d__[j]);
/* L40: */
}
dlascl_("G", &c__0, &c__0, &scl, &sigmx, &ny, &c__1, &d__[m +
1], &ny, &ierr, 1L);
}
L50:
m = i__;
if (i__ != *n) {
dx = work[i__ + 1];
dm = dx;
ke = i__;
restrt = TRUE_;
}
}
if (i__ != *n && ! restrt) {
dx = work[i__ + 1] * (dx / (dx + work[*n + i__]));
if (dm > dx) {
dm = dx;
ke = i__;
}
}
restrt = FALSE_;
/* L60: */
}
kend = ke + 1;
/* Sort the singular values into decreasing order */
L70:
dlasrt_("D", n, &d__[1], info, 1L);
return 0;
/* End of DLASQ1 */
} /* dlasq1_ */
/* dlarft.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b8
#undef c_b8
#endif
#define c_b8 c_b8a
/* Subroutine */ int dlarft_(direct, storev, n, k, v, ldv, tau, t, ldt,
direct_len, storev_len)
char *direct, *storev;
integer *n, *k;
doublereal *v;
integer *ldv;
doublereal *tau, *t;
integer *ldt;
ftnlen direct_len;
ftnlen storev_len;
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
static integer i__, j;
extern logical lsame_();
extern /* Subroutine */ int dgemv_(), dtrmv_();
static doublereal vii;
/* -- LAPACK auxiliary routine (version 2.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 */
/* ======= */
/* DLARFT forms the triangular factor T of a real block reflector H */
/* of order n, which is defined as a product of k elementary reflectors.
*/
/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
*/
/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
*/
/* If STOREV = 'C', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th column of the array V, and */
/* H = I - V * T * V' */
/* If STOREV = 'R', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th row of the array V, and */
/* H = I - V' * T * V */
/* Arguments */
/* ========= */
/* DIRECT (input) CHARACTER*1 */
/* Specifies the order in which the elementary reflectors are */
/* multiplied to form the block reflector: */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Specifies how the vectors which define the elementary */
/* reflectors are stored (see also Further Details): */
/* = 'C': columnwise */
/* = 'R': rowwise */
/* N (input) INTEGER */
/* The order of the block reflector H. N >= 0. */
/* K (input) INTEGER */
/* The order of the triangular factor T (= the number of */
/* elementary reflectors). K >= 1. */
/* V (input/output) DOUBLE PRECISION array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,N) if STOREV = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
*/
/* TAU (input) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i). */
/* T (output) DOUBLE PRECISION array, dimension (LDT,K) */
/* The k by k triangular factor T of the block reflector. */
/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
*/
/* lower triangular. The rest of the array is not used. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* Further Details */
/* =============== */
/* The shape of the matrix V and the storage of the vectors which define
*/
/* the H(i) is best illustrated by the following example with n = 5 and
*/
/* k = 3. The elements equal to 1 are not stored; the corresponding */
/* array elements are modified but restored on exit. The rest of the */
/* array is not used. */
/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
*/
/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
*/
/* ( v1 1 ) ( 1 v2 v2 v2 )
*/
/* ( v1 v2 1 ) ( 1 v3 v3 )
*/
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
*/
/* V = ( v1 v2 v3 ) V = ( v1 v1 1 )
*/
/* ( v1 v2 v3 ) ( v2 v2 v2 1 )
*/
/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
*/
/* ( 1 v3 ) */
/* ( 1 ) */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = v_dim1 + 1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = t_dim1 + 1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
if (tau[i__] == 0.) {
/* H(i) = I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
t[j + i__ * t_dim1] = 0.;
/* L10: */
}
} else {
/* general case */
vii = v[i__ + i__ * v_dim1];
v[i__ + i__ * v_dim1] = 1.;
if (lsame_(storev, "C", 1L, 1L)) {
/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)'
* V(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
d__1 = -tau[i__];
dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1],
ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[
i__ * t_dim1 + 1], &c__1, 9L);
} else {
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) *
V(i,i:n)' */
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
d__1 = -tau[i__];
dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ *
v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
c_b8, &t[i__ * t_dim1 + 1], &c__1, 12L);
}
v[i__ + i__ * v_dim1] = vii;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, 5L, 12L,
8L);
t[i__ + i__ * t_dim1] = tau[i__];
}
/* L20: */
}
} else {
for (i__ = *k; i__ >= 1; --i__) {
if (tau[i__] == 0.) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
t[j + i__ * t_dim1] = 0.;
/* L30: */
}
} else {
/* general case */
if (i__ < *k) {
if (lsame_(storev, "C", 1L, 1L)) {
vii = v[*n - *k + i__ + i__ * v_dim1];
v[*n - *k + i__ + i__ * v_dim1] = 1.;
/* T(i+1:k,i) := */
/* - tau(i) * V(1:n-k+i,i+1
:k)' * V(1:n-k+i,i) */
i__1 = *n - *k + i__;
i__2 = *k - i__;
d__1 = -tau[i__];
dgemv_("Transpose", &i__1, &i__2, &d__1, &v[(i__ + 1)
* v_dim1 + 1], ldv, &v[i__ * v_dim1 + 1], &
c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], &
c__1, 9L);
v[*n - *k + i__ + i__ * v_dim1] = vii;
} else {
vii = v[i__ + (*n - *k + i__) * v_dim1];
v[i__ + (*n - *k + i__) * v_dim1] = 1.;
/* T(i+1:k,i) := */
/* - tau(i) * V(i+1:k,1:n-k
+i) * V(i,1:n-k+i)' */
i__1 = *k - i__;
i__2 = *n - *k + i__;
d__1 = -tau[i__];
dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ +
1 + v_dim1], ldv, &v[i__ + v_dim1], ldv, &
c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1, 12L);
v[i__ + (*n - *k + i__) * v_dim1] = vii;
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,
i) */
i__1 = *k - i__;
dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
t_dim1], &c__1, 5L, 12L, 8L);
}
t[i__ + i__ * t_dim1] = tau[i__];
}
/* L40: */
}
}
return 0;
/* End of DLARFT */
} /* dlarft_ */
/* dgebd2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dgebd2_(m, n, a, lda, d__, e, tauq, taup, work, info)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *d__, *e, *tauq, *taup, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__;
extern /* Subroutine */ int dlarf_(), dlarfg_(), xerbla_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEBD2 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The diagonal elements of the bidiagonal matrix B: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION 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) DOUBLE PRECISION array dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix Q. See Further Details. */
/* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix P. See Further Details. */
/* WORK (workspace) DOUBLE PRECISION 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 = a_dim1 + 1;
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_("DGEBD2", &i__1, 6L);
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;
dlarfg_(&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.;
/* Apply H(i) to A(i:m,i+1:n) from the left */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tauq[
i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1], 4L);
a[i__ + i__ * a_dim1] = d__[i__];
if (i__ < *n) {
/* Generate elementary reflector G(i) to annihila
te */
/* A(i,i+2:n) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&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.;
/* Apply G(i) to A(i+1:m,i+1:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__;
dlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
lda, &work[1], 5L);
a[i__ + (i__ + 1) * a_dim1] = e[i__];
} else {
taup[i__] = 0.;
}
/* 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;
dlarfg_(&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.;
/* Apply G(i) to A(i+1:m,i:n) from the right */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
/* Computing MIN */
i__4 = i__ + 1;
dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &taup[
i__], &a[min(i__4,*m) + i__ * a_dim1], lda, &work[1], 5L);
a[i__ + i__ * a_dim1] = d__[i__];
if (i__ < *m) {
/* Generate elementary reflector H(i) to annihila
te */
/* A(i+2:m,i) */
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&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.;
/* Apply H(i) to A(i+1:m,i+1:n) from the left */
i__2 = *m - i__;
i__3 = *n - i__;
dlarf_("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], 4L);
a[i__ + 1 + i__ * a_dim1] = e[i__];
} else {
tauq[i__] = 0.;
}
/* L20: */
}
}
return 0;
/* End of DGEBD2 */
} /* dgebd2_ */
/* dlas2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlas2_(f, g, h__, ssmin, ssmax)
doublereal *f, *g, *h__, *ssmin, *ssmax;
{
/* System generated locals */
doublereal d__1, d__2;
/* Builtin functions */
double sqrt();
/* Local variables */
static doublereal fhmn, fhmx, c__, fa, ga, ha, as, at, au;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAS2 computes the singular values of the 2-by-2 matrix */
/* [ F G ] */
/* [ 0 H ]. */
/* On return, SSMIN is the smaller singular value and SSMAX is the */
/* larger singular value. */
/* Arguments */
/* ========= */
/* F (input) DOUBLE PRECISION */
/* The (1,1) element of the 2-by-2 matrix. */
/* G (input) DOUBLE PRECISION */
/* The (1,2) element of the 2-by-2 matrix. */
/* H (input) DOUBLE PRECISION */
/* The (2,2) element of the 2-by-2 matrix. */
/* SSMIN (output) DOUBLE PRECISION */
/* The smaller singular value. */
/* SSMAX (output) DOUBLE PRECISION */
/* The larger singular value. */
/* Further Details */
/* =============== */
/* Barring over/underflow, all output quantities are correct to within */
/* a few units in the last place (ulps), even in the absence of a guard
*/
/* digit in addition/subtraction. */
/* In IEEE arithmetic, the code works correctly if one matrix element is
*/
/* infinite. */
/* Overflow will not occur unless the largest singular value itself */
/* overflows, or is within a few ulps of overflow. (On machines with */
/* partial overflow, like the Cray, overflow may occur if the largest */
/* singular value is within a factor of 2 of overflow.) */
/* Underflow is harmless if underflow is gradual. Otherwise, results */
/* may correspond to a matrix modified by perturbations of size near */
/* the underflow threshold. */
/* ====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
fa = abs(*f);
ga = abs(*g);
ha = abs(*h__);
fhmn = min(fa,ha);
fhmx = max(fa,ha);
if (fhmn == 0.) {
*ssmin = 0.;
if (fhmx == 0.) {
*ssmax = ga;
} else {
/* Computing 2nd power */
d__1 = min(fhmx,ga) / max(fhmx,ga);
*ssmax = max(fhmx,ga) * sqrt(d__1 * d__1 + 1.);
}
} else {
if (ga < fhmx) {
as = fhmn / fhmx + 1.;
at = (fhmx - fhmn) / fhmx;
/* Computing 2nd power */
d__1 = ga / fhmx;
au = d__1 * d__1;
c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au));
*ssmin = fhmn * c__;
*ssmax = fhmx / c__;
} else {
au = fhmx / ga;
if (au == 0.) {
/* Avoid possible harmful underflow if exponent r
ange */
/* asymmetric (true SSMIN may not underflow even
if */
/* AU underflows) */
*ssmin = fhmn * fhmx / ga;
*ssmax = ga;
} else {
as = fhmn / fhmx + 1.;
at = (fhmx - fhmn) / fhmx;
/* Computing 2nd power */
d__1 = as * au;
/* Computing 2nd power */
d__2 = at * au;
c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.));
*ssmin = fhmn * c__ * au;
*ssmin += *ssmin;
*ssmax = ga / (c__ + c__);
}
}
}
return 0;
/* End of DLAS2 */
} /* dlas2_ */
/* dlartg.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlartg_(f, g, cs, sn, r__)
doublereal *f, *g, *cs, *sn, *r__;
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double log(), pow_di(), sqrt();
/* Local variables */
static integer i__;
static doublereal scale;
static integer count;
static doublereal f1, g1, safmn2, safmx2;
extern doublereal dlamch_();
static doublereal safmin, eps;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARTG generate a plane rotation so that */
/* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. */
/* [ -SN CS ] [ G ] [ 0 ] */
/* This is a slower, more accurate version of the BLAS1 routine DROTG, */
/* with the following other differences: */
/* F and G are unchanged on return. */
/* If G=0, then CS=1 and SN=0. */
/* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any */
/* floating point operations (saves work in DBDSQR when */
/* there are zeros on the diagonal). */
/* If F exceeds G in magnitude, CS will be positive. */
/* Arguments */
/* ========= */
/* F (input) DOUBLE PRECISION */
/* The first component of vector to be rotated. */
/* G (input) DOUBLE PRECISION */
/* The second component of vector to be rotated. */
/* CS (output) DOUBLE PRECISION */
/* The cosine of the rotation. */
/* SN (output) DOUBLE PRECISION */
/* The sine of the rotation. */
/* R (output) DOUBLE PRECISION */
/* The nonzero component of the rotated vector. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
if (first) {
first = FALSE_;
safmin = dlamch_("S", 1L);
eps = dlamch_("E", 1L);
d__1 = dlamch_("B", 1L);
i__1 = (integer) (log(safmin / eps) / log(dlamch_("B", 1L)) / 2.);
safmn2 = pow_di(&d__1, &i__1);
safmx2 = 1. / safmn2;
}
if (*g == 0.) {
*cs = 1.;
*sn = 0.;
*r__ = *f;
} else if (*f == 0.) {
*cs = 0.;
*sn = 1.;
*r__ = *g;
} else {
f1 = *f;
g1 = *g;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
if (scale >= safmx2) {
count = 0;
L10:
++count;
f1 *= safmn2;
g1 *= safmn2;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
if (scale >= safmx2) {
goto L10;
}
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmx2;
/* L20: */
}
} else if (scale <= safmn2) {
count = 0;
L30:
++count;
f1 *= safmx2;
g1 *= safmx2;
/* Computing MAX */
d__1 = abs(f1), d__2 = abs(g1);
scale = max(d__1,d__2);
if (scale <= safmn2) {
goto L30;
}
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
i__1 = count;
for (i__ = 1; i__ <= i__1; ++i__) {
*r__ *= safmn2;
/* L40: */
}
} else {
/* Computing 2nd power */
d__1 = f1;
/* Computing 2nd power */
d__2 = g1;
*r__ = sqrt(d__1 * d__1 + d__2 * d__2);
*cs = f1 / *r__;
*sn = g1 / *r__;
}
if (abs(*f) > abs(*g) && *cs < 0.) {
*cs = -(*cs);
*sn = -(*sn);
*r__ = -(*r__);
}
}
return 0;
/* End of DLARTG */
} /* dlartg_ */
/* dlamch.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b32
#undef c_b32
#endif
#define c_b32 c_b32
doublereal dlamch_(cmach, cmach_len)
char *cmach;
ftnlen cmach_len;
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
integer i__1;
doublereal ret_val;
/* Builtin functions */
double pow_di();
/* Local variables */
static doublereal base;
static integer beta;
static doublereal emin, prec, emax;
static integer imin, imax;
static logical lrnd;
static doublereal rmin, rmax, t, rmach;
extern logical lsame_();
static doublereal small, sfmin;
extern /* Subroutine */ int dlamc2_();
static integer it;
static doublereal rnd, eps;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAMCH determines double precision machine parameters. */
/* Arguments */
/* ========= */
/* CMACH (input) CHARACTER*1 */
/* Specifies the value to be returned by DLAMCH: */
/* = 'E' or 'e', DLAMCH := eps */
/* = 'S' or 's , DLAMCH := sfmin */
/* = 'B' or 'b', DLAMCH := base */
/* = 'P' or 'p', DLAMCH := eps*base */
/* = 'N' or 'n', DLAMCH := t */
/* = 'R' or 'r', DLAMCH := rnd */
/* = 'M' or 'm', DLAMCH := emin */
/* = 'U' or 'u', DLAMCH := rmin */
/* = 'L' or 'l', DLAMCH := emax */
/* = 'O' or 'o', DLAMCH := rmax */
/* where */
/* eps = relative machine precision */
/* sfmin = safe minimum, such that 1/sfmin does not overflow */
/* base = base of the machine */
/* prec = eps*base */
/* t = number of (base) digits in the mantissa */
/* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */
/* emin = minimum exponent before (gradual) underflow */
/* rmin = underflow threshold - base**(emin-1) */
/* emax = largest exponent before overflow */
/* rmax = overflow threshold - (base**emax)*(1-eps) */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
if (first) {
first = FALSE_;
dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
base = (doublereal) beta;
t = (doublereal) it;
if (lrnd) {
rnd = 1.;
i__1 = 1 - it;
eps = pow_di(&base, &i__1) / 2;
} else {
rnd = 0.;
i__1 = 1 - it;
eps = pow_di(&base, &i__1);
}
prec = eps * base;
emin = (doublereal) imin;
emax = (doublereal) imax;
sfmin = rmin;
small = 1. / rmax;
if (small >= sfmin) {
/* Use SMALL plus a bit, to avoid the possibility of rou
nding */
/* causing overflow when computing 1/sfmin. */
sfmin = small * (eps + 1.);
}
}
if (lsame_(cmach, "E", 1L, 1L)) {
rmach = eps;
} else if (lsame_(cmach, "S", 1L, 1L)) {
rmach = sfmin;
} else if (lsame_(cmach, "B", 1L, 1L)) {
rmach = base;
} else if (lsame_(cmach, "P", 1L, 1L)) {
rmach = prec;
} else if (lsame_(cmach, "N", 1L, 1L)) {
rmach = t;
} else if (lsame_(cmach, "R", 1L, 1L)) {
rmach = rnd;
} else if (lsame_(cmach, "M", 1L, 1L)) {
rmach = emin;
} else if (lsame_(cmach, "U", 1L, 1L)) {
rmach = rmin;
} else if (lsame_(cmach, "L", 1L, 1L)) {
rmach = emax;
} else if (lsame_(cmach, "O", 1L, 1L)) {
rmach = rmax;
}
ret_val = rmach;
return ret_val;
/* End of DLAMCH */
} /* dlamch_ */
/* *********************************************************************** */
/* Subroutine */ int dlamc1_(beta, t, rnd, ieee1)
integer *beta, *t;
logical *rnd, *ieee1;
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
doublereal d__1, d__2;
/* Local variables */
static logical lrnd;
static doublereal a, b, c__, f;
static integer lbeta;
static doublereal savec;
extern doublereal dlamc3_();
static logical lieee1;
static doublereal t1, t2;
static integer lt;
static doublereal one, qtr;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAMC1 determines the machine parameters given by BETA, T, RND, and */
/* IEEE1. */
/* Arguments */
/* ========= */
/* BETA (output) INTEGER */
/* The base of the machine. */
/* T (output) INTEGER */
/* The number of ( BETA ) digits in the mantissa. */
/* RND (output) LOGICAL */
/* Specifies whether proper rounding ( RND = .TRUE. ) or */
/* chopping ( RND = .FALSE. ) occurs in addition. This may not
*/
/* be a reliable guide to the way in which the machine performs
*/
/* its arithmetic. */
/* IEEE1 (output) LOGICAL */
/* Specifies whether rounding appears to be done in the IEEE */
/* 'round to nearest' style. */
/* Further Details */
/* =============== */
/* The routine is based on the routine ENVRON by Malcolm and */
/* incorporates suggestions by Gentleman and Marovich. See */
/* Malcolm M. A. (1972) Algorithms to reveal properties of */
/* floating-point arithmetic. Comms. of the ACM, 15, 949-951. */
/* Gentleman W. M. and Marovich S. B. (1974) More on algorithms */
/* that reveal properties of floating point arithmetic units. */
/* Comms. of the ACM, 17, 276-277. */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
if (first) {
first = FALSE_;
one = 1.;
/* LBETA, LIEEE1, LT and LRND are the local values of BE
TA, */
/* IEEE1, T and RND. */
/* Throughout this routine we use the function DLAMC3 to ens
ure */
/* that relevant values are stored and not held in registers,
or */
/* are not affected by optimizers. */
/* Compute a = 2.0**m with the smallest positive integer m s
uch */
/* that */
/* fl( a + 1.0 ) = a. */
a = 1.;
c__ = 1.;
/* + WHILE( C.EQ.ONE )LOOP */
L10:
if (c__ == one) {
a *= 2;
c__ = dlamc3_(&a, &one);
d__1 = -a;
c__ = dlamc3_(&c__, &d__1);
goto L10;
}
/* + END WHILE */
/* Now compute b = 2.0**m with the smallest positive integer
m */
/* such that */
/* fl( a + b ) .gt. a. */
b = 1.;
c__ = dlamc3_(&a, &b);
/* + WHILE( C.EQ.A )LOOP */
L20:
if (c__ == a) {
b *= 2;
c__ = dlamc3_(&a, &b);
goto L20;
}
/* + END WHILE */
/* Now compute the base. a and c are neighbouring floating po
int */
/* numbers in the interval ( beta**t, beta**( t + 1 ) ) and
so */
/* their difference is beta. Adding 0.25 to c is to ensure that
it */
/* is truncated to beta and not ( beta - 1 ). */
qtr = one / 4;
savec = c__;
d__1 = -a;
c__ = dlamc3_(&c__, &d__1);
lbeta = (integer) (c__ + qtr);
/* Now determine whether rounding or chopping occurs, by addin
g a */
/* bit less than beta/2 and a bit more than beta/2 to
a. */
b = (doublereal) lbeta;
d__1 = b / 2;
d__2 = -b / 100;
f = dlamc3_(&d__1, &d__2);
c__ = dlamc3_(&f, &a);
if (c__ == a) {
lrnd = TRUE_;
} else {
lrnd = FALSE_;
}
d__1 = b / 2;
d__2 = b / 100;
f = dlamc3_(&d__1, &d__2);
c__ = dlamc3_(&f, &a);
if (lrnd && c__ == a) {
lrnd = FALSE_;
}
/* Try and decide whether rounding is done in the IEEE 'round
to */
/* nearest' style. B/2 is half a unit in the last place of the
two */
/* numbers A and SAVEC. Furthermore, A is even, i.e. has last
bit */
/* zero, and SAVEC is odd. Thus adding B/2 to A should not cha
nge */
/* A, but adding B/2 to SAVEC should change SAVEC. */
d__1 = b / 2;
t1 = dlamc3_(&d__1, &a);
d__1 = b / 2;
t2 = dlamc3_(&d__1, &savec);
lieee1 = t1 == a && t2 > savec && lrnd;
/* Now find the mantissa, t. It should be the integer part
of */
/* log to the base beta of a, however it is safer to determine
t */
/* by powering. So we find t as the smallest positive integer
for */
/* which */
/* fl( beta**t + 1.0 ) = 1.0. */
lt = 0;
a = 1.;
c__ = 1.;
/* + WHILE( C.EQ.ONE )LOOP */
L30:
if (c__ == one) {
++lt;
a *= lbeta;
c__ = dlamc3_(&a, &one);
d__1 = -a;
c__ = dlamc3_(&c__, &d__1);
goto L30;
}
/* + END WHILE */
}
*beta = lbeta;
*t = lt;
*rnd = lrnd;
*ieee1 = lieee1;
return 0;
/* End of DLAMC1 */
} /* dlamc1_ */
/* *********************************************************************** */
/* Subroutine */ int dlamc2_(beta, t, rnd, eps, emin, rmin, emax, rmax)
integer *beta, *t;
logical *rnd;
doublereal *eps;
integer *emin;
doublereal *rmin;
integer *emax;
doublereal *rmax;
{
/* Initialized data */
static logical first = TRUE_;
static logical iwarn = FALSE_;
/* Format strings */
static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorre\
ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the value EMIN loo\
ks\002,\002 acceptable please comment out \002,/\002 the IF block as marked \
within the code of routine\002,\002 DLAMC2,\002,/\002 otherwise supply EMIN \
explicitly.\002,/)";
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double pow_di();
integer s_wsfe(), do_fio(), e_wsfe();
/* Local variables */
static logical ieee;
static doublereal half;
static logical lrnd;
static doublereal leps, zero, a, b, c__;
static integer i__, lbeta;
static doublereal rbase;
static integer lemin, lemax, gnmin;
static doublereal small;
static integer gpmin;
static doublereal third, lrmin, lrmax, sixth;
extern /* Subroutine */ int dlamc1_();
extern doublereal dlamc3_();
static logical lieee1;
extern /* Subroutine */ int dlamc4_(), dlamc5_();
static integer lt, ngnmin, ngpmin;
static doublereal one, two;
/* Fortran I/O blocks */
static cilist io___58 = { 0, 6, 0, fmt_9999, 0 };
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAMC2 determines the machine parameters specified in its argument */
/* list. */
/* Arguments */
/* ========= */
/* BETA (output) INTEGER */
/* The base of the machine. */
/* T (output) INTEGER */
/* The number of ( BETA ) digits in the mantissa. */
/* RND (output) LOGICAL */
/* Specifies whether proper rounding ( RND = .TRUE. ) or */
/* chopping ( RND = .FALSE. ) occurs in addition. This may not
*/
/* be a reliable guide to the way in which the machine performs
*/
/* its arithmetic. */
/* EPS (output) DOUBLE PRECISION */
/* The smallest positive number such that */
/* fl( 1.0 - EPS ) .LT. 1.0, */
/* where fl denotes the computed value. */
/* EMIN (output) INTEGER */
/* The minimum exponent before (gradual) underflow occurs. */
/* RMIN (output) DOUBLE PRECISION */
/* The smallest normalized number for the machine, given by */
/* BASE**( EMIN - 1 ), where BASE is the floating point value
*/
/* of BETA. */
/* EMAX (output) INTEGER */
/* The maximum exponent before overflow occurs. */
/* RMAX (output) DOUBLE PRECISION */
/* The largest positive number for the machine, given by */
/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
*/
/* value of BETA. */
/* Further Details */
/* =============== */
/* The computation of EPS is based on a routine PARANOIA by */
/* W. Kahan of the University of California at Berkeley. */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
if (first) {
first = FALSE_;
zero = 0.;
one = 1.;
two = 2.;
/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values
of */
/* BETA, T, RND, EPS, EMIN and RMIN. */
/* Throughout this routine we use the function DLAMC3 to ens
ure */
/* that relevant values are stored and not held in registers,
or */
/* are not affected by optimizers. */
/* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
*/
dlamc1_(&lbeta, <, &lrnd, &lieee1);
/* Start to find EPS. */
b = (doublereal) lbeta;
i__1 = -lt;
a = pow_di(&b, &i__1);
leps = a;
/* Try some tricks to see whether or not this is the correct E
PS. */
b = two / 3;
half = one / 2;
d__1 = -half;
sixth = dlamc3_(&b, &d__1);
third = dlamc3_(&sixth, &sixth);
d__1 = -half;
b = dlamc3_(&third, &d__1);
b = dlamc3_(&b, &sixth);
b = abs(b);
if (b < leps) {
b = leps;
}
leps = 1.;
/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
if (leps > b && b > zero) {
leps = b;
d__1 = half * leps;
/* Computing 5th power */
d__3 = two, d__4 = d__3, d__3 *= d__3;
/* Computing 2nd power */
d__5 = leps;
d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5);
c__ = dlamc3_(&d__1, &d__2);
d__1 = -c__;
c__ = dlamc3_(&half, &d__1);
b = dlamc3_(&half, &c__);
d__1 = -b;
c__ = dlamc3_(&half, &d__1);
b = dlamc3_(&half, &c__);
goto L10;
}
/* + END WHILE */
if (a < leps) {
leps = a;
}
/* Computation of EPS complete. */
/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3
)). */
/* Keep dividing A by BETA until (gradual) underflow occurs. T
his */
/* is detected when we cannot recover the previous A. */
rbase = one / lbeta;
small = one;
for (i__ = 1; i__ <= 3; ++i__) {
d__1 = small * rbase;
small = dlamc3_(&d__1, &zero);
/* L20: */
}
a = dlamc3_(&one, &small);
dlamc4_(&ngpmin, &one, &lbeta);
d__1 = -one;
dlamc4_(&ngnmin, &d__1, &lbeta);
dlamc4_(&gpmin, &a, &lbeta);
d__1 = -a;
dlamc4_(&gnmin, &d__1, &lbeta);
ieee = FALSE_;
if (ngpmin == ngnmin && gpmin == gnmin) {
if (ngpmin == gpmin) {
lemin = ngpmin;
/* ( Non twos-complement machines, no gradual under
flow; */
/* e.g., VAX ) */
} else if (gpmin - ngpmin == 3) {
lemin = ngpmin - 1 + lt;
ieee = TRUE_;
/* ( Non twos-complement machines, with gradual und
erflow; */
/* e.g., IEEE standard followers ) */
} else {
lemin = min(ngpmin,gpmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if (ngpmin == gpmin && ngnmin == gnmin) {
if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
lemin = max(ngpmin,ngnmin);
/* ( Twos-complement machines, no gradual underflow
; */
/* e.g., CYBER 205 ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
{
if (gpmin - min(ngpmin,ngnmin) == 3) {
lemin = max(ngpmin,ngnmin) - 1 + lt;
/* ( Twos-complement machines with gradual underflo
w; */
/* no known machine ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else {
/* Computing MIN */
i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
lemin = min(i__1,gnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
/* ** */
/* Comment out this if block if EMIN is ok *
if (iwarn) {
first = TRUE_;
s_wsfe(&io___58);
do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer));
e_wsfe();
}
*/
/* Assume IEEE arithmetic if we found denormalised numbers abo
ve, */
/* or if arithmetic seems to round in the IEEE style, determi
ned */
/* in routine DLAMC1. A true IEEE machine should have both thi
ngs */
/* true; however, faulty machines may have one or the other. */
ieee = ieee || lieee1;
/* Compute RMIN by successive division by BETA. We could comp
ute */
/* RMIN as BASE**( EMIN - 1 ), but some machines underflow dur
ing */
/* this computation. */
lrmin = 1.;
i__1 = 1 - lemin;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = lrmin * rbase;
lrmin = dlamc3_(&d__1, &zero);
/* L30: */
}
/* Finally, call DLAMC5 to compute EMAX and RMAX. */
dlamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
}
*beta = lbeta;
*t = lt;
*rnd = lrnd;
*eps = leps;
*emin = lemin;
*rmin = lrmin;
*emax = lemax;
*rmax = lrmax;
return 0;
/* End of DLAMC2 */
} /* dlamc2_ */
/* *********************************************************************** */
doublereal dlamc3_(a, b)
doublereal *a, *b;
{
/* System generated locals */
doublereal ret_val;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAMC3 is intended to force A and B to be stored prior to doing
*/
/* the addition of A and B , for use in situations where optimizers
*/
/* might hold one of these in a register. */
/* Arguments */
/* ========= */
/* A, B (input) DOUBLE PRECISION */
/* The values A and B. */
/* =====================================================================
*/
/* .. Executable Statements .. */
ret_val = *a + *b;
return ret_val;
/* End of DLAMC3 */
} /* dlamc3_ */
/* *********************************************************************** */
/* Subroutine */ int dlamc4_(emin, start, base)
integer *emin;
doublereal *start;
integer *base;
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Local variables */
static doublereal zero, a;
static integer i__;
static doublereal rbase, b1, b2, c1, c2, d1, d2;
extern doublereal dlamc3_();
static doublereal one;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAMC4 is a service routine for DLAMC2. */
/* Arguments */
/* ========= */
/* EMIN (output) EMIN */
/* The minimum exponent before (gradual) underflow, computed by
*/
/* setting A = START and dividing by BASE until the previous A */
/* can not be recovered. */
/* START (input) DOUBLE PRECISION */
/* The starting point for determining EMIN. */
/* BASE (input) INTEGER */
/* The base of the machine. */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
a = *start;
one = 1.;
rbase = one / *base;
zero = 0.;
*emin = 1;
d__1 = a * rbase;
b1 = dlamc3_(&d__1, &zero);
c1 = a;
c2 = a;
d1 = a;
d2 = a;
/* + WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. */
/* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP */
L10:
if (c1 == a && c2 == a && d1 == a && d2 == a) {
--(*emin);
a = b1;
d__1 = a / *base;
b1 = dlamc3_(&d__1, &zero);
d__1 = b1 * *base;
c1 = dlamc3_(&d__1, &zero);
d1 = zero;
i__1 = *base;
for (i__ = 1; i__ <= i__1; ++i__) {
d1 += b1;
/* L20: */
}
d__1 = a * rbase;
b2 = dlamc3_(&d__1, &zero);
d__1 = b2 / rbase;
c2 = dlamc3_(&d__1, &zero);
d2 = zero;
i__1 = *base;
for (i__ = 1; i__ <= i__1; ++i__) {
d2 += b2;
/* L30: */
}
goto L10;
}
/* + END WHILE */
return 0;
/* End of DLAMC4 */
} /* dlamc4_ */
/* *********************************************************************** */
/* Subroutine */ int dlamc5_(beta, p, emin, ieee, emax, rmax)
integer *beta, *p, *emin;
logical *ieee;
integer *emax;
doublereal *rmax;
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Local variables */
static integer lexp;
static doublereal oldy;
static integer uexp, i__;
static doublereal y, z__;
static integer nbits;
extern doublereal dlamc3_();
static doublereal recbas;
static integer exbits, expsum, try__;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAMC5 attempts to compute RMAX, the largest machine floating-point */
/* number, without overflow. It assumes that EMAX + abs(EMIN) sum */
/* approximately to a power of 2. It will fail on machines where this */
/* assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
*/
/* EMAX = 28718). It will also fail if the value supplied for EMIN is */
/* too large (i.e. too close to zero), probably with overflow. */
/* Arguments */
/* ========= */
/* BETA (input) INTEGER */
/* The base of floating-point arithmetic. */
/* P (input) INTEGER */
/* The number of base BETA digits in the mantissa of a */
/* floating-point value. */
/* EMIN (input) INTEGER */
/* The minimum exponent before (gradual) underflow. */
/* IEEE (input) LOGICAL */
/* A logical flag specifying whether or not the arithmetic */
/* system is thought to comply with the IEEE standard. */
/* EMAX (output) INTEGER */
/* The largest exponent before overflow */
/* RMAX (output) DOUBLE PRECISION */
/* The largest machine floating-point number. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* First compute LEXP and UEXP, two powers of 2 that bound */
/* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum */
/* approximately to the bound that is closest to abs(EMIN). */
/* (EMAX is the exponent of the required number RMAX). */
lexp = 1;
exbits = 1;
L10:
try__ = lexp << 1;
if (try__ <= -(*emin)) {
lexp = try__;
++exbits;
goto L10;
}
if (lexp == -(*emin)) {
uexp = lexp;
} else {
uexp = try__;
++exbits;
}
/* Now -LEXP is less than or equal to EMIN, and -UEXP is greater */
/* than or equal to EMIN. EXBITS is the number of bits needed to */
/* store the exponent. */
if (uexp + *emin > -lexp - *emin) {
expsum = lexp << 1;
} else {
expsum = uexp << 1;
}
/* EXPSUM is the exponent range, approximately equal to */
/* EMAX - EMIN + 1 . */
*emax = expsum + *emin - 1;
nbits = exbits + 1 + *p;
/* NBITS is the total number of bits needed to store a */
/* floating-point number. */
if (nbits % 2 == 1 && *beta == 2) {
/* Either there are an odd number of bits used to store a */
/* floating-point number, which is unlikely, or some bits are
*/
/* not used in the representation of numbers, which is possible
, */
/* (e.g. Cray machines) or the mantissa has an implicit bit, */
/* (e.g. IEEE machines, Dec Vax machines), which is perhaps the
*/
/* most likely. We have to assume the last alternative. */
/* If this is true, then we need to reduce EMAX by one because
*/
/* there must be some way of representing zero in an implicit-b
it */
/* system. On machines like Cray, we are reducing EMAX by one
*/
/* unnecessarily. */
--(*emax);
}
if (*ieee) {
/* Assume we are on an IEEE machine which reserves one exponent
*/
/* for infinity and NaN. */
--(*emax);
}
/* Now create RMAX, the largest machine number, which should */
/* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . */
/* First compute 1.0 - BETA**(-P), being careful that the */
/* result is less than 1.0 . */
recbas = 1. / *beta;
z__ = *beta - 1.;
y = 0.;
i__1 = *p;
for (i__ = 1; i__ <= i__1; ++i__) {
z__ *= recbas;
if (y < 1.) {
oldy = y;
}
y = dlamc3_(&y, &z__);
/* L20: */
}
if (y >= 1.) {
y = oldy;
}
/* Now multiply by BETA**EMAX to get RMAX. */
i__1 = *emax;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = y * *beta;
y = dlamc3_(&d__1, &c_b32);
/* L30: */
}
*rmax = y;
return 0;
/* End of DLAMC5 */
} /* dlamc5_ */
/* drscl.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int drscl_(n, sa, sx, incx)
integer *n;
doublereal *sa, *sx;
integer *incx;
{
static doublereal cden;
static logical done;
static doublereal cnum, cden1, cnum1;
extern /* Subroutine */ int dscal_(), dlabad_();
extern doublereal dlamch_();
static doublereal bignum, smlnum, mul;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DRSCL multiplies an n-element real vector x by the real scalar 1/a. */
/* This is done without overflow or underflow as long as */
/* the final result x/a does not overflow or underflow. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of components of the vector x. */
/* SA (input) DOUBLE PRECISION */
/* The scalar a which is used to divide each component of x. */
/* SA must be >= 0, or the subroutine will divide by zero. */
/* SX (input/output) DOUBLE PRECISION array, dimension */
/* (1+(N-1)*abs(INCX)) */
/* The n-element vector x. */
/* INCX (input) INTEGER */
/* The increment between successive values of the vector SX. */
/* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n
*/
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--sx;
/* Function Body */
if (*n <= 0) {
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S", 1L);
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Initialize the denominator to SA and the numerator to 1. */
cden = *sa;
cnum = 1.;
L10:
cden1 = cden * smlnum;
cnum1 = cnum / bignum;
if (abs(cden1) > abs(cnum) && cnum != 0.) {
/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
*/
mul = smlnum;
done = FALSE_;
cden = cden1;
} else if (abs(cnum1) > abs(cden)) {
/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
*/
mul = bignum;
done = FALSE_;
cnum = cnum1;
} else {
/* Multiply X by CNUM / CDEN and return. */
mul = cnum / cden;
done = TRUE_;
}
/* Scale the vector X by MUL */
dscal_(n, &mul, &sx[1], incx);
if (! done) {
goto L10;
}
return 0;
/* End of DRSCL */
} /* drscl_ */
/* dlassq.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlassq_(n, x, incx, scale, sumsq)
integer *n;
doublereal *x;
integer *incx;
doublereal *scale, *sumsq;
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
static doublereal absxi;
static integer ix;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASSQ returns the values scl and smsq such that */
/* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
*/
/* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is */
/* assumed to be non-negative and scl returns the value */
/* scl = max( scale, abs( x( i ) ) ). */
/* scale and sumsq must be supplied in SCALE and SUMSQ and */
/* scl and smsq are overwritten on SCALE and SUMSQ respectively. */
/* The routine makes only one pass through the vector x. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of elements to be used from the vector X. */
/* X (input) DOUBLE PRECISION */
/* The vector for which a scaled sum of squares is computed. */
/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */
/* INCX (input) INTEGER */
/* The increment between successive values of the vector X. */
/* INCX > 0. */
/* SCALE (input/output) DOUBLE PRECISION */
/* On entry, the value scale in the equation above. */
/* On exit, SCALE is overwritten with scl , the scaling factor
*/
/* for the sum of squares. */
/* SUMSQ (input/output) DOUBLE PRECISION */
/* On entry, the value sumsq in the equation above. */
/* On exit, SUMSQ is overwritten with smsq , the basic sum of */
/* squares from which scl has been factored out. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--x;
/* Function Body */
if (*n > 0) {
i__1 = (*n - 1) * *incx + 1;
i__2 = *incx;
for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
if (x[ix] != 0.) {
absxi = (d__1 = x[ix], abs(d__1));
if (*scale < absxi) {
/* Computing 2nd power */
d__1 = *scale / absxi;
*sumsq = *sumsq * (d__1 * d__1) + 1;
*scale = absxi;
} else {
/* Computing 2nd power */
d__1 = absxi / *scale;
*sumsq += d__1 * d__1;
}
}
/* L10: */
}
}
return 0;
/* End of DLASSQ */
} /* dlassq_ */
/* dorml2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dorml2_(side, trans, m, n, k, a, lda, tau, c__, ldc,
work, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *c__;
integer *ldc;
doublereal *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 logical left;
static integer i__;
extern /* Subroutine */ int dlarf_();
extern logical lsame_();
static integer i1, i2, i3, ic, jc, mi, ni, nq;
extern /* Subroutine */ int xerbla_();
static logical notran;
static doublereal aii;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORML2 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 DGELQF. 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) DOUBLE PRECISION 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
*/
/* DGELQF 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) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DGELQF. */
/* C (input/output) DOUBLE PRECISION 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) DOUBLE PRECISION 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 = a_dim1 + 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R", 1L, 1L)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T", 1L, 1L)) {
*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_("DORML2", &i__1, 6L);
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; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
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_dim1];
a[i__ + i__ * a_dim1] = 1.;
dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[
ic + jc * c_dim1], ldc, &work[1], 1L);
a[i__ + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of DORML2 */
} /* dorml2_ */
/* dlascl.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlascl_(type__, kl, ku, cfrom, cto, m, n, a, lda, info,
type_len)
char *type__;
integer *kl, *ku;
doublereal *cfrom, *cto;
integer *m, *n;
doublereal *a;
integer *lda, *info;
ftnlen type_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
/* Local variables */
static logical done;
static doublereal ctoc;
static integer i__, j;
extern logical lsame_();
static integer itype, k1, k2, k3, k4;
static doublereal cfrom1;
extern doublereal dlamch_();
static doublereal cfromc;
extern /* Subroutine */ int xerbla_();
static doublereal bignum, smlnum, mul, cto1;
/* -- LAPACK auxiliary routine (version 2.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 */
/* ======= */
/* DLASCL multiplies the M by N real matrix A by the real scalar */
/* CTO/CFROM. This is done without over/underflow as long as the final
*/
/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
*/
/* A may be full, upper triangular, lower triangular, upper Hessenberg,
*/
/* or banded. */
/* Arguments */
/* ========= */
/* TYPE (input) CHARACTER*1 */
/* TYPE indices the storage type of the input matrix. */
/* = 'G': A is a full matrix. */
/* = 'L': A is a lower triangular matrix. */
/* = 'U': A is an upper triangular matrix. */
/* = 'H': A is an upper Hessenberg matrix. */
/* = 'B': A is a symmetric band matrix with lower bandwidth KL
*/
/* and upper bandwidth KU and with the only the lower */
/* half stored. */
/* = 'Q': A is a symmetric band matrix with lower bandwidth KL
*/
/* and upper bandwidth KU and with the only the upper */
/* half stored. */
/* = 'Z': A is a band matrix with lower bandwidth KL and upper
*/
/* bandwidth KU. */
/* KL (input) INTEGER */
/* The lower bandwidth of A. Referenced only if TYPE = 'B', */
/* 'Q' or 'Z'. */
/* KU (input) INTEGER */
/* The upper bandwidth of A. Referenced only if TYPE = 'B', */
/* 'Q' or 'Z'. */
/* CFROM (input) DOUBLE PRECISION */
/* CTO (input) DOUBLE PRECISION */
/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
/* without over/underflow if the final result CTO*A(I,J)/CFROM */
/* can be represented without over/underflow. CFROM must be */
/* nonzero. */
/* 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) DOUBLE PRECISION array, dimension (LDA,M) */
/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */
/* storage type. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* INFO (output) INTEGER */
/* 0 - successful exit */
/* <0 - if INFO = -i, the i-th argument had an illegal value. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
*info = 0;
if (lsame_(type__, "G", 1L, 1L)) {
itype = 0;
} else if (lsame_(type__, "L", 1L, 1L)) {
itype = 1;
} else if (lsame_(type__, "U", 1L, 1L)) {
itype = 2;
} else if (lsame_(type__, "H", 1L, 1L)) {
itype = 3;
} else if (lsame_(type__, "B", 1L, 1L)) {
itype = 4;
} else if (lsame_(type__, "Q", 1L, 1L)) {
itype = 5;
} else if (lsame_(type__, "Z", 1L, 1L)) {
itype = 6;
} else {
itype = -1;
}
if (itype == -1) {
*info = -1;
} else if (*cfrom == 0.) {
*info = -4;
} else if (*m < 0) {
*info = -6;
} else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
*info = -7;
} else if (itype <= 3 && *lda < max(1,*m)) {
*info = -9;
} else if (itype >= 4) {
/* Computing MAX */
i__1 = *m - 1;
if (*kl < 0 || *kl > max(i__1,0)) {
*info = -2;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = *n - 1;
if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
*kl != *ku) {
*info = -3;
} else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
*info = -9;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASCL", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
}
/* Get machine parameters */
smlnum = dlamch_("S", 1L);
bignum = 1. / smlnum;
cfromc = *cfrom;
ctoc = *cto;
L10:
cfrom1 = cfromc * smlnum;
cto1 = ctoc / bignum;
if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
mul = smlnum;
done = FALSE_;
cfromc = cfrom1;
} else if (abs(cto1) > abs(cfromc)) {
mul = bignum;
done = FALSE_;
ctoc = cto1;
} else {
mul = ctoc / cfromc;
done = TRUE_;
}
if (itype == 0) {
/* Full matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L20: */
}
/* L30: */
}
} else if (itype == 1) {
/* Lower triangular matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L40: */
}
/* L50: */
}
} else if (itype == 2) {
/* Upper triangular matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L60: */
}
/* L70: */
}
} else if (itype == 3) {
/* Upper Hessenberg matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = j + 1;
i__2 = min(i__3,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L80: */
}
/* L90: */
}
} else if (itype == 4) {
/* Lower half of a symmetric band matrix */
k3 = *kl + 1;
k4 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__3 = k3, i__4 = k4 - j;
i__2 = min(i__3,i__4);
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L100: */
}
/* L110: */
}
} else if (itype == 5) {
/* Upper half of a symmetric band matrix */
k1 = *ku + 2;
k3 = *ku + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = k1 - j;
i__3 = k3;
for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L120: */
}
/* L130: */
}
} else if (itype == 6) {
/* Band matrix */
k1 = *kl + *ku + 2;
k2 = *kl + 1;
k3 = (*kl << 1) + *ku + 1;
k4 = *kl + *ku + 1 + *m;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__3 = k1 - j;
/* Computing MIN */
i__4 = k3, i__5 = k4 - j;
i__2 = min(i__4,i__5);
for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] *= mul;
/* L140: */
}
/* L150: */
}
}
if (! done) {
goto L10;
}
return 0;
/* End of DLASCL */
} /* dlascl_ */
/* dhseqr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b9
#undef c_b9
#endif
#define c_b9 c_b9
#ifdef c_b10
#undef c_b10
#endif
#define c_b10 c_b10
/* Subroutine */ int dhseqr_(job, compz, n, ilo, ihi, h__, ldh, wr, wi, z__,
ldz, work, lwork, info, job_len, compz_len)
char *job, *compz;
integer *n, *ilo, *ihi;
doublereal *h__;
integer *ldh;
doublereal *wr, *wi, *z__;
integer *ldz;
doublereal *work;
integer *lwork, *info;
ftnlen job_len;
ftnlen compz_len;
{
/* System generated locals */
address a__1[2];
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2], i__4,
i__5;
doublereal d__1, d__2;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat();
/* Local variables */
static integer maxb;
static doublereal absw;
static integer ierr;
static doublereal unfl, temp, ovfl;
static integer i__, j, k, l;
static doublereal s[225] /* was [15][15] */, v[16];
extern /* Subroutine */ int dscal_();
extern logical lsame_();
extern /* Subroutine */ int dgemv_();
static integer itemp;
extern /* Subroutine */ int dcopy_();
static integer i1, i2;
static logical initz, wantt, wantz;
extern doublereal dlapy2_();
extern /* Subroutine */ int dlabad_();
static integer ii, nh;
extern doublereal dlamch_();
extern /* Subroutine */ int dlarfg_();
static integer nr, ns;
extern integer idamax_();
static integer nv;
extern doublereal dlanhs_();
extern /* Subroutine */ int dlahqr_();
static doublereal vv[16];
extern /* Subroutine */ int dlacpy_();
extern integer ilaenv_();
extern /* Subroutine */ int dlaset_(), dlarfx_(), xerbla_();
static doublereal smlnum;
static integer itn;
static doublereal tau;
static integer its;
static doublereal ulp, tst1;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DHSEQR computes the eigenvalues of a real upper Hessenberg matrix H */
/* and, optionally, the matrices T and Z from the Schur decomposition */
/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur
*/
/* form), and Z is the orthogonal matrix of Schur vectors. */
/* Optionally Z may be postmultiplied into an input orthogonal matrix Q,
*/
/* so that this routine can give the Schur factorization of a matrix A */
/* which has been reduced to the Hessenberg form H by the orthogonal */
/* matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* = 'E': compute eigenvalues only; */
/* = 'S': compute eigenvalues and the Schur form T. */
/* COMPZ (input) CHARACTER*1 */
/* = 'N': no Schur vectors are computed; */
/* = 'I': Z is initialized to the unit matrix and the matrix Z
*/
/* of Schur vectors of H is returned; */
/* = 'V': Z must contain an orthogonal matrix Q on entry, and */
/* the product Q*Z is returned. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H 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 DGEBAL, and then passed to SGEHRD */
/* when the matrix output by DGEBAL is reduced to Hessenberg */
/* form. Otherwise ILO and IHI should be set to 1 and N */
/* respectively. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if JOB = 'S', H contains the upper quasi-triangular
*/
/* matrix T from the Schur decomposition (the Schur form); */
/* 2-by-2 diagonal blocks (corresponding to complex conjugate */
/* pairs of eigenvalues) are returned in standard form, with */
/* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E',
*/
/* the contents of H are unspecified on exit. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* WR (output) DOUBLE PRECISION array, dimension (N) */
/* WI (output) DOUBLE PRECISION array, dimension (N) */
/* The real and imaginary parts, respectively, of the computed */
/* eigenvalues. If two eigenvalues are computed as a complex */
/* conjugate pair, they are stored in consecutive elements of */
/* WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and */
/* WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the
*/
/* same order as on the diagonal of the Schur form returned in */
/* H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */
/* diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and */
/* WI(i+1) = -WI(i). */
/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
/* If COMPZ = 'N': Z is not referenced. */
/* If COMPZ = 'I': on entry, Z need not be set, and on exit, Z */
/* contains the orthogonal matrix Z of the Schur vectors of H. */
/* If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, */
/* which is assumed to be equal to the unit matrix except for */
/* the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. */
/* Normally Q is the orthogonal matrix generated by DORGHR after
*/
/* the call to DGEHRD which formed the Hessenberg matrix H. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. */
/* LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* LWORK (input) INTEGER */
/* This argument is currently redundant. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, DHSEQR failed to compute all of the */
/* eigenvalues in a total of 30*(IHI-ILO+1) iterations; */
/* elements 1:ilo-1 and i+1:n of WR and WI contain those */
/* eigenvalues which have been successfully computed. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = h_dim1 + 1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = z_dim1 + 1;
z__ -= z_offset;
--work;
/* Function Body */
wantt = lsame_(job, "S", 1L, 1L);
initz = lsame_(compz, "I", 1L, 1L);
wantz = initz || lsame_(compz, "V", 1L, 1L);
*info = 0;
if (! lsame_(job, "E", 1L, 1L) && ! wantt) {
*info = -1;
} else if (! lsame_(compz, "N", 1L, 1L) && ! wantz) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*ldh < max(1,*n)) {
*info = -7;
} else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DHSEQR", &i__1, 6L);
return 0;
}
/* Initialize Z, if necessary */
if (initz) {
dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz, 4L);
}
/* Store the eigenvalues isolated by DGEBAL. */
i__1 = *ilo - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
/* L10: */
}
i__1 = *n;
for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.;
/* L20: */
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.;
return 0;
}
/* Set rows and columns ILO to IHI to zero below the first */
/* subdiagonal. */
i__1 = *ihi - 2;
for (j = *ilo; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
h__[i__ + j * h_dim1] = 0.;
/* L30: */
}
/* L40: */
}
nh = *ihi - *ilo + 1;
/* Determine the order of the multi-shift QR algorithm to be used. */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
ns = ilaenv_(&c__4, "DHSEQR", ch__1, n, ilo, ihi, &c_n1, 6L, 2L);
/* Writing concatenation */
i__3[0] = 1, a__1[0] = job;
i__3[1] = 1, a__1[1] = compz;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
maxb = ilaenv_(&c__8, "DHSEQR", ch__1, n, ilo, ihi, &c_n1, 6L, 2L);
if (ns <= 2 || ns > nh || maxb >= nh) {
/* Use the standard double-shift algorithm */
dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[
1], ilo, ihi, &z__[z_offset], ldz, info);
return 0;
}
maxb = max(3,maxb);
/* Computing MIN */
i__1 = min(ns,maxb);
ns = min(i__1,15);
/* Now 2 < NS <= MAXB < NH. */
/* Set machine-dependent constants for the stopping criterion. */
/* If norm(H) <= sqrt(OVFL), overflow should not occur. */
unfl = dlamch_("Safe minimum", 12L);
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision", 9L);
smlnum = unfl * (nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are
*/
/* being computed, I1 and I2 are set inside the main loop. */
if (wantt) {
i1 = 1;
i2 = *n;
}
/* ITN is the total number of multiple-shift QR iterations allowed. */
itn = nh * 30;
/* The main loop begins here. I is the loop index and decreases from
*/
/* IHI to ILO in steps of at most MAXB. Each iteration of the loop */
/* works with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L50:
l = *ilo;
if (i__ < *ilo) {
goto L170;
}
/* Perform multiple-shift QR iterations on rows and columns ILO to I
*/
/* until a submatrix of order at most MAXB splits off at the bottom */
/* because a subdiagonal element has become negligible. */
i__1 = itn;
for (its = 0; its <= i__1; ++its) {
/* Look for a single small subdiagonal element. */
i__2 = l + 1;
for (k = i__; k >= i__2; --k) {
tst1 = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 =
h__[k + k * h_dim1], abs(d__2));
if (tst1 == 0.) {
i__4 = i__ - l + 1;
tst1 = dlanhs_("1", &i__4, &h__[l + l * h_dim1], ldh, &work[1]
, 1L);
}
/* Computing MAX */
d__2 = ulp * tst1;
if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= max(d__2,
smlnum)) {
goto L70;
}
/* L60: */
}
L70:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible. */
h__[l + (l - 1) * h_dim1] = 0.;
}
/* Exit from loop if a submatrix of order <= MAXB has split off
. */
if (l >= i__ - maxb + 1) {
goto L160;
}
/* Now the active submatrix is in rows and columns L to I. If
*/
/* eigenvalues only are being computed, only the active submatr
ix */
/* need be transformed. */
if (! wantt) {
i1 = l;
i2 = i__;
}
if (its == 20 || its == 30) {
/* Exceptional shifts. */
i__2 = i__;
for (ii = i__ - ns + 1; ii <= i__2; ++ii) {
wr[ii] = ((d__1 = h__[ii + (ii - 1) * h_dim1], abs(d__1)) + (
d__2 = h__[ii + ii * h_dim1], abs(d__2))) * 1.5;
wi[ii] = 0.;
/* L80: */
}
} else {
/* Use eigenvalues of trailing submatrix of order NS as
shifts. */
dlacpy_("Full", &ns, &ns, &h__[i__ - ns + 1 + (i__ - ns + 1) *
h_dim1], ldh, s, &c__15, 4L);
dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &wr[i__ -
ns + 1], &wi[i__ - ns + 1], &c__1, &ns, &z__[z_offset],
ldz, &ierr);
if (ierr > 0) {
/* If DLAHQR failed to compute all NS eigenvalues
, use the */
/* unconverged diagonal elements as the remaining
shifts. */
i__2 = ierr;
for (ii = 1; ii <= i__2; ++ii) {
wr[i__ - ns + ii] = s[ii + ii * 15 - 16];
wi[i__ - ns + ii] = 0.;
/* L90: */
}
}
}
/* Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
*/
/* where G is the Hessenberg submatrix H(L:I,L:I) and w is */
/* the vector of shifts (stored in WR and WI). The result is */
/* stored in the local array V. */
v[0] = 1.;
i__2 = ns + 1;
for (ii = 2; ii <= i__2; ++ii) {
v[ii - 1] = 0.;
/* L100: */
}
nv = 1;
i__2 = i__;
for (j = i__ - ns + 1; j <= i__2; ++j) {
if (wi[j] >= 0.) {
if (wi[j] == 0.) {
/* real shift */
i__4 = nv + 1;
dcopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
d__1 = -wr[j];
dgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l *
h_dim1], ldh, vv, &c__1, &d__1, v, &c__1, 12L);
++nv;
} else if (wi[j] > 0.) {
/* complex conjugate pair of shifts */
i__4 = nv + 1;
dcopy_(&i__4, v, &c__1, vv, &c__1);
i__4 = nv + 1;
d__1 = wr[j] * -2.;
dgemv_("No transpose", &i__4, &nv, &c_b10, &h__[l + l *
h_dim1], ldh, v, &c__1, &d__1, vv, &c__1, 12L);
i__4 = nv + 1;
itemp = idamax_(&i__4, vv, &c__1);
/* Computing MAX */
d__2 = (d__1 = vv[itemp - 1], abs(d__1));
temp = 1. / max(d__2,smlnum);
i__4 = nv + 1;
dscal_(&i__4, &temp, vv, &c__1);
absw = dlapy2_(&wr[j], &wi[j]);
temp = temp * absw * absw;
i__4 = nv + 2;
i__5 = nv + 1;
dgemv_("No transpose", &i__4, &i__5, &c_b10, &h__[l + l *
h_dim1], ldh, vv, &c__1, &temp, v, &c__1, 12L);
nv += 2;
}
/* Scale V(1:NV) so that max(abs(V(i))) = 1. If V
is zero, */
/* reset it to the unit vector. */
itemp = idamax_(&nv, v, &c__1);
temp = (d__1 = v[itemp - 1], abs(d__1));
if (temp == 0.) {
v[0] = 1.;
i__4 = nv;
for (ii = 2; ii <= i__4; ++ii) {
v[ii - 1] = 0.;
/* L110: */
}
} else {
temp = max(temp,smlnum);
d__1 = 1. / temp;
dscal_(&nv, &d__1, v, &c__1);
}
}
/* L120: */
}
/* Multiple-shift QR step */
i__2 = i__ - 1;
for (k = l; k <= i__2; ++k) {
/* The first iteration of this loop determines a reflect
ion G */
/* from the vector V and applies it from left and right
to H, */
/* thus creating a nonzero bulge below the subdiagonal.
*/
/* Each subsequent iteration determines a reflection G t
o */
/* restore the Hessenberg form in the (K-1)th column, an
d thus */
/* chases the bulge one step toward the bottom of the ac
tive */
/* submatrix. NR is the order of G. */
/* Computing MIN */
i__4 = ns + 1, i__5 = i__ - k + 1;
nr = min(i__4,i__5);
if (k > l) {
dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
dlarfg_(&nr, v, &v[1], &c__1, &tau);
if (k > l) {
h__[k + (k - 1) * h_dim1] = v[0];
i__4 = i__;
for (ii = k + 1; ii <= i__4; ++ii) {
h__[ii + (k - 1) * h_dim1] = 0.;
/* L130: */
}
}
v[0] = 1.;
/* Apply G from the left to transform the rows of the ma
trix in */
/* columns K to I2. */
i__4 = i2 - k + 1;
dlarfx_("Left", &nr, &i__4, v, &tau, &h__[k + k * h_dim1], ldh, &
work[1], 4L);
/* Apply G from the right to transform the columns of th
e */
/* matrix in rows I1 to min(K+NR,I). */
/* Computing MIN */
i__5 = k + nr;
i__4 = min(i__5,i__) - i1 + 1;
dlarfx_("Right", &i__4, &nr, v, &tau, &h__[i1 + k * h_dim1], ldh,
&work[1], 5L);
if (wantz) {
/* Accumulate transformations in the matrix Z */
dlarfx_("Right", &nh, &nr, v, &tau, &z__[*ilo + k * z_dim1],
ldz, &work[1], 5L);
}
/* L140: */
}
/* L150: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L160:
/* A submatrix of order <= MAXB in rows and columns L to I has split
*/
/* off. Use the double-shift QR algorithm to handle it. */
dlahqr_(&wantt, &wantz, n, &l, &i__, &h__[h_offset], ldh, &wr[1], &wi[1],
ilo, ihi, &z__[z_offset], ldz, info);
if (*info > 0) {
return 0;
}
/* Decrement number of remaining iterations, and return to start of */
/* the main loop with a new value of I. */
itn -= its;
i__ = l - 1;
goto L50;
L170:
return 0;
/* End of DHSEQR */
} /* dhseqr_ */
/* dorgqr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dorgqr_(m, n, k, a, lda, tau, work, lwork, info)
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j, l, nbmin, iinfo;
extern /* Subroutine */ int dorg2r_();
static integer ib, nb, ki, kk;
extern /* Subroutine */ int dlarfb_();
static integer nx;
extern /* Subroutine */ int dlarft_(), xerbla_();
extern integer ilaenv_();
static integer ldwork, iws;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORGQR generates an M-by-N real matrix Q with orthonormal columns, */
/* which is defined as the first N columns of a product of K elementary
*/
/* reflectors of order M */
/* Q = H(1) H(2) . . . H(k) */
/* as returned by DGEQRF. */
/* 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the i-th column must contain the vector which */
/* defines the elementary reflector H(i), for i = 1,2,...,k, as
*/
/* returned by DGEQRF in the first 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) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DGEQRF. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,N). */
/* For optimum performance LWORK >= N*NB, where NB is the */
/* optimal blocksize. */
/* 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
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;
} else if (*lwork < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DORGQR", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n <= 0) {
work[1] = 1.;
return 0;
}
/* Determine the block size. */
nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1, 6L, 1L);
nbmin = 2;
nx = 0;
iws = *n;
if (nb > 1 && nb < *k) {
/* Determine when to cross over from blocked to unblocked code.
*/
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "DORGQR", " ", m, n, k, &c_n1, 6L, 1L)
;
nx = max(i__1,i__2);
if (nx < *k) {
/* Determine if workspace is large enough for blocked co
de. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduc
e NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "DORGQR", " ", m, n, k, &c_n1,
6L, 1L);
nbmin = max(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < *k && nx < *k) {
/* Use blocked code after the last block. */
/* The first kk columns are handled by the block method. */
ki = (*k - nx - 1) / nb * nb;
/* Computing MIN */
i__1 = *k, i__2 = ki + nb;
kk = min(i__1,i__2);
/* Set A(1:kk,kk+1:n) to zero. */
i__1 = *n;
for (j = kk + 1; j <= i__1; ++j) {
i__2 = kk;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
/* L10: */
}
/* L20: */
}
} else {
kk = 0;
}
/* Use unblocked code for the last or only block. */
if (kk < *n) {
i__1 = *m - kk;
i__2 = *n - kk;
i__3 = *k - kk;
dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
tau[kk + 1], &work[1], &iinfo);
}
if (kk > 0) {
/* Use blocked code */
i__1 = -nb;
for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
/* Computing MIN */
i__2 = nb, i__3 = *k - i__ + 1;
ib = min(i__2,i__3);
if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflec
tor */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__2 = *m - i__ + 1;
dlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 10L);
/* Apply H to A(i:m,i+ib:n) from the left */
i__2 = *m - i__ + 1;
i__3 = *n - i__ - ib + 1;
dlarfb_("Left", "No transpose", "Forward", "Columnwise", &
i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &
work[ib + 1], &ldwork, 4L, 12L, 7L, 10L);
}
/* Apply H to rows i:m of current block */
i__2 = *m - i__ + 1;
dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
work[1], &iinfo);
/* Set rows 1:i-1 of current block to zero */
i__2 = i__ + ib - 1;
for (j = i__; j <= i__2; ++j) {
i__3 = i__ - 1;
for (l = 1; l <= i__3; ++l) {
a[l + j * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
/* L50: */
}
}
work[1] = (doublereal) iws;
return 0;
/* End of DORGQR */
} /* dorgqr_ */
/* dgelq2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dgelq2_(m, n, a, lda, tau, work, info)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, k;
extern /* Subroutine */ int dlarf_(), dlarfg_(), xerbla_();
static doublereal aii;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGELQ2 computes an LQ factorization of a real m by n matrix A: */
/* A = L * 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the m by n matrix A. */
/* On exit, the elements on and below the diagonal of the array
*/
/* contain the m by min(m,n) lower trapezoidal matrix L (L is */
/* lower triangular if m <= n); the elements above 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) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). */
/* WORK (workspace) DOUBLE PRECISION 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(k) . . . H(2) H(1), 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:n) is stored on exit in A(i,i+1:n),
*/
/* 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 = a_dim1 + 1;
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_("DGELQ2", &i__1, 6L);
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,i+1:n)
*/
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3,*n) * a_dim1]
, lda, &tau[i__]);
if (i__ < *m) {
/* Apply H(i) to A(i+1:m,i:n) from the right */
aii = a[i__ + i__ * a_dim1];
a[i__ + i__ * a_dim1] = 1.;
i__2 = *m - i__;
i__3 = *n - i__ + 1;
dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1], 5L);
a[i__ + i__ * a_dim1] = aii;
}
/* L10: */
}
return 0;
/* End of DGELQ2 */
} /* dgelq2_ */
/* dgebrd.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b21
#undef c_b21
#endif
#define c_b21 c_b21
#ifdef c_b22
#undef c_b22
#endif
#define c_b22 c_b22
/* Subroutine */ int dgebrd_(m, n, a, lda, d__, e, tauq, taup, work, lwork,
info)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *d__, *e, *tauq, *taup, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__, j;
extern /* Subroutine */ int dgemm_();
static integer nbmin, iinfo, minmn;
extern /* Subroutine */ int dgebd2_();
static integer nb;
extern /* Subroutine */ int dlabrd_();
static integer nx;
static doublereal ws;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
static integer ldwrkx, ldwrky;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEBRD reduces a general real M-by-N matrix A to upper or lower */
/* bidiagonal form B by an orthogonal transformation: Q**T * 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The diagonal elements of the bidiagonal matrix B: */
/* D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION 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) DOUBLE PRECISION array dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix Q. See Further Details. */
/* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix P. See Further Details. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,M,N). */
/* For optimum performance LWORK >= (M+N)*NB, where NB */
/* is the optimal blocksize. */
/* 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
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;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = max(1,*m);
if (*lwork < max(i__1,*n)) {
*info = -10;
}
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("DGEBRD", &i__1, 6L);
return 0;
}
/* Quick return if possible */
minmn = min(*m,*n);
if (minmn == 0) {
work[1] = 1.;
return 0;
}
ws = (doublereal) max(*m,*n);
ldwrkx = *m;
ldwrky = *n;
/* Set the block size NB and the crossover point NX. */
/* Computing MAX */
i__1 = 1, i__2 = ilaenv_(&c__1, "DGEBRD", " ", m, n, &c_n1, &c_n1, 6L, 1L)
;
nb = max(i__1,i__2);
if (nb > 1 && nb < minmn) {
/* Determine when to switch from blocked to unblocked code. */
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__3, "DGEBRD", " ", m, n, &c_n1, &c_n1,
6L, 1L);
nx = max(i__1,i__2);
if (nx < minmn) {
ws = (doublereal) ((*m + *n) * nb);
if ((doublereal) (*lwork) < ws) {
/* Not enough work space for the optimal NB, cons
ider using */
/* a smaller block size. */
nbmin = ilaenv_(&c__2, "DGEBRD", " ", m, n, &c_n1, &c_n1, 6L,
1L);
if (*lwork >= (*m + *n) * nbmin) {
nb = *lwork / (*m + *n);
} else {
nb = 1;
nx = minmn;
}
}
}
} else {
nx = minmn;
}
i__1 = minmn - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Reduce rows and columns i:i+nb-1 to bidiagonal form and retu
rn */
/* the matrices X and Y which are needed to update the unreduce
d */
/* part of the matrix */
i__3 = *m - i__ + 1;
i__4 = *n - i__ + 1;
dlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[
i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx
* nb + 1], &ldwrky);
/* Update the trailing submatrix A(i+nb:m,i+nb:n), using an upd
ate */
/* of the form A := A - V*Y' - X*U' */
i__3 = *m - i__ - nb + 1;
i__4 = *n - i__ - nb + 1;
dgemm_("No transpose", "Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__
+ nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], &
ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, 12L,
9L);
i__3 = *m - i__ - nb + 1;
i__4 = *n - i__ - nb + 1;
dgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &c_b21, &
work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, &
c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda, 12L, 12L);
/* Copy diagonal and off-diagonal elements of B back into A */
if (*m >= *n) {
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
a[j + j * a_dim1] = d__[j];
a[j + (j + 1) * a_dim1] = e[j];
/* L10: */
}
} else {
i__3 = i__ + nb - 1;
for (j = i__; j <= i__3; ++j) {
a[j + j * a_dim1] = d__[j];
a[j + 1 + j * a_dim1] = e[j];
/* L20: */
}
}
/* L30: */
}
/* Use unblocked code to reduce the remainder of the matrix */
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &
tauq[i__], &taup[i__], &work[1], &iinfo);
work[1] = ws;
return 0;
/* End of DGEBRD */
} /* dgebrd_ */
/* dgehd2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dgehd2_(n, ilo, ihi, a, lda, tau, work, info)
integer *n, *ilo, *ihi;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__;
extern /* Subroutine */ int dlarf_(), dlarfg_(), xerbla_();
static doublereal aii;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEHD2 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 DGEBAL; otherwise they should be */
/* set to 1 and N respectively. See Further Details. */
/* 1 <= ILO <= IHI <= max(1,N). */
/* A (input/output) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N-1) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). */
/* WORK (workspace) DOUBLE PRECISION 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 = 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_("DGEHD2", &i__1, 6L);
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;
dlarfg_(&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.;
/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
i__2 = *ihi - i__;
dlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1], 5L);
/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */
i__2 = *ihi - i__;
i__3 = *n - i__;
dlarf_("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], 4L);
a[i__ + 1 + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of DGEHD2 */
} /* dgehd2_ */
/* dorglq.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dorglq_(m, n, k, a, lda, tau, work, lwork, info)
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j, l, nbmin, iinfo;
extern /* Subroutine */ int dorgl2_();
static integer ib, nb, ki, kk;
extern /* Subroutine */ int dlarfb_();
static integer nx;
extern /* Subroutine */ int dlarft_(), xerbla_();
extern integer ilaenv_();
static integer ldwork, iws;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORGLQ 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 DGELQF. */
/* 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) DOUBLE PRECISION 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 DGELQF 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) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DGELQF. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,M). */
/* For optimum performance LWORK >= M*NB, where NB is */
/* the optimal blocksize. */
/* 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 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;
} else if (*lwork < max(1,*m)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DORGLQ", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
work[1] = 1.;
return 0;
}
/* Determine the block size. */
nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1, 6L, 1L);
nbmin = 2;
nx = 0;
iws = *m;
if (nb > 1 && nb < *k) {
/* Determine when to cross over from blocked to unblocked code.
*/
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "DORGLQ", " ", m, n, k, &c_n1, 6L, 1L)
;
nx = max(i__1,i__2);
if (nx < *k) {
/* Determine if workspace is large enough for blocked co
de. */
ldwork = *m;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduc
e NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "DORGLQ", " ", m, n, k, &c_n1,
6L, 1L);
nbmin = max(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < *k && nx < *k) {
/* Use blocked code after the last block. */
/* The first kk rows are handled by the block method. */
ki = (*k - nx - 1) / nb * nb;
/* Computing MIN */
i__1 = *k, i__2 = ki + nb;
kk = min(i__1,i__2);
/* Set A(kk+1:m,1:kk) to zero. */
i__1 = kk;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = kk + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
/* L10: */
}
/* L20: */
}
} else {
kk = 0;
}
/* Use unblocked code for the last or only block. */
if (kk < *m) {
i__1 = *m - kk;
i__2 = *n - kk;
i__3 = *k - kk;
dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
tau[kk + 1], &work[1], &iinfo);
}
if (kk > 0) {
/* Use blocked code */
i__1 = -nb;
for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
/* Computing MIN */
i__2 = nb, i__3 = *k - i__ + 1;
ib = min(i__2,i__3);
if (i__ + ib <= *m) {
/* Form the triangular factor of the block reflec
tor */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__2 = *n - i__ + 1;
dlarft_("Forward", "Rowwise", &i__2, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 7L);
/* Apply H' to A(i+ib:m,i:n) from the right */
i__2 = *m - i__ - ib + 1;
i__3 = *n - i__ + 1;
dlarfb_("Right", "Transpose", "Forward", "Rowwise", &i__2, &
i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
1], &ldwork, 5L, 9L, 7L, 7L);
}
/* Apply H' to columns i:n of current block */
i__2 = *n - i__ + 1;
dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
work[1], &iinfo);
/* Set columns 1:i-1 of current block to zero */
i__2 = i__ - 1;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + ib - 1;
for (l = i__; l <= i__3; ++l) {
a[l + j * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
/* L50: */
}
}
work[1] = (doublereal) iws;
return 0;
/* End of DORGLQ */
} /* dorglq_ */
/* dlasv2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b3
#undef c_b3
#endif
#define c_b3 c_b3
#ifdef c_b4
#undef c_b4
#endif
#define c_b4 c_b4
/* Subroutine */ int dlasv2_(f, g, h__, ssmin, ssmax, snr, csr, snl, csl)
doublereal *f, *g, *h__, *ssmin, *ssmax, *snr, *csr, *snl, *csl;
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double sqrt(), d_sign();
/* Local variables */
static integer pmax;
static doublereal temp;
static logical swap;
static doublereal a, d__, l, m, r__, s, t, tsign, fa, ga, ha;
extern doublereal dlamch_();
static doublereal ft, gt, ht, mm;
static logical gasmal;
static doublereal tt, clt, crt, slt, srt;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASV2 computes the singular value decomposition of a 2-by-2 */
/* triangular matrix */
/* [ F G ] */
/* [ 0 H ]. */
/* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
*/
/* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
*/
/* right singular vectors for abs(SSMAX), giving the decomposition */
/* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] */
/* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. */
/* Arguments */
/* ========= */
/* F (input) DOUBLE PRECISION */
/* The (1,1) element of the 2-by-2 matrix. */
/* G (input) DOUBLE PRECISION */
/* The (1,2) element of the 2-by-2 matrix. */
/* H (input) DOUBLE PRECISION */
/* The (2,2) element of the 2-by-2 matrix. */
/* SSMIN (output) DOUBLE PRECISION */
/* abs(SSMIN) is the smaller singular value. */
/* SSMAX (output) DOUBLE PRECISION */
/* abs(SSMAX) is the larger singular value. */
/* SNL (output) DOUBLE PRECISION */
/* CSL (output) DOUBLE PRECISION */
/* The vector (CSL, SNL) is a unit left singular vector for the
*/
/* singular value abs(SSMAX). */
/* SNR (output) DOUBLE PRECISION */
/* CSR (output) DOUBLE PRECISION */
/* The vector (CSR, SNR) is a unit right singular vector for the
*/
/* singular value abs(SSMAX). */
/* Further Details */
/* =============== */
/* Any input parameter may be aliased with any output parameter. */
/* Barring over/underflow and assuming a guard digit in subtraction, all
*/
/* output quantities are correct to within a few units in the last */
/* place (ulps). */
/* In IEEE arithmetic, the code works correctly if one matrix element is
*/
/* infinite. */
/* Overflow will not occur unless the largest singular value itself */
/* overflows or is within a few ulps of overflow. (On machines with */
/* partial overflow, like the Cray, overflow may occur if the largest */
/* singular value is within a factor of 2 of overflow.) */
/* Underflow is harmless if underflow is gradual. Otherwise, results */
/* may correspond to a matrix modified by perturbations of size near */
/* the underflow threshold. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
ft = *f;
fa = abs(ft);
ht = *h__;
ha = abs(*h__);
/* PMAX points to the maximum absolute element of matrix */
/* PMAX = 1 if F largest in absolute values */
/* PMAX = 2 if G largest in absolute values */
/* PMAX = 3 if H largest in absolute values */
pmax = 1;
swap = ha > fa;
if (swap) {
pmax = 3;
temp = ft;
ft = ht;
ht = temp;
temp = fa;
fa = ha;
ha = temp;
/* Now FA .ge. HA */
}
gt = *g;
ga = abs(gt);
if (ga == 0.) {
/* Diagonal matrix */
*ssmin = ha;
*ssmax = fa;
clt = 1.;
crt = 1.;
slt = 0.;
srt = 0.;
} else {
gasmal = TRUE_;
if (ga > fa) {
pmax = 2;
if (fa / ga < dlamch_("EPS", 3L)) {
/* Case of very large GA */
gasmal = FALSE_;
*ssmax = ga;
if (ha > 1.) {
*ssmin = fa / (ga / ha);
} else {
*ssmin = fa / ga * ha;
}
clt = 1.;
slt = ht / gt;
srt = 1.;
crt = ft / gt;
}
}
if (gasmal) {
/* Normal case */
d__ = fa - ha;
if (d__ == fa) {
/* Copes with infinite F or H */
l = 1.;
} else {
l = d__ / fa;
}
/* Note that 0 .le. L .le. 1 */
m = gt / ft;
/* Note that abs(M) .le. 1/macheps */
t = 2. - l;
/* Note that T .ge. 1 */
mm = m * m;
tt = t * t;
s = sqrt(tt + mm);
/* Note that 1 .le. S .le. 1 + 1/macheps */
if (l == 0.) {
r__ = abs(m);
} else {
r__ = sqrt(l * l + mm);
}
/* Note that 0 .le. R .le. 1 + 1/macheps */
a = (s + r__) * .5;
/* Note that 1 .le. A .le. 1 + abs(M) */
*ssmin = ha / a;
*ssmax = fa * a;
if (mm == 0.) {
/* Note that M is very tiny */
if (l == 0.) {
t = d_sign(&c_b3, &ft) * d_sign(&c_b4, >);
} else {
t = gt / d_sign(&d__, &ft) + m / t;
}
} else {
t = (m / (s + t) + m / (r__ + l)) * (a + 1.);
}
l = sqrt(t * t + 4.);
crt = 2. / l;
srt = t / l;
clt = (crt + srt * m) / a;
slt = ht / ft * srt / a;
}
}
if (swap) {
*csl = srt;
*snl = crt;
*csr = slt;
*snr = clt;
} else {
*csl = clt;
*snl = slt;
*csr = crt;
*snr = srt;
}
/* Correct signs of SSMAX and SSMIN */
if (pmax == 1) {
tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f);
}
if (pmax == 2) {
tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g);
}
if (pmax == 3) {
tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__);
}
*ssmax = d_sign(ssmax, &tsign);
d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__);
*ssmin = d_sign(ssmin, &d__1);
return 0;
/* End of DLASV2 */
} /* dlasv2_ */
/* dorghr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dorghr_(n, ilo, ihi, a, lda, tau, work, lwork, info)
integer *n, *ilo, *ihi;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer i__, j, iinfo, nh;
extern /* Subroutine */ int xerbla_(), dorgqr_();
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORGHR generates a real orthogonal matrix Q which is defined as the */
/* product of IHI-ILO elementary reflectors of order N, as returned by */
/* DGEHRD: */
/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix Q. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* ILO and IHI must have the same values as in the previous call
*/
/* of DGEHRD. Q is equal to the unit matrix except in the */
/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the vectors which define the elementary reflectors,
*/
/* as returned by DGEHRD. */
/* On exit, the N-by-N orthogonal matrix Q. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (input) DOUBLE PRECISION array, dimension (N-1) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DGEHRD. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= IHI-ILO. */
/* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is */
/* the optimal blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 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;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *ihi - *ilo;
if (*lwork < max(i__1,i__2)) {
*info = -8;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DORGHR", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
work[1] = 1.;
return 0;
}
/* Shift the vectors which define the elementary reflectors one */
/* column to the right, and set the first ilo and the last n-ihi */
/* rows and columns to those of the unit matrix */
i__1 = *ilo + 1;
for (j = *ihi; j >= i__1; --j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
/* L10: */
}
i__2 = *ihi;
for (i__ = j + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
/* L20: */
}
i__2 = *n;
for (i__ = *ihi + 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
i__1 = *ilo;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
/* L50: */
}
a[j + j * a_dim1] = 1.;
/* L60: */
}
i__1 = *n;
for (j = *ihi + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = 0.;
/* L70: */
}
a[j + j * a_dim1] = 1.;
/* L80: */
}
nh = *ihi - *ilo;
if (nh > 0) {
/* Generate Q(ilo+1:ihi,ilo+1:ihi) */
dorgqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[*
ilo], &work[1], lwork, &iinfo);
}
return 0;
/* End of DORGHR */
} /* dorghr_ */
/* dlasq4.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b4
#undef c_b4
#endif
#define c_b4 c_b4a
/* Subroutine */ int dlasq4_(n, q, e, tau, sup)
integer *n;
doublereal *q, *e, *tau, *sup;
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double pow_di();
/* Local variables */
static doublereal xinf, d__;
static integer i__;
static doublereal dm;
static integer ifl;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASQ4 estimates TAU, the smallest eigenvalue of a matrix. This */
/* routine improves the input value of SUP which is an upper bound */
/* for the smallest eigenvalue for this matrix . */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* On entry, N specifies the number of rows and columns */
/* in the matrix. N must be at least 0. */
/* Q (input) DOUBLE PRECISION array, dimension (N) */
/* Q array */
/* E (input) DOUBLE PRECISION array, dimension (N) */
/* E array */
/* TAU (output) DOUBLE PRECISION */
/* Estimate of the shift */
/* SUP (input/output) DOUBLE PRECISION */
/* Upper bound for the smallest singular value */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--e;
--q;
/* Function Body */
ifl = 1;
/* Computing MIN */
d__1 = min(*sup,q[1]), d__1 = min(d__1,q[2]), d__1 = min(d__1,q[3]), d__2
= q[*n], d__1 = min(d__1,d__2), d__2 = q[*n - 1], d__1 = min(d__1,
d__2), d__2 = q[*n - 2];
*sup = min(d__1,d__2);
*tau = *sup * .9999;
xinf = 0.;
L10:
if (ifl == 5) {
*tau = xinf;
return 0;
}
d__ = q[1] - *tau;
dm = d__;
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
d__ = d__ / (d__ + e[i__]) * q[i__ + 1] - *tau;
if (dm > d__) {
dm = d__;
}
if (d__ < 0.) {
*sup = *tau;
/* Computing MAX */
d__1 = *sup * pow_di(&c_b4, &ifl), d__2 = d__ + *tau;
*tau = max(d__1,d__2);
++ifl;
goto L10;
}
/* L20: */
}
d__ = d__ / (d__ + e[*n - 1]) * q[*n] - *tau;
if (dm > d__) {
dm = d__;
}
if (d__ < 0.) {
*sup = *tau;
/* Computing MAX */
d__1 = xinf, d__2 = d__ + *tau;
xinf = max(d__1,d__2);
if (*sup * pow_di(&c_b4, &ifl) <= xinf) {
*tau = xinf;
} else {
*tau = *sup * pow_di(&c_b4, &ifl);
++ifl;
goto L10;
}
} else {
/* Computing MIN */
d__1 = *sup, d__2 = dm + *tau;
*sup = min(d__1,d__2);
}
return 0;
/* End of DLASQ4 */
} /* dlasq4_ */
/* dlapy2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
doublereal dlapy2_(x, y)
doublereal *x, *y;
{
/* System generated locals */
doublereal ret_val, d__1;
/* Builtin functions */
double sqrt();
/* Local variables */
static doublereal xabs, yabs, w, z__;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
*/
/* overflow. */
/* Arguments */
/* ========= */
/* X (input) DOUBLE PRECISION */
/* Y (input) DOUBLE PRECISION */
/* X and Y specify the values x and y. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
xabs = abs(*x);
yabs = abs(*y);
w = max(xabs,yabs);
z__ = min(xabs,yabs);
if (z__ == 0.) {
ret_val = w;
} else {
/* Computing 2nd power */
d__1 = z__ / w;
ret_val = w * sqrt(d__1 * d__1 + 1.);
}
return ret_val;
/* End of DLAPY2 */
} /* dlapy2_ */
/* dlapy3.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
doublereal dlapy3_(x, y, z__)
doublereal *x, *y, *z__;
{
/* System generated locals */
doublereal ret_val, d__1, d__2, d__3;
/* Builtin functions */
double sqrt();
/* Local variables */
static doublereal xabs, yabs, zabs, w;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause */
/* unnecessary overflow. */
/* Arguments */
/* ========= */
/* X (input) DOUBLE PRECISION */
/* Y (input) DOUBLE PRECISION */
/* Z (input) DOUBLE PRECISION */
/* X, Y and Z specify the values x, y and z. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
xabs = abs(*x);
yabs = abs(*y);
zabs = abs(*z__);
/* Computing MAX */
d__1 = max(xabs,yabs);
w = max(d__1,zabs);
if (w == 0.) {
ret_val = 0.;
} else {
/* Computing 2nd power */
d__1 = xabs / w;
/* Computing 2nd power */
d__2 = yabs / w;
/* Computing 2nd power */
d__3 = zabs / w;
ret_val = w * sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3);
}
return ret_val;
/* End of DLAPY3 */
} /* dlapy3_ */
/* dlasq2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlasq2_(m, q, e, qq, ee, eps, tol2, small2, sup, kend,
info)
integer *m;
doublereal *q, *e, *qq, *ee, *eps, *tol2, *small2, *sup;
integer *kend, *info;
{
/* System generated locals */
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt();
integer i_dnnt();
/* Local variables */
static doublereal xinf;
static integer n;
static doublereal sigma, qemax;
static integer iconv;
extern /* Subroutine */ int dlasq3_();
static integer iphase;
static doublereal xx, yy;
static integer off, isp, off1;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASQ2 computes the singular values of a real N-by-N unreduced */
/* bidiagonal matrix with squared diagonal elements in Q and */
/* squared off-diagonal elements in E. The singular values are */
/* computed to relative accuracy TOL, barring over/underflow or */
/* denormalization. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows and columns in the matrix. M >= 0. */
/* Q (output) DOUBLE PRECISION array, dimension (M) */
/* On normal exit, contains the squared singular values. */
/* E (workspace) DOUBLE PRECISION array, dimension (M) */
/* QQ (input/output) DOUBLE PRECISION array, dimension (M) */
/* On entry, QQ contains the squared diagonal elements of the */
/* bidiagonal matrix whose SVD is desired. */
/* On exit, QQ is overwritten. */
/* EE (input/output) DOUBLE PRECISION array, dimension (M) */
/* On entry, EE(1:N-1) contains the squared off-diagonal */
/* elements of the bidiagonal matrix whose SVD is desired. */
/* On exit, EE is overwritten. */
/* EPS (input) DOUBLE PRECISION */
/* Machine epsilon. */
/* TOL2 (input) DOUBLE PRECISION */
/* Desired relative accuracy of computed eigenvalues */
/* as defined in DLASQ1. */
/* SMALL2 (input) DOUBLE PRECISION */
/* A threshold value as defined in DLASQ1. */
/* SUP (input/output) DOUBLE PRECISION */
/* Upper bound for the smallest eigenvalue. */
/* KEND (input/output) INTEGER */
/* Index where minimum d occurs. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the algorithm did not converge; i */
/* specifies how many superdiagonals did not converge. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ee;
--qq;
--e;
--q;
/* Function Body */
n = *m;
/* Set the default maximum number of iterations */
off = 0;
off1 = off + 1;
sigma = 0.;
xinf = 0.;
iconv = 0;
iphase = 2;
/* Try deflation at the bottom */
/* 1x1 deflation */
L10:
if (n <= 2) {
goto L20;
}
/* Computing MAX */
d__1 = qq[n], d__1 = max(d__1,xinf);
if (ee[n - 1] <= max(d__1,*small2) * *tol2) {
q[n] = qq[n];
--n;
if (*kend > n) {
*kend = n;
}
/* Computing MIN */
d__1 = qq[n], d__2 = qq[n - 1];
*sup = min(d__1,d__2);
goto L10;
}
/* 2x2 deflation */
/* Computing MAX */
d__1 = max(xinf,*small2), d__2 = qq[n] / (qq[n] + ee[n - 1] + qq[n - 1]) *
qq[n - 1];
if (ee[n - 2] <= max(d__1,d__2) * *tol2) {
/* Computing MAX */
d__1 = qq[n], d__2 = qq[n - 1], d__1 = max(d__1,d__2), d__2 = ee[n -
1];
qemax = max(d__1,d__2);
if (qemax != 0.) {
if (qemax == qq[n - 1]) {
/* Computing 2nd power */
d__1 = (qq[n] - qq[n - 1] + ee[n - 1]) / qemax;
xx = (qq[n] + qq[n - 1] + ee[n - 1] + qemax * sqrt(d__1 *
d__1 + ee[n - 1] * 4. / qemax)) * .5;
} else if (qemax == qq[n]) {
/* Computing 2nd power */
d__1 = (qq[n - 1] - qq[n] + ee[n - 1]) / qemax;
xx = (qq[n] + qq[n - 1] + ee[n - 1] + qemax * sqrt(d__1 *
d__1 + ee[n - 1] * 4. / qemax)) * .5;
} else {
/* Computing 2nd power */
d__1 = (qq[n] - qq[n - 1] + ee[n - 1]) / qemax;
xx = (qq[n] + qq[n - 1] + ee[n - 1] + qemax * sqrt(d__1 *
d__1 + qq[n - 1] * 4. / qemax)) * .5;
}
/* Computing MAX */
d__1 = qq[n], d__2 = qq[n - 1];
/* Computing MIN */
d__3 = qq[n], d__4 = qq[n - 1];
yy = max(d__1,d__2) / xx * min(d__3,d__4);
} else {
xx = 0.;
yy = 0.;
}
q[n - 1] = xx;
q[n] = yy;
n += -2;
if (*kend > n) {
*kend = n;
}
*sup = qq[n];
goto L10;
}
L20:
if (n == 0) {
/* The lower branch is finished */
if (off == 0) {
/* No upper branch; return to DLASQ1 */
return 0;
} else {
/* Going back to upper branch */
xinf = 0.;
if (ee[off] > 0.) {
isp = i_dnnt(&ee[off]);
iphase = 1;
} else {
isp = -i_dnnt(&ee[off]);
iphase = 2;
}
sigma = e[off];
n = off - isp + 1;
off1 = isp;
off = off1 - 1;
if (n <= 2) {
goto L20;
}
if (iphase == 1) {
/* Computing MIN */
d__1 = q[n + off], d__2 = q[n - 1 + off], d__1 = min(d__1,
d__2), d__2 = q[n - 2 + off];
*sup = min(d__1,d__2);
} else {
/* Computing MIN */
d__1 = qq[n + off], d__2 = qq[n - 1 + off], d__1 = min(d__1,
d__2), d__2 = qq[n - 2 + off];
*sup = min(d__1,d__2);
}
*kend = 0;
iconv = -3;
}
} else if (n == 1) {
/* 1x1 Solver */
if (iphase == 1) {
q[off1] += sigma;
} else {
q[off1] = qq[off1] + sigma;
}
n = 0;
goto L20;
/* 2x2 Solver */
} else if (n == 2) {
if (iphase == 2) {
/* Computing MAX */
d__1 = qq[n + off], d__2 = qq[n - 1 + off], d__1 = max(d__1,d__2),
d__2 = ee[n - 1 + off];
qemax = max(d__1,d__2);
if (qemax != 0.) {
if (qemax == qq[n - 1 + off]) {
/* Computing 2nd power */
d__1 = (qq[n + off] - qq[n - 1 + off] + ee[n - 1 + off]) /
qemax;
xx = (qq[n + off] + qq[n - 1 + off] + ee[n - 1 + off] +
qemax * sqrt(d__1 * d__1 + ee[off + n - 1] * 4. /
qemax)) * .5;
} else if (qemax == qq[n + off]) {
/* Computing 2nd power */
d__1 = (qq[n - 1 + off] - qq[n + off] + ee[n - 1 + off]) /
qemax;
xx = (qq[n + off] + qq[n - 1 + off] + ee[n - 1 + off] +
qemax * sqrt(d__1 * d__1 + ee[n - 1 + off] * 4. /
qemax)) * .5;
} else {
/* Computing 2nd power */
d__1 = (qq[n + off] - qq[n - 1 + off] + ee[n - 1 + off]) /
qemax;
xx = (qq[n + off] + qq[n - 1 + off] + ee[n - 1 + off] +
qemax * sqrt(d__1 * d__1 + qq[n - 1 + off] * 4. /
qemax)) * .5;
}
/* Computing MAX */
d__1 = qq[n + off], d__2 = qq[n - 1 + off];
/* Computing MIN */
d__3 = qq[n + off], d__4 = qq[n - 1 + off];
yy = max(d__1,d__2) / xx * min(d__3,d__4);
} else {
xx = 0.;
yy = 0.;
}
} else {
/* Computing MAX */
d__1 = q[n + off], d__2 = q[n - 1 + off], d__1 = max(d__1,d__2),
d__2 = e[n - 1 + off];
qemax = max(d__1,d__2);
if (qemax != 0.) {
if (qemax == q[n - 1 + off]) {
/* Computing 2nd power */
d__1 = (q[n + off] - q[n - 1 + off] + e[n - 1 + off]) /
qemax;
xx = (q[n + off] + q[n - 1 + off] + e[n - 1 + off] +
qemax * sqrt(d__1 * d__1 + e[n - 1 + off] * 4. /
qemax)) * .5;
} else if (qemax == q[n + off]) {
/* Computing 2nd power */
d__1 = (q[n - 1 + off] - q[n + off] + e[n - 1 + off]) /
qemax;
xx = (q[n + off] + q[n - 1 + off] + e[n - 1 + off] +
qemax * sqrt(d__1 * d__1 + e[n - 1 + off] * 4. /
qemax)) * .5;
} else {
/* Computing 2nd power */
d__1 = (q[n + off] - q[n - 1 + off] + e[n - 1 + off]) /
qemax;
xx = (q[n + off] + q[n - 1 + off] + e[n - 1 + off] +
qemax * sqrt(d__1 * d__1 + q[n - 1 + off] * 4. /
qemax)) * .5;
}
/* Computing MAX */
d__1 = q[n + off], d__2 = q[n - 1 + off];
/* Computing MIN */
d__3 = q[n + off], d__4 = q[n - 1 + off];
yy = max(d__1,d__2) / xx * min(d__3,d__4);
} else {
xx = 0.;
yy = 0.;
}
}
q[n - 1 + off] = sigma + xx;
q[n + off] = yy + sigma;
n = 0;
goto L20;
}
dlasq3_(&n, &q[off1], &e[off1], &qq[off1], &ee[off1], sup, &sigma, kend, &
off, &iphase, &iconv, eps, tol2, small2);
if (*sup < 0.) {
*info = n + off;
return 0;
}
off1 = off + 1;
goto L20;
/* End of DLASQ2 */
} /* dlasq2_ */
/* dgeev.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dgeev_(jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,
ldvr, work, lwork, info, jobvl_len, jobvr_len)
char *jobvl, *jobvr;
integer *n;
doublereal *a;
integer *lda;
doublereal *wr, *wi, *vl;
integer *ldvl;
doublereal *vr;
integer *ldvr;
doublereal *work;
integer *lwork, *info;
ftnlen jobvl_len;
ftnlen jobvr_len;
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3, i__4;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt();
/* Local variables */
static integer ibal;
static char side[1];
static integer maxb;
static doublereal anrm;
static integer ierr, itau;
extern /* Subroutine */ int drot_();
static integer iwrk, nout;
extern doublereal dnrm2_();
static integer i__, k;
static doublereal r__;
extern /* Subroutine */ int dscal_();
extern logical lsame_();
extern doublereal dlapy2_();
extern /* Subroutine */ int dlabad_(), dgebak_(), dgebal_();
static doublereal cs;
static logical scalea;
extern doublereal dlamch_();
static doublereal cscale;
extern doublereal dlange_();
extern /* Subroutine */ int dgehrd_();
static doublereal sn;
extern /* Subroutine */ int dlascl_();
extern integer idamax_();
extern /* Subroutine */ int dlacpy_(), dlartg_(), xerbla_();
static logical select[1];
extern integer ilaenv_();
static doublereal bignum;
extern /* Subroutine */ int dorghr_(), dhseqr_(), dtrevc_();
static integer minwrk, maxwrk;
static logical wantvl;
static doublereal smlnum;
static integer hswork;
static logical wantvr;
static integer ihi;
static doublereal scl;
static integer ilo;
static doublereal dum[1], eps;
/* -- LAPACK driver routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEEV computes for an N-by-N real nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* WR (output) DOUBLE PRECISION array, dimension (N) */
/* WI (output) DOUBLE PRECISION array, dimension (N) */
/* WR and WI contain the real and imaginary parts, */
/* respectively, of the computed eigenvalues. Complex */
/* conjugate pairs of eigenvalues appear consecutively */
/* with the eigenvalue having the positive imaginary part */
/* first. */
/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
/* the j-th column of VL. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
/* the j-th column of VR. */
/* If the j-th and (j+1)-st eigenvalues form a complex */
/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,3*N), and */
/* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good */
/* performance, LWORK must generally be larger. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the
*/
/* eigenvalues, and no eigenvectors have been computed; */
/* elements i+1:N of WR and WI contain eigenvalues which */
/* have converged. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--wr;
--wi;
vl_dim1 = *ldvl;
vl_offset = vl_dim1 + 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = vr_dim1 + 1;
vr -= vr_offset;
--work;
/* Function Body */
*info = 0;
wantvl = lsame_(jobvl, "V", 1L, 1L);
wantvr = lsame_(jobvr, "V", 1L, 1L);
if (! wantvl && ! lsame_(jobvl, "N", 1L, 1L)) {
*info = -1;
} else if (! wantvr && ! lsame_(jobvr, "N", 1L, 1L)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -9;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -11;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by DHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, &
c__0, 6L, 1L);
if (! wantvl && ! wantvr) {
/* Computing MAX */
i__1 = 1, i__2 = *n * 3;
minwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = ilaenv_(&c__8, "DHSEQR", "EN", n, &c__1, n, &c_n1, 6L, 2L);
maxb = max(i__1,2);
/* Computing MIN */
/* Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "DHSEQR", "EN", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *n +
hswork;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = 1, i__2 = *n << 2;
minwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, "DOR\
GHR", " ", n, &c__1, n, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = ilaenv_(&c__8, "DHSEQR", "SV", n, &c__1, n, &c_n1, 6L, 2L);
maxb = max(i__1,2);
/* Computing MIN */
/* Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "DHSEQR", "SV", n, &c__1, n, &
c_n1, 6L, 2L);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *n +
hswork;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 2;
maxwrk = max(i__1,i__2);
}
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEEV ", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = dlamch_("P", 1L);
smlnum = dlamch_("S", 1L);
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", n, n, &a[a_offset], lda, dum, 1L);
scalea = FALSE_;
if (anrm > 0. && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr, 1L);
}
/* Balance the matrix */
/* (Workspace: need N) */
ibal = 1;
dgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr, 1L);
/* Reduce to upper Hessenberg form */
/* (Workspace: need 3*N, prefer 2*N+N*NB) */
itau = ibal + *n;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl, 1L);
/* Generate orthogonal matrix in VL */
/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vl[vl_offset], ldvl, &work[iwrk], &i__1, info, 1L, 1L);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, 1L)
;
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr, 1L);
/* Generate orthogonal matrix in VR */
/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
i__1 = *lwork - iwrk + 1;
dorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vr[vr_offset], ldvr, &work[iwrk], &i__1, info, 1L, 1L);
} else {
/* Compute eigenvalues only */
/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
dhseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
vr[vr_offset], ldvr, &work[iwrk], &i__1, info, 1L, 1L);
}
/* If INFO > 0 from DHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (Workspace: need 4*N) */
dtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr, 1L, 1L);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
/* (Workspace: need N) */
dgebak_("B", "L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl,
&ierr, 1L, 1L);
/* Normalize left eigenvectors and make largest component real
*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
scl = 1. / dlapy2_(&d__1, &d__2);
dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
d__1 = vl[k + i__ * vl_dim1];
/* Computing 2nd power */
d__2 = vl[k + (i__ + 1) * vl_dim1];
work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2;
/* L10: */
}
k = idamax_(n, &work[iwrk], &c__1);
dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
&cs, &sn, &r__);
drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
vl_dim1 + 1], &c__1, &cs, &sn);
vl[k + (i__ + 1) * vl_dim1] = 0.;
}
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
/* (Workspace: need N) */
dgebak_("B", "R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr,
&ierr, 1L, 1L);
/* Normalize right eigenvectors and make largest component real
*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (wi[i__] == 0.) {
scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
} else if (wi[i__] > 0.) {
d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
scl = 1. / dlapy2_(&d__1, &d__2);
dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing 2nd power */
d__1 = vr[k + i__ * vr_dim1];
/* Computing 2nd power */
d__2 = vr[k + (i__ + 1) * vr_dim1];
work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2;
/* L30: */
}
k = idamax_(n, &work[iwrk], &c__1);
dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
&cs, &sn, &r__);
drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
vr_dim1 + 1], &c__1, &cs, &sn);
vr[k + (i__ + 1) * vr_dim1] = 0.;
}
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
1], &i__2, &ierr, 1L);
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
1], &i__2, &ierr, 1L);
if (*info > 0) {
i__1 = ilo - 1;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
n, &ierr, 1L);
i__1 = ilo - 1;
dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
n, &ierr, 1L);
}
}
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGEEV */
} /* dgeev_ */
/* dgebal.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dgebal_(job, n, a, lda, ilo, ihi, scale, info, job_len)
char *job;
integer *n;
doublereal *a;
integer *lda, *ilo, *ihi;
doublereal *scale;
integer *info;
ftnlen job_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
static integer iexc;
static doublereal c__, f, g;
static integer i__, j, k, l, m;
static doublereal r__, s;
extern /* Subroutine */ int dscal_();
extern logical lsame_();
extern /* Subroutine */ int dswap_();
static doublereal sfmin1, sfmin2, sfmax1, sfmax2, ca, ra;
extern doublereal dlamch_();
extern integer idamax_();
extern /* Subroutine */ int xerbla_();
static logical noconv;
static integer ica, ira;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEBAL balances a general real matrix A. This involves, first, */
/* permuting A by a similarity transformation to isolate eigenvalues */
/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */
/* diagonal; and second, applying a diagonal similarity transformation */
/* to rows and columns ILO to IHI to make the rows and columns as */
/* close in norm as possible. Both steps are optional. */
/* Balancing may reduce the 1-norm of the matrix, and improve the */
/* accuracy of the computed eigenvalues and/or eigenvectors. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the operations to be performed on A: */
/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */
/* for i = 1,...,N; */
/* = 'P': permute only; */
/* = 'S': scale only; */
/* = 'B': both permute and scale. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the input matrix A. */
/* On exit, A is overwritten by the balanced matrix. */
/* If JOB = 'N', A is not referenced. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are set to integers such that on exit */
/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */
/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutations and scaling factors applied to */
/* A. If P(j) is the index of the row and column interchanged */
/* with row and column j and D(j) is the scaling factor */
/* applied to row and column j, then */
/* SCALE(j) = P(j) for j = 1,...,ILO-1 */
/* = D(j) for j = ILO,...,IHI */
/* = P(j) for j = IHI+1,...,N. */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* The permutations consist of row and column interchanges which put */
/* the matrix in the form */
/* ( T1 X Y ) */
/* P A P = ( 0 B Z ) */
/* ( 0 0 T2 ) */
/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
/* along the diagonal. The column indices ILO and IHI mark the starting
*/
/* and ending columns of the submatrix B. Balancing consists of applying
*/
/* a diagonal similarity transformation inv(D) * B * D to make the */
/* 1-norms of each row of B and its corresponding column nearly equal. */
/* The output matrix is */
/* ( T1 X*D Y ) */
/* ( 0 inv(D)*B*D inv(D)*Z ). */
/* ( 0 0 T2 ) */
/* Information about the permutations P and the diagonal matrix D is */
/* returned in the vector SCALE. */
/* This subroutine is based on the EISPACK routine BALANC. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--scale;
/* Function Body */
*info = 0;
if (! lsame_(job, "N", 1L, 1L) && ! lsame_(job, "P", 1L, 1L) && ! lsame_(
job, "S", 1L, 1L) && ! lsame_(job, "B", 1L, 1L)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEBAL", &i__1, 6L);
return 0;
}
k = 1;
l = *n;
if (*n == 0) {
goto L210;
}
if (lsame_(job, "N", 1L, 1L)) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L10: */
}
goto L210;
}
if (lsame_(job, "S", 1L, 1L)) {
goto L120;
}
/* Permutation to isolate eigenvalues if possible */
goto L50;
/* Row and column exchange. */
L20:
scale[m] = (doublereal) j;
if (j == m) {
goto L30;
}
dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
i__1 = *n - k + 1;
dswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
L30:
switch ((int)iexc) {
case 1: goto L40;
case 2: goto L80;
}
/* Search for rows isolating an eigenvalue and push them down. */
L40:
if (l == 1) {
goto L210;
}
--l;
L50:
for (j = l; j >= 1; --j) {
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ == j) {
goto L60;
}
if (a[j + i__ * a_dim1] != 0.) {
goto L70;
}
L60:
;
}
m = l;
iexc = 1;
goto L20;
L70:
;
}
goto L90;
/* Search for columns isolating an eigenvalue and push them left. */
L80:
++k;
L90:
i__1 = l;
for (j = k; j <= i__1; ++j) {
i__2 = l;
for (i__ = k; i__ <= i__2; ++i__) {
if (i__ == j) {
goto L100;
}
if (a[i__ + j * a_dim1] != 0.) {
goto L110;
}
L100:
;
}
m = k;
iexc = 2;
goto L20;
L110:
;
}
L120:
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
scale[i__] = 1.;
/* L130: */
}
if (lsame_(job, "P", 1L, 1L)) {
goto L210;
}
/* Balance the submatrix in rows K to L. */
/* Iterative loop for norm reduction */
sfmin1 = dlamch_("S", 1L) / dlamch_("P", 1L);
sfmax1 = 1. / sfmin1;
sfmin2 = sfmin1 * 10.;
sfmax2 = 1. / sfmin2;
L140:
noconv = FALSE_;
i__1 = l;
for (i__ = k; i__ <= i__1; ++i__) {
c__ = 0.;
r__ = 0.;
i__2 = l;
for (j = k; j <= i__2; ++j) {
if (j == i__) {
goto L150;
}
c__ += (d__1 = a[j + i__ * a_dim1], abs(d__1));
r__ += (d__1 = a[i__ + j * a_dim1], abs(d__1));
L150:
;
}
ica = idamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
ca = (d__1 = a[ica + i__ * a_dim1], abs(d__1));
i__2 = *n - k + 1;
ira = idamax_(&i__2, &a[i__ + k * a_dim1], lda);
ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], abs(d__1));
/* Guard against zero C or R due to underflow. */
if (c__ == 0. || r__ == 0.) {
goto L200;
}
g = r__ / 10.;
f = 1.;
s = c__ + r__;
L160:
/* Computing MAX */
d__1 = max(f,c__);
/* Computing MIN */
d__2 = min(r__,g);
if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) {
goto L170;
}
f *= 10.;
c__ *= 10.;
ca *= 10.;
r__ /= 10.;
g /= 10.;
ra /= 10.;
goto L160;
L170:
g = c__ / 10.;
L180:
/* Computing MIN */
d__1 = min(f,c__), d__1 = min(d__1,g);
if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) {
goto L190;
}
f /= 10.;
c__ /= 10.;
g /= 10.;
ca /= 10.;
r__ *= 10.;
ra *= 10.;
goto L180;
/* Now balance. */
L190:
if (c__ + r__ >= s * .95) {
goto L200;
}
if (f < 1. && scale[i__] < 1.) {
if (f * scale[i__] <= sfmin1) {
goto L200;
}
}
if (f > 1. && scale[i__] > 1.) {
if (scale[i__] >= sfmax1 / f) {
goto L200;
}
}
g = 1. / f;
scale[i__] *= f;
noconv = TRUE_;
i__2 = *n - k + 1;
dscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
dscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
L200:
;
}
if (noconv) {
goto L140;
}
L210:
*ilo = k;
*ihi = l;
return 0;
/* End of DGEBAL */
} /* dgebal_ */
/* dgebak.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dgebak_(job, side, n, ilo, ihi, scale, m, v, ldv, info,
job_len, side_len)
char *job, *side;
integer *n, *ilo, *ihi;
doublereal *scale;
integer *m;
doublereal *v;
integer *ldv, *info;
ftnlen job_len;
ftnlen side_len;
{
/* System generated locals */
integer v_dim1, v_offset, i__1;
/* Local variables */
static integer i__, k;
static doublereal s;
extern /* Subroutine */ int dscal_();
extern logical lsame_();
extern /* Subroutine */ int dswap_();
static logical leftv;
static integer ii;
extern /* Subroutine */ int xerbla_();
static logical rightv;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEBAK forms the right or left eigenvectors of a real general matrix
*/
/* by backward transformation on the computed eigenvectors of the */
/* balanced matrix output by DGEBAL. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies the type of backward transformation required: */
/* = 'N', do nothing, return immediately; */
/* = 'P', do backward transformation for permutation only; */
/* = 'S', do backward transformation for scaling only; */
/* = 'B', do backward transformations for both permutation and */
/* scaling. */
/* JOB must be the same as the argument JOB supplied to DGEBAL.
*/
/* SIDE (input) CHARACTER*1 */
/* = 'R': V contains right eigenvectors; */
/* = 'L': V contains left eigenvectors. */
/* N (input) INTEGER */
/* The number of rows of the matrix V. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* The integers ILO and IHI determined by DGEBAL. */
/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
/* SCALE (input) DOUBLE PRECISION array, dimension (N) */
/* Details of the permutation and scaling factors, as returned */
/* by DGEBAL. */
/* M (input) INTEGER */
/* The number of columns of the matrix V. M >= 0. */
/* V (input/output) DOUBLE PRECISION array, dimension (LDV,M) */
/* On entry, the matrix of right or left eigenvectors to be */
/* transformed, as returned by DHSEIN or DTREVC. */
/* On exit, V is overwritten by the transformed eigenvectors. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. LDV >= max(1,N). */
/* 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 .. */
/* Decode and Test the input parameters */
/* Parameter adjustments */
--scale;
v_dim1 = *ldv;
v_offset = v_dim1 + 1;
v -= v_offset;
/* Function Body */
rightv = lsame_(side, "R", 1L, 1L);
leftv = lsame_(side, "L", 1L, 1L);
*info = 0;
if (! lsame_(job, "N", 1L, 1L) && ! lsame_(job, "P", 1L, 1L) && ! lsame_(
job, "S", 1L, 1L) && ! lsame_(job, "B", 1L, 1L)) {
*info = -1;
} else if (! rightv && ! leftv) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*m < 0) {
*info = -7;
} else if (*ldv < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEBAK", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*m == 0) {
return 0;
}
if (lsame_(job, "N", 1L, 1L)) {
return 0;
}
if (*ilo == *ihi) {
goto L30;
}
/* Backward balance */
if (lsame_(job, "S", 1L, 1L) || lsame_(job, "B", 1L, 1L)) {
if (rightv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = scale[i__];
dscal_(m, &s, &v[i__ + v_dim1], ldv);
/* L10: */
}
}
if (leftv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = 1. / scale[i__];
dscal_(m, &s, &v[i__ + v_dim1], ldv);
/* L20: */
}
}
}
/* Backward permutation */
/* For I = ILO-1 step -1 until 1, */
/* IHI+1 step 1 until N do -- */
L30:
if (lsame_(job, "P", 1L, 1L) || lsame_(job, "B", 1L, 1L)) {
if (rightv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L40;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer) scale[i__];
if (k == i__) {
goto L40;
}
dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L40:
;
}
}
if (leftv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L50;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer) scale[i__];
if (k == i__) {
goto L50;
}
dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
L50:
;
}
}
}
return 0;
/* End of DGEBAK */
} /* dgebak_ */
/* dorgbr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dorgbr_(vect, m, n, k, a, lda, tau, work, lwork, info,
vect_len)
char *vect;
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *lwork, *info;
ftnlen vect_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer i__, j;
extern logical lsame_();
static integer iinfo;
static logical wantq;
extern /* Subroutine */ int xerbla_(), dorglq_(), dorgqr_();
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORGBR generates one of the real orthogonal matrices Q or P**T */
/* determined by DGEBRD when reducing a real matrix A to bidiagonal */
/* form: A = Q * B * P**T. Q and P**T are defined as products of */
/* elementary reflectors H(i) or G(i) respectively. */
/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */
/* is of order M: */
/* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n */
/* columns of Q, where m >= n >= k; */
/* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an */
/* M-by-M matrix. */
/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T */
/* is of order N: */
/* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m
*/
/* rows of P**T, where n >= m >= k; */
/* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as */
/* an N-by-N matrix. */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* Specifies whether the matrix Q or the matrix P**T is */
/* required, as defined in the transformation applied by DGEBRD:
*/
/* = 'Q': generate Q; */
/* = 'P': generate P**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix Q or P**T to be returned. */
/* M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q or P**T to be returned.
*/
/* N >= 0. */
/* If VECT = 'Q', M >= N >= min(M,K); */
/* if VECT = 'P', N >= M >= min(N,K). */
/* K (input) INTEGER */
/* If VECT = 'Q', the number of columns in the original M-by-K */
/* matrix reduced by DGEBRD. */
/* If VECT = 'P', the number of rows in the original K-by-N */
/* matrix reduced by DGEBRD. */
/* K >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the vectors which define the elementary reflectors,
*/
/* as returned by DGEBRD. */
/* On exit, the M-by-N matrix Q or P**T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (input) DOUBLE PRECISION array, dimension */
/* (min(M,K)) if VECT = 'Q' */
/* (min(N,K)) if VECT = 'P' */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i) or G(i), which determines Q or P**T, as */
/* returned by DGEBRD in its array argument TAUQ or TAUP. */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,min(M,N)). */
/* For optimum performance LWORK >= min(M,N)*NB, where NB */
/* is the optimal blocksize. */
/* 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 = a_dim1 + 1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
wantq = lsame_(vect, "Q", 1L, 1L);
if (! wantq && ! lsame_(vect, "P", 1L, 1L)) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
*m > *n || *m < min(*n,*k))) {
*info = -3;
} else if (*k < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = min(*m,*n);
if (*lwork < max(i__1,i__2)) {
*info = -9;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DORGBR", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
work[1] = 1.;
return 0;
}
if (wantq) {
/* Form Q, determined by a call to DGEBRD to reduce an m-by-k
*/
/* matrix */
if (*m >= *k) {
/* If m >= k, assume m >= n >= k */
dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo);
} else {
/* If m < k, assume m = n */
/* Shift the vectors which define the elementary reflect
ors one */
/* column to the right, and set the first row and column
of Q */
/* to those of the unit matrix */
for (j = *m; j >= 2; --j) {
a[j * a_dim1 + 1] = 0.;
i__1 = *m;
for (i__ = j + 1; i__ <= i__1; ++i__) {
a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
/* L10: */
}
/* L20: */
}
a[a_dim1 + 1] = 1.;
i__1 = *m;
for (i__ = 2; i__ <= i__1; ++i__) {
a[i__ + a_dim1] = 0.;
/* L30: */
}
if (*m > 1) {
/* Form Q(2:m,2:m) */
i__1 = *m - 1;
i__2 = *m - 1;
i__3 = *m - 1;
dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo);
}
}
} else {
/* Form P', determined by a call to DGEBRD to reduce a k-by-n
*/
/* matrix */
if (*k < *n) {
/* If k < n, assume k <= m <= n */
dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
iinfo);
} else {
/* If k >= n, assume m = n */
/* Shift the vectors which define the elementary reflect
ors one */
/* row downward, and set the first row and column of P'
to */
/* those of the unit matrix */
a[a_dim1 + 1] = 1.;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
a[i__ + a_dim1] = 0.;
/* L40: */
}
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
for (i__ = j - 1; i__ >= 2; --i__) {
a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1];
/* L50: */
}
a[j * a_dim1 + 1] = 0.;
/* L60: */
}
if (*n > 1) {
/* Form P'(2:n,2:n) */
i__1 = *n - 1;
i__2 = *n - 1;
i__3 = *n - 1;
dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
1], &work[1], lwork, &iinfo);
}
}
}
return 0;
/* End of DORGBR */
} /* dorgbr_ */
/* dormqr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dormqr_(side, trans, m, n, k, a, lda, tau, c__, ldc,
work, lwork, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *c__;
integer *ldc;
doublereal *work;
integer *lwork, *info;
ftnlen side_len;
ftnlen trans_len;
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat();
/* Local variables */
static logical left;
static integer i__;
static doublereal t[4160] /* was [65][64] */;
extern logical lsame_();
static integer nbmin, iinfo, i1, i2, i3;
extern /* Subroutine */ int dorm2r_();
static integer ib, ic, jc, nb, mi, ni;
extern /* Subroutine */ int dlarfb_();
static integer nq, nw;
extern /* Subroutine */ int dlarft_(), xerbla_();
extern integer ilaenv_();
static logical notran;
static integer ldwork, iws;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORMQR overwrites the general real M-by-N matrix C with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': Q * C C * Q */
/* TRANS = 'T': Q**T * C C * Q**T */
/* where Q is a real orthogonal matrix defined as the product of k */
/* elementary reflectors */
/* Q = H(1) H(2) . . . H(k) */
/* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N */
/* if SIDE = 'R'. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q or Q**T from the Left; */
/* = 'R': apply Q or Q**T from the Right. */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, apply Q; */
/* = 'T': Transpose, apply Q**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines */
/* the matrix Q. */
/* If SIDE = 'L', M >= K >= 0; */
/* if SIDE = 'R', N >= K >= 0. */
/* A (input) DOUBLE PRECISION 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
*/
/* DGEQRF 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) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DGEQRF. */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
*/
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! lsame_(side, "R", 1L, 1L)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T", 1L, 1L)) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*lda < max(1,nq)) {
*info = -7;
} else if (*ldc < max(1,*m)) {
*info = -10;
} else if (*lwork < max(1,nw)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DORMQR", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
work[1] = 1.;
return 0;
}
/* Determine the block size. NB may be at most NBMAX, where NBMAX */
/* is used to define the local array T. */
/* Computing MIN */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1, 6L, 2L);
nb = min(i__1,i__2);
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1,
6L, 2L);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo, 1L, 1L);
} else {
/* Use blocked code */
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = nq - i__ + 1;
dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], t, &c__65, 7L, 10L);
if (left) {
/* H or H' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H or H' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H or H' */
dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc *
c_dim1], ldc, &work[1], &ldwork, 1L, 1L, 7L, 10L);
/* L10: */
}
}
work[1] = (doublereal) iws;
return 0;
/* End of DORMQR */
} /* dormqr_ */
/* dlaswp.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlaswp_(n, a, lda, k1, k2, ipiv, incx)
integer *n;
doublereal *a;
integer *lda, *k1, *k2, *ipiv, *incx;
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
/* Local variables */
static integer i__;
extern /* Subroutine */ int dswap_();
static integer ip, ix;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASWP performs a series of row interchanges on the matrix A. */
/* One row interchange is initiated for each of rows K1 through K2 of A.
*/
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of columns of the matrix A. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the matrix of column dimension N to which the row */
/* interchanges will be applied. */
/* On exit, the permuted matrix. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* K1 (input) INTEGER */
/* The first element of IPIV for which a row interchange will */
/* be done. */
/* K2 (input) INTEGER */
/* The last element of IPIV for which a row interchange will */
/* be done. */
/* IPIV (input) INTEGER array, dimension (M*abs(INCX)) */
/* The vector of pivot indices. Only the elements in positions
*/
/* K1 through K2 of IPIV are accessed. */
/* IPIV(K) = L implies rows K and L are to be interchanged. */
/* INCX (input) INTEGER */
/* The increment between successive values of IPIV. If IPIV */
/* is negative, the pivots are applied in reverse order. */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Interchange row I with row IPIV(I) for each of rows K1 through K2.
*/
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--ipiv;
/* Function Body */
if (*incx == 0) {
return 0;
}
if (*incx > 0) {
ix = *k1;
} else {
ix = (1 - *k2) * *incx + 1;
}
if (*incx == 1) {
i__1 = *k2;
for (i__ = *k1; i__ <= i__1; ++i__) {
ip = ipiv[i__];
if (ip != i__) {
dswap_(n, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda);
}
/* L10: */
}
} else if (*incx > 1) {
i__1 = *k2;
for (i__ = *k1; i__ <= i__1; ++i__) {
ip = ipiv[ix];
if (ip != i__) {
dswap_(n, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda);
}
ix += *incx;
/* L20: */
}
} else if (*incx < 0) {
i__1 = *k1;
for (i__ = *k2; i__ >= i__1; --i__) {
ip = ipiv[ix];
if (ip != i__) {
dswap_(n, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda);
}
ix += *incx;
/* L30: */
}
}
return 0;
/* End of DLASWP */
} /* dlaswp_ */
/* dlanv2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b3
#undef c_b3
#endif
#define c_b3 c_b3a
/* Subroutine */ int dlanv2_(a, b, c__, d__, rt1r, rt1i, rt2r, rt2i, cs, sn)
doublereal *a, *b, *c__, *d__, *rt1r, *rt1i, *rt2r, *rt2i, *cs, *sn;
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double d_sign(), sqrt();
/* Local variables */
static doublereal temp, p, sigma;
extern doublereal dlapy2_();
static doublereal aa, bb, cc, dd, cs1, sn1, sab, sac, tau;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
*/
/* matrix in standard form: */
/* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] */
/* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] */
/* where either */
/* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or */
/* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex */
/* conjugate eigenvalues. */
/* Arguments */
/* ========= */
/* A (input/output) DOUBLE PRECISION */
/* B (input/output) DOUBLE PRECISION */
/* C (input/output) DOUBLE PRECISION */
/* D (input/output) DOUBLE PRECISION */
/* On entry, the elements of the input matrix. */
/* On exit, they are overwritten by the elements of the */
/* standardised Schur form. */
/* RT1R (output) DOUBLE PRECISION */
/* RT1I (output) DOUBLE PRECISION */
/* RT2R (output) DOUBLE PRECISION */
/* RT2I (output) DOUBLE PRECISION */
/* The real and imaginary parts of the eigenvalues. If the */
/* eigenvalues are both real, abs(RT1R) >= abs(RT2R); if the */
/* eigenvalues are a complex conjugate pair, RT1I > 0. */
/* CS (output) DOUBLE PRECISION */
/* SN (output) DOUBLE PRECISION */
/* Parameters of the rotation matrix. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialize CS and SN */
*cs = 1.;
*sn = 0.;
if (*c__ == 0.) {
goto L10;
} else if (*b == 0.) {
/* Swap rows and columns */
*cs = 0.;
*sn = 1.;
temp = *d__;
*d__ = *a;
*a = temp;
*b = -(*c__);
*c__ = 0.;
goto L10;
} else if (*a - *d__ == 0. && d_sign(&c_b3, b) != d_sign(&c_b3, c__)) {
goto L10;
} else {
/* Make diagonal elements equal */
temp = *a - *d__;
p = temp * .5;
sigma = *b + *c__;
tau = dlapy2_(&sigma, &temp);
cs1 = sqrt((abs(sigma) / tau + 1.) * .5);
sn1 = -(p / (tau * cs1)) * d_sign(&c_b3, &sigma);
/* Compute [ AA BB ] = [ A B ] [ CS1 -SN1 ] */
/* [ CC DD ] [ C D ] [ SN1 CS1 ] */
aa = *a * cs1 + *b * sn1;
bb = -(*a) * sn1 + *b * cs1;
cc = *c__ * cs1 + *d__ * sn1;
dd = -(*c__) * sn1 + *d__ * cs1;
/* Compute [ A B ] = [ CS1 SN1 ] [ AA BB ] */
/* [ C D ] [-SN1 CS1 ] [ CC DD ] */
*a = aa * cs1 + cc * sn1;
*b = bb * cs1 + dd * sn1;
*c__ = -aa * sn1 + cc * cs1;
*d__ = -bb * sn1 + dd * cs1;
/* Accumulate transformation */
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
temp = (*a + *d__) * .5;
*a = temp;
*d__ = temp;
if (*c__ != 0.) {
if (*b != 0.) {
if (d_sign(&c_b3, b) == d_sign(&c_b3, c__)) {
/* Real eigenvalues: reduce to upper trian
gular form */
sab = sqrt((abs(*b)));
sac = sqrt((abs(*c__)));
d__1 = sab * sac;
p = d_sign(&d__1, c__);
tau = 1. / sqrt((d__1 = *b + *c__, abs(d__1)));
*a = temp + p;
*d__ = temp - p;
*b -= *c__;
*c__ = 0.;
cs1 = sab * tau;
sn1 = sac * tau;
temp = *cs * cs1 - *sn * sn1;
*sn = *cs * sn1 + *sn * cs1;
*cs = temp;
}
} else {
*b = -(*c__);
*c__ = 0.;
temp = *cs;
*cs = -(*sn);
*sn = temp;
}
}
}
L10:
/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */
*rt1r = *a;
*rt2r = *d__;
if (*c__ == 0.) {
*rt1i = 0.;
*rt2i = 0.;
} else {
*rt1i = sqrt((abs(*b))) * sqrt((abs(*c__)));
*rt2i = -(*rt1i);
}
return 0;
/* End of DLANV2 */
} /* dlanv2_ */
/* dlahrd.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b4
#undef c_b4
#endif
#define c_b4 c_b4b
#ifdef c_b5
#undef c_b5
#endif
#define c_b5 c_b5
#ifdef c_b38
#undef c_b38
#endif
#define c_b38 c_b38
/* Subroutine */ int dlahrd_(n, k, nb, a, lda, tau, t, ldt, y, ldy)
integer *n, *k, *nb;
doublereal *a;
integer *lda;
doublereal *tau, *t;
integer *ldt;
doublereal *y;
integer *ldy;
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
doublereal d__1;
/* Local variables */
static integer i__;
extern /* Subroutine */ int dscal_(), dgemv_(), dcopy_(), daxpy_(),
dtrmv_();
static doublereal ei;
extern /* Subroutine */ int dlarfg_();
/* -- LAPACK auxiliary routine (version 2.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 */
/* ======= */
/* DLAHRD reduces the first NB columns of a real general n-by-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an orthogonal similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine
*/
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
*/
/* This is an auxiliary routine called by DGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)
*/
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a
*/
/* product of elementary reflectors. The other columns of A are
*/
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) DOUBLE PRECISION array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further
*/
/* Details. */
/* T (output) DOUBLE PRECISION array, dimension (NB,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors
*/
/* Q = H(1) H(2) . . . H(nb). */
/* 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix
*/
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a h a a a ) */
/* ( a h a a a ) */
/* ( a h a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a 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 .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = t_dim1 + 1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = y_dim1 + 1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(1:n,i) */
/* Compute i-th column of A - Y * V' */
i__2 = i__ - 1;
dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k
+ i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], &
c__1, 12L);
/* Apply I - V * T' * V' to this column (call it b) from
the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
*/
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
dtrmv_("Lower", "Transpose", "Unit", &i__2, &a[*k + 1 + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, 5L, 9L, 4L);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
t_dim1 + 1], &c__1, 9L);
/* w := T'*w */
i__2 = i__ - 1;
dtrmv_("Upper", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt,
&t[*nb * t_dim1 + 1], &c__1, 5L, 9L, 8L);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
i__ * a_dim1], &c__1, 12L);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
dtrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1, 5L, 12L, 4L);
i__2 = i__ - 1;
daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
}
/* Generate the elementary reflector H(i) to annihilate */
/* A(k+i+1:n,i) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3,*n) + i__ *
a_dim1], &c__1, &tau[i__]);
ei = a[*k + i__ + i__ * a_dim1];
a[*k + i__ + i__ * a_dim1] = 1.;
/* Compute Y(1:n,i) */
i__2 = *n - *k - i__ + 1;
dgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ *
y_dim1 + 1], &c__1, 12L);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
1], &c__1, 9L);
i__2 = i__ - 1;
dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ *
t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1, 12L);
dscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
/* Compute T(1:i,i) */
i__2 = i__ - 1;
d__1 = -tau[i__];
dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1, 5L, 12L, 8L);
t[i__ + i__ * t_dim1] = tau[i__];
/* L10: */
}
a[*k + *nb + *nb * a_dim1] = ei;
return 0;
/* End of DLAHRD */
} /* dlahrd_ */
/* dladiv.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dladiv_(a, b, c__, d__, p, q)
doublereal *a, *b, *c__, *d__, *p, *q;
{
static doublereal e, f;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLADIV performs complex division in real arithmetic */
/* a + i*b */
/* p + i*q = --------- */
/* c + i*d */
/* The algorithm is due to Robert L. Smith and can be found */
/* in D. Knuth, The art of Computer Programming, Vol.2, p.195 */
/* Arguments */
/* ========= */
/* A (input) DOUBLE PRECISION */
/* B (input) DOUBLE PRECISION */
/* C (input) DOUBLE PRECISION */
/* D (input) DOUBLE PRECISION */
/* The scalars a, b, c, and d in the above expression. */
/* P (output) DOUBLE PRECISION */
/* Q (output) DOUBLE PRECISION */
/* The scalars p and q in the above expression. */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
if (abs(*d__) < abs(*c__)) {
e = *d__ / *c__;
f = *c__ + *d__ * e;
*p = (*a + *b * e) / f;
*q = (*b - *a * e) / f;
} else {
e = *c__ / *d__;
f = *d__ + *c__ * e;
*p = (*b + *a * e) / f;
*q = (-(*a) + *b * e) / f;
}
return 0;
/* End of DLADIV */
} /* dladiv_ */
/* dorm2r.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dorm2r_(side, trans, m, n, k, a, lda, tau, c__, ldc,
work, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *c__;
integer *ldc;
doublereal *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 logical left;
static integer i__;
extern /* Subroutine */ int dlarf_();
extern logical lsame_();
static integer i1, i2, i3, ic, jc, mi, ni, nq;
extern /* Subroutine */ int xerbla_();
static logical notran;
static doublereal aii;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORM2R 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 DGEQRF. 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) DOUBLE PRECISION 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
*/
/* DGEQRF 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) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DGEQRF. */
/* C (input/output) DOUBLE PRECISION 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) DOUBLE PRECISION 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 = a_dim1 + 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R", 1L, 1L)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T", 1L, 1L)) {
*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_("DORM2R", &i__1, 6L);
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; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
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_dim1];
a[i__ + i__ * a_dim1] = 1.;
dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[
ic + jc * c_dim1], ldc, &work[1], 1L);
a[i__ + i__ * a_dim1] = aii;
/* L10: */
}
return 0;
/* End of DORM2R */
} /* dorm2r_ */
/* dorgl2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dorgl2_(m, n, k, a, lda, tau, work, info)
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
static integer i__, j, l;
extern /* Subroutine */ int dscal_(), dlarf_(), xerbla_();
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORGL2 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 DGELQF. */
/* 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) DOUBLE PRECISION 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 DGELQF 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) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DGELQF. */
/* WORK (workspace) DOUBLE PRECISION 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 = 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_("DORGL2", &i__1, 6L);
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.;
/* L10: */
}
if (j > *k && j <= *m) {
a[j + j * a_dim1] = 1.;
}
/* 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.;
i__1 = *m - i__;
i__2 = *n - i__ + 1;
dlarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1],
5L);
}
i__1 = *n - i__;
d__1 = -tau[i__];
dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda);
}
a[i__ + i__ * a_dim1] = 1. - tau[i__];
/* Set A(1:i-1,i) to zero */
i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) {
a[i__ + l * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
return 0;
/* End of DORGL2 */
} /* dorgl2_ */
/* dgesv.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dgesv_(n, nrhs, a, lda, ipiv, b, ldb, info)
integer *n, *nrhs;
doublereal *a;
integer *lda, *ipiv;
doublereal *b;
integer *ldb, *info;
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern /* Subroutine */ int dgetrf_(), xerbla_(), dgetrs_();
/* -- LAPACK driver routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGESV computes the solution to a real system of linear equations */
/* A * X = B, */
/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
/* The LU decomposition with partial pivoting and row interchanges is */
/* used to factor A as */
/* A = P * L * U, */
/* where P is a permutation matrix, L is unit lower triangular, and U is
*/
/* upper triangular. The factored form of A is then used to solve the */
/* system of equations A * X = B. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the N-by-N coefficient matrix A. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (output) INTEGER array, dimension (N) */
/* The pivot indices that define the permutation matrix P; */
/* row i of the matrix was interchanged with row IPIV(i). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS matrix of right hand side matrix B. */
/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*/
/* has been completed, but the factor U is exactly */
/* singular, so the solution could not be computed. */
/* =====================================================================
*/
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = b_dim1 + 1;
b -= b_offset;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGESV ", &i__1, 6L);
return 0;
}
/* Compute the LU factorization of A. */
dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[
b_offset], ldb, info, 12L);
}
return 0;
/* End of DGESV */
} /* dgesv_ */
/* dgetf2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b6
#undef c_b6
#endif
#define c_b6 c_b6
/* Subroutine */ int dgetf2_(m, n, a, lda, ipiv, info)
integer *m, *n;
doublereal *a;
integer *lda, *ipiv, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_();
static integer j;
extern /* Subroutine */ int dscal_(), dswap_();
static integer jp;
extern integer idamax_();
extern /* Subroutine */ int xerbla_();
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGETF2 computes an LU factorization of a general m-by-n matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This is the right-looking Level 2 BLAS version of the algorithm. */
/* 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the m by n matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used
*/
/* to solve a system of equations. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--ipiv;
/* 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_("DGETF2", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
if (a[jp + j * a_dim1] != 0.) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
i__2 = *m - j;
d__1 = 1. / a[j + j * a_dim1];
dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
dger_(&i__2, &i__3, &c_b6, &a[j + 1 + j * a_dim1], &c__1, &a[j + (
j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda);
}
/* L10: */
}
return 0;
/* End of DGETF2 */
} /* dgetf2_ */
/* dbdsqr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b15
#undef c_b15
#endif
#define c_b15 c_b15
#ifdef c_b48
#undef c_b48
#endif
#define c_b48 c_b48
#ifdef c_b71
#undef c_b71
#endif
#define c_b71 c_b71
/* Subroutine */ int dbdsqr_(uplo, n, ncvt, nru, ncc, d__, e, vt, ldvt, u,
ldu, c__, ldc, work, info, uplo_len)
char *uplo;
integer *n, *ncvt, *nru, *ncc;
doublereal *d__, *e, *vt;
integer *ldvt;
doublereal *u;
integer *ldu;
doublereal *c__;
integer *ldc;
doublereal *work;
integer *info;
ftnlen uplo_len;
{
/* System generated locals */
integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double pow_dd(), sqrt(), d_sign();
/* Local variables */
static doublereal abse;
static integer idir;
static doublereal abss;
static integer oldm;
static doublereal cosl;
static integer isub, iter;
static doublereal unfl, sinl, cosr, smin, smax, sinr;
extern /* Subroutine */ int drot_();
static integer irot;
extern /* Subroutine */ int dlas2_();
static doublereal f, g, h__;
static integer i__, j, m;
static doublereal r__;
extern /* Subroutine */ int dscal_();
extern logical lsame_();
static doublereal oldcs;
extern /* Subroutine */ int dlasr_();
static integer oldll;
static doublereal shift, sigmn, oldsn;
extern /* Subroutine */ int dswap_();
static integer maxit;
static doublereal sminl, sigmx;
static integer iuplo;
extern /* Subroutine */ int dlasq1_(), dlasv2_();
static doublereal cs;
static integer ll;
extern doublereal dlamch_();
static doublereal sn, mu;
extern /* Subroutine */ int dlartg_(), xerbla_();
static doublereal sminoa, thresh;
static logical rotate;
static doublereal sminlo;
static integer nm1;
static doublereal tolmul;
static integer nm12, nm13, lll;
static doublereal eps, sll, tol;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DBDSQR computes the singular value decomposition (SVD) of a real */
/* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' */
/* denotes the transpose of P), where S is a diagonal matrix with */
/* non-negative diagonal elements (the singular values of B), and Q */
/* and P are orthogonal matrices. */
/* The routine computes S, and optionally computes U * Q, P' * VT, */
/* or Q' * C, for given real input matrices U, VT, and C. */
/* See "Computing Small Singular Values of Bidiagonal Matrices With */
/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */
/* no. 5, pp. 873-912, Sept 1990) and */
/* "Accurate singular values and differential qd algorithms," by */
/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */
/* Department, University of California at Berkeley, July 1992 */
/* for a detailed description of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': B is upper bidiagonal; */
/* = 'L': B is lower bidiagonal. */
/* N (input) INTEGER */
/* The order of the matrix B. N >= 0. */
/* NCVT (input) INTEGER */
/* The number of columns of the matrix VT. NCVT >= 0. */
/* NRU (input) INTEGER */
/* The number of rows of the matrix U. NRU >= 0. */
/* NCC (input) INTEGER */
/* The number of columns of the matrix C. NCC >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the bidiagonal matrix B.
*/
/* On exit, if INFO=0, the singular values of B in decreasing */
/* order. */
/* E (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the elements of E contain the */
/* offdiagonal elements of the bidiagonal matrix whose SVD */
/* is desired. On normal exit (INFO = 0), E is destroyed. */
/* If the algorithm does not converge (INFO > 0), D and E */
/* will contain the diagonal and superdiagonal elements of a */
/* bidiagonal matrix orthogonally equivalent to the one given */
/* as input. E(N) is used for workspace. */
/* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
*/
/* On entry, an N-by-NCVT matrix VT. */
/* On exit, VT is overwritten by P' * VT. */
/* VT is not referenced if NCVT = 0. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. */
/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
/* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) */
/* On entry, an NRU-by-N matrix U. */
/* On exit, U is overwritten by U * Q. */
/* U is not referenced if NRU = 0. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,NRU). */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */
/* On entry, an N-by-NCC matrix C. */
/* On exit, C is overwritten by Q' * C. */
/* C is not referenced if NCC = 0. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. */
/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* 2*N if only singular values wanted (NCVT = NRU = NCC = 0)
*/
/* max( 1, 4*N-4 ) otherwise */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0: the algorithm did not converge; D and E contain the */
/* elements of a bidiagonal matrix which is orthogonally */
/* similar to the input matrix B; if INFO = i, i */
/* elements of E have not converged to zero. */
/* Internal Parameters */
/* =================== */
/* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) */
/* TOLMUL controls the convergence criterion of the QR loop. */
/* If it is positive, TOLMUL*EPS is the desired relative */
/* precision in the computed singular values. */
/* If it is negative, abs(TOLMUL*EPS*sigma_max) is the */
/* desired absolute accuracy in the computed singular */
/* values (corresponds to relative accuracy */
/* abs(TOLMUL*EPS) in the largest singular value. */
/* abs(TOLMUL) should be between 1 and 1/EPS, and preferably */
/* between 10 (for fast convergence) and .1/EPS */
/* (for there to be some accuracy in the results). */
/* Default is to lose at either one eighth or 2 of the */
/* available decimal digits in each computed singular value */
/* (whichever is smaller). */
/* MAXITR INTEGER, default = 6 */
/* MAXITR controls the maximum number of passes of the */
/* algorithm through its inner loop. The algorithms stops */
/* (and so fails to converge) if the number of passes */
/* through the inner loop exceeds MAXITR*N**2. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
vt_dim1 = *ldvt;
vt_offset = vt_dim1 + 1;
vt -= vt_offset;
u_dim1 = *ldu;
u_offset = u_dim1 + 1;
u -= u_offset;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
iuplo = 0;
if (lsame_(uplo, "U", 1L, 1L)) {
iuplo = 1;
}
if (lsame_(uplo, "L", 1L, 1L)) {
iuplo = 2;
}
if (iuplo == 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*ncvt < 0) {
*info = -3;
} else if (*nru < 0) {
*info = -4;
} else if (*ncc < 0) {
*info = -5;
} else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
*info = -9;
} else if (*ldu < max(1,*nru)) {
*info = -11;
} else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DBDSQR", &i__1, 6L);
return 0;
}
if (*n == 0) {
return 0;
}
if (*n == 1) {
goto L150;
}
/* ROTATE is true if any singular vectors desired, false otherwise */
rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
/* If no singular vectors desired, use qd algorithm */
if (! rotate) {
dlasq1_(n, &d__[1], &e[1], &work[1], info);
return 0;
}
nm1 = *n - 1;
nm12 = nm1 + nm1;
nm13 = nm12 + nm1;
/* Get machine constants */
eps = dlamch_("Epsilon", 7L);
unfl = dlamch_("Safe minimum", 12L);
/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
/* by applying Givens rotations on the left */
if (iuplo == 2) {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
work[i__] = cs;
work[nm1 + i__] = sn;
/* L10: */
}
/* Update singular vectors if desired */
if (*nru > 0) {
dlasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset],
ldu, 1L, 1L, 1L);
}
if (*ncc > 0) {
dlasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset],
ldc, 1L, 1L, 1L);
}
}
/* Compute singular values to relative accuracy TOL */
/* (By setting TOL to be negative, algorithm will compute */
/* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
*/
/* Computing MAX */
/* Computing MIN */
d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
d__1 = 10., d__2 = min(d__3,d__4);
tolmul = max(d__1,d__2);
tol = tolmul * eps;
/* Compute approximate maximum, minimum singular values */
smax = (d__1 = d__[*n], abs(d__1));
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__3 = smax, d__4 = (d__1 = d__[i__], abs(d__1)), d__3 = max(d__3,
d__4), d__4 = (d__2 = e[i__], abs(d__2));
smax = max(d__3,d__4);
/* L20: */
}
sminl = 0.;
if (tol >= 0.) {
/* Relative accuracy desired */
sminoa = abs(d__[1]);
if (sminoa == 0.) {
goto L40;
}
mu = sminoa;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
mu = (d__1 = d__[i__], abs(d__1)) * (mu / (mu + (d__2 = e[i__ - 1]
, abs(d__2))));
sminoa = min(sminoa,mu);
if (sminoa == 0.) {
goto L40;
}
/* L30: */
}
L40:
sminoa /= sqrt((doublereal) (*n));
/* Computing MAX */
d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
} else {
/* Absolute accuracy desired */
/* Computing MAX */
d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
thresh = max(d__1,d__2);
}
/* Prepare for main iteration loop for the singular values */
/* (MAXIT is the maximum number of passes through the inner */
/* loop permitted before nonconvergence signalled.) */
maxit = *n * 6 * *n;
iter = 0;
oldll = -1;
oldm = -1;
/* M points to last element of unconverged part of matrix */
m = *n;
/* Begin main iteration loop */
L50:
/* Check for convergence or exceeding iteration count */
if (m <= 1) {
goto L150;
}
if (iter > maxit) {
goto L190;
}
/* Find diagonal block of matrix to work on */
if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
d__[m] = 0.;
}
smax = (d__1 = d__[m], abs(d__1));
smin = smax;
i__1 = m;
for (lll = 1; lll <= i__1; ++lll) {
ll = m - lll;
if (ll == 0) {
goto L80;
}
abss = (d__1 = d__[ll], abs(d__1));
abse = (d__1 = e[ll], abs(d__1));
if (tol < 0. && abss <= thresh) {
d__[ll] = 0.;
}
if (abse <= thresh) {
goto L70;
}
smin = min(smin,abss);
/* Computing MAX */
d__1 = max(smax,abss);
smax = max(d__1,abse);
/* L60: */
}
L70:
e[ll] = 0.;
/* Matrix splits since E(LL) = 0 */
if (ll == m - 1) {
/* Convergence of bottom singular value, return to top of loop
*/
--m;
goto L50;
}
L80:
++ll;
/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
if (ll == m - 1) {
/* 2 by 2 block, handle separately */
dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
&sinl, &cosl);
d__[m - 1] = sigmx;
e[m - 1] = 0.;
d__[m] = sigmn;
/* Compute singular vectors, if desired */
if (*ncvt > 0) {
drot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
cosr, &sinr);
}
if (*nru > 0) {
drot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
c__1, &cosl, &sinl);
}
if (*ncc > 0) {
drot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &
cosl, &sinl);
}
m += -2;
goto L50;
}
/* If working on new submatrix, choose shift direction */
/* (from larger end diagonal element towards smaller) */
if (ll > oldm || m < oldll) {
if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
/* Chase bulge from top (big end) to bottom (small end)
*/
idir = 1;
} else {
/* Chase bulge from bottom (big end) to top (small end)
*/
idir = 2;
}
}
/* Apply convergence tests */
if (idir == 1) {
/* Run convergence test in forward direction */
/* First apply standard test to bottom of matrix */
if ((d__1 = e[m - 1], abs(d__1)) <= abs(tol) * (d__2 = d__[m], abs(
d__2)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh)
{
e[m - 1] = 0.;
goto L50;
}
if (tol >= 0.) {
/* If relative accuracy desired, */
/* apply convergence criterion forward */
mu = (d__1 = d__[ll], abs(d__1));
sminl = mu;
i__1 = m - 1;
for (lll = ll; lll <= i__1; ++lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L50;
}
sminlo = sminl;
mu = (d__1 = d__[lll + 1], abs(d__1)) * (mu / (mu + (d__2 = e[
lll], abs(d__2))));
sminl = min(sminl,mu);
/* L90: */
}
}
} else {
/* Run convergence test in backward direction */
/* First apply standard test to top of matrix */
if ((d__1 = e[ll], abs(d__1)) <= abs(tol) * (d__2 = d__[ll], abs(d__2)
) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) {
e[ll] = 0.;
goto L50;
}
if (tol >= 0.) {
/* If relative accuracy desired, */
/* apply convergence criterion backward */
mu = (d__1 = d__[m], abs(d__1));
sminl = mu;
i__1 = ll;
for (lll = m - 1; lll >= i__1; --lll) {
if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
e[lll] = 0.;
goto L50;
}
sminlo = sminl;
mu = (d__1 = d__[lll], abs(d__1)) * (mu / (mu + (d__2 = e[lll]
, abs(d__2))));
sminl = min(sminl,mu);
/* L100: */
}
}
}
oldll = ll;
oldm = m;
/* Compute shift. First, test if shifting would ruin relative */
/* accuracy, and if so set the shift to zero. */
/* Computing MAX */
d__1 = eps, d__2 = tol * .01;
if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
/* Use a zero shift to avoid loss of relative accuracy */
shift = 0.;
} else {
/* Compute the shift from 2-by-2 block at end of matrix */
if (idir == 1) {
sll = (d__1 = d__[ll], abs(d__1));
dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
} else {
sll = (d__1 = d__[m], abs(d__1));
dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
}
/* Test if shift negligible, and if so set to zero */
if (sll > 0.) {
/* Computing 2nd power */
d__1 = shift / sll;
if (d__1 * d__1 < eps) {
shift = 0.;
}
}
}
/* Increment iteration count */
iter = iter + m - ll;
/* If SHIFT = 0, do simplified QR iteration */
if (shift == 0.) {
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector upda
tes */
cs = 1.;
oldcs = 1.;
d__1 = d__[ll] * cs;
dlartg_(&d__1, &e[ll], &cs, &sn, &r__);
d__1 = oldcs * r__;
d__2 = d__[ll + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[ll]);
work[1] = cs;
work[nm1 + 1] = sn;
work[nm12 + 1] = oldcs;
work[nm13 + 1] = oldsn;
irot = 1;
i__1 = m - 1;
for (i__ = ll + 1; i__ <= i__1; ++i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
e[i__ - 1] = oldsn * r__;
d__1 = oldcs * r__;
d__2 = d__[i__ + 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
++irot;
work[irot] = cs;
work[irot + nm1] = sn;
work[irot + nm12] = oldcs;
work[irot + nm13] = oldsn;
/* L110: */
}
h__ = d__[m] * cs;
d__[m] = h__ * oldcs;
e[m - 1] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
ll + vt_dim1], ldvt, 1L, 1L, 1L);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u[ll * u_dim1 + 1], ldu, 1L, 1L, 1L);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c__[ll + c_dim1], ldc, 1L, 1L, 1L);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector upda
tes */
cs = 1.;
oldcs = 1.;
d__1 = d__[m] * cs;
dlartg_(&d__1, &e[m - 1], &cs, &sn, &r__);
d__1 = oldcs * r__;
d__2 = d__[m - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[m]);
work[m - ll] = cs;
work[m - ll + nm1] = -sn;
work[m - ll + nm12] = oldcs;
work[m - ll + nm13] = -oldsn;
irot = m - ll;
i__1 = ll + 1;
for (i__ = m - 1; i__ >= i__1; --i__) {
d__1 = d__[i__] * cs;
dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
e[i__] = oldsn * r__;
d__1 = oldcs * r__;
d__2 = d__[i__ - 1] * sn;
dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
--irot;
work[irot] = cs;
work[irot + nm1] = -sn;
work[irot + nm12] = oldcs;
work[irot + nm13] = -oldsn;
/* L120: */
}
h__ = d__[ll] * cs;
d__[ll] = h__ * oldcs;
e[ll] = h__ * oldsn;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt[ll + vt_dim1], ldvt, 1L, 1L, 1L);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
u_dim1 + 1], ldu, 1L, 1L, 1L);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
ll + c_dim1], ldc, 1L, 1L, 1L);
}
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
}
} else {
/* Use nonzero shift */
if (idir == 1) {
/* Chase bulge from top to bottom */
/* Save cosines and sines for later singular vector upda
tes */
f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b48, &d__[
ll]) + shift / d__[ll]);
g = e[ll];
dlartg_(&f, &g, &cosr, &sinr, &r__);
f = cosr * d__[ll] + sinr * e[ll];
e[ll] = cosr * e[ll] - sinr * d__[ll];
g = sinr * d__[ll + 1];
d__[ll + 1] = cosr * d__[ll + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[ll] = r__;
f = cosl * e[ll] + sinl * d__[ll + 1];
d__[ll + 1] = cosl * d__[ll + 1] - sinl * e[ll];
g = sinl * e[ll + 1];
e[ll + 1] = cosl * e[ll + 1];
work[1] = cosr;
work[nm1 + 1] = sinr;
work[nm12 + 1] = cosl;
work[nm13 + 1] = sinl;
irot = 1;
i__1 = m - 2;
for (i__ = ll + 1; i__ <= i__1; ++i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
e[i__ - 1] = r__;
f = cosr * d__[i__] + sinr * e[i__];
e[i__] = cosr * e[i__] - sinr * d__[i__];
g = sinr * d__[i__ + 1];
d__[i__ + 1] = cosr * d__[i__ + 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__] + sinl * d__[i__ + 1];
d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
g = sinl * e[i__ + 1];
e[i__ + 1] = cosl * e[i__ + 1];
++irot;
work[irot] = cosr;
work[irot + nm1] = sinr;
work[irot + nm12] = cosl;
work[irot + nm13] = sinl;
/* L130: */
}
dlartg_(&f, &g, &cosr, &sinr, &r__);
e[m - 2] = r__;
f = cosr * d__[m - 1] + sinr * e[m - 1];
e[m - 1] = cosr * e[m - 1] - sinr * d__[m - 1];
g = sinr * d__[m];
d__[m] = cosr * d__[m];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[m - 1] = r__;
f = cosl * e[m - 1] + sinl * d__[m];
d__[m] = cosl * d__[m] - sinl * e[m - 1];
++irot;
work[irot] = cosr;
work[irot + nm1] = sinr;
work[irot + nm12] = cosl;
work[irot + nm13] = sinl;
e[m - 1] = f;
/* Update singular vectors */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
ll + vt_dim1], ldvt, 1L, 1L, 1L);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ 1], &u[ll * u_dim1 + 1], ldu, 1L, 1L, 1L);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ 1], &c__[ll + c_dim1], ldc, 1L, 1L, 1L);
}
/* Test convergence */
if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
e[m - 1] = 0.;
}
} else {
/* Chase bulge from bottom to top */
/* Save cosines and sines for later singular vector upda
tes */
f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b48, &d__[m]
) + shift / d__[m]);
g = e[m - 1];
dlartg_(&f, &g, &cosr, &sinr, &r__);
f = cosr * d__[m] + sinr * e[m - 1];
e[m - 1] = cosr * e[m - 1] - sinr * d__[m];
g = sinr * d__[m - 1];
d__[m - 1] = cosr * d__[m - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[m] = r__;
f = cosl * e[m - 1] + sinl * d__[m - 1];
d__[m - 1] = cosl * d__[m - 1] - sinl * e[m - 1];
g = sinl * e[m - 2];
e[m - 2] = cosl * e[m - 2];
work[m - ll] = cosr;
work[m - ll + nm1] = -sinr;
work[m - ll + nm12] = cosl;
work[m - ll + nm13] = -sinl;
irot = m - ll;
i__1 = ll + 2;
for (i__ = m - 1; i__ >= i__1; --i__) {
dlartg_(&f, &g, &cosr, &sinr, &r__);
e[i__] = r__;
f = cosr * d__[i__] + sinr * e[i__ - 1];
e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
g = sinr * d__[i__ - 1];
d__[i__ - 1] = cosr * d__[i__ - 1];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[i__] = r__;
f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
g = sinl * e[i__ - 2];
e[i__ - 2] = cosl * e[i__ - 2];
--irot;
work[irot] = cosr;
work[irot + nm1] = -sinr;
work[irot + nm12] = cosl;
work[irot + nm13] = -sinl;
/* L140: */
}
dlartg_(&f, &g, &cosr, &sinr, &r__);
e[ll + 1] = r__;
f = cosr * d__[ll + 1] + sinr * e[ll];
e[ll] = cosr * e[ll] - sinr * d__[ll + 1];
g = sinr * d__[ll];
d__[ll] = cosr * d__[ll];
dlartg_(&f, &g, &cosl, &sinl, &r__);
d__[ll + 1] = r__;
f = cosl * e[ll] + sinl * d__[ll];
d__[ll] = cosl * d__[ll] - sinl * e[ll];
--irot;
work[irot] = cosr;
work[irot + nm1] = -sinr;
work[irot + nm12] = cosl;
work[irot + nm13] = -sinl;
e[ll] = f;
/* Test convergence */
if ((d__1 = e[ll], abs(d__1)) <= thresh) {
e[ll] = 0.;
}
/* Update singular vectors if desired */
if (*ncvt > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
nm13 + 1], &vt[ll + vt_dim1], ldvt, 1L, 1L, 1L);
}
if (*nru > 0) {
i__1 = m - ll + 1;
dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
u_dim1 + 1], ldu, 1L, 1L, 1L);
}
if (*ncc > 0) {
i__1 = m - ll + 1;
dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
ll + c_dim1], ldc, 1L, 1L, 1L);
}
}
}
/* QR iteration finished, go back and check convergence */
goto L50;
/* All singular values converged, so make them positive */
L150:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] < 0.) {
d__[i__] = -d__[i__];
/* Change sign of singular vectors, if desired */
if (*ncvt > 0) {
dscal_(ncvt, &c_b71, &vt[i__ + vt_dim1], ldvt);
}
}
/* L160: */
}
/* Sort the singular values into decreasing order (insertion sort on
*/
/* singular values, but only one transposition per singular vector) */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Scan for smallest D(I) */
isub = 1;
smin = d__[1];
i__2 = *n + 1 - i__;
for (j = 2; j <= i__2; ++j) {
if (d__[j] <= smin) {
isub = j;
smin = d__[j];
}
/* L170: */
}
if (isub != *n + 1 - i__) {
/* Swap singular values and vectors */
d__[isub] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = smin;
if (*ncvt > 0) {
dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
vt_dim1], ldvt);
}
if (*nru > 0) {
dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
u_dim1 + 1], &c__1);
}
if (*ncc > 0) {
dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
c_dim1], ldc);
}
}
/* L180: */
}
goto L210;
/* Maximum number of iterations exceeded, failure to converge */
L190:
*info = 0;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (e[i__] != 0.) {
++(*info);
}
/* L200: */
}
L210:
return 0;
/* End of DBDSQR */
} /* dbdsqr_ */
/* dgelss.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b74
#undef c_b74
#endif
#define c_b74 c_b74
#ifdef c_b108
#undef c_b108
#endif
#define c_b108 c_b108
/* Subroutine */ int dgelss_(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work,
lwork, info)
integer *m, *n, *nrhs;
doublereal *a;
integer *lda;
doublereal *b;
integer *ldb;
doublereal *s, *rcond;
integer *rank;
doublereal *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
doublereal d__1;
/* Local variables */
static doublereal anrm, bnrm;
static integer itau;
static doublereal vdum[1];
static integer i__;
extern /* Subroutine */ int dgemm_();
static integer iascl, ibscl;
extern /* Subroutine */ int dgemv_(), drscl_();
static integer chunk;
static doublereal sfmin;
static integer minmn;
extern /* Subroutine */ int dcopy_();
static integer maxmn, itaup, itauq, mnthr, iwork;
extern /* Subroutine */ int dlabad_();
static integer bl, ie, il;
extern /* Subroutine */ int dgebrd_();
extern doublereal dlamch_();
static integer mm;
extern doublereal dlange_();
static integer bdspac;
extern /* Subroutine */ int dgelqf_(), dlascl_(), dgeqrf_(), dlacpy_(),
dlaset_(), xerbla_(), dbdsqr_(), dorgbr_();
static doublereal bignum;
extern integer ilaenv_();
extern /* Subroutine */ int dormbr_(), dormlq_();
static integer ldwork;
extern /* Subroutine */ int dormqr_();
static integer minwrk, maxwrk;
static doublereal smlnum, eps, thr;
/* -- LAPACK driver routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGELSS computes the minimum norm solution to a real linear least */
/* squares problem: */
/* Minimize 2-norm(| b - A*x |). */
/* using the singular value decomposition (SVD) of A. A is an M-by-N */
/* matrix which may be rank-deficient. */
/* Several right hand side vectors b and solution vectors x can be */
/* handled in a single call; they are stored as the columns of the */
/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
*/
/* X. */
/* The effective rank of A is determined by treating as zero those */
/* singular values which are less than RCOND times the largest singular
*/
/* value. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the first min(m,n) rows of A are overwritten with */
/* its right singular vectors, stored rowwise. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the M-by-NRHS right hand side matrix B. */
/* On exit, B is overwritten by the N-by-NRHS solution */
/* matrix X. If m >= n and RANK = n, the residual */
/* sum-of-squares for the solution in the i-th column is given */
/* by the sum of squares of elements n+1:m in that column. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,max(M,N)).
*/
/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The singular values of A in decreasing order. */
/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
/* RCOND (input) DOUBLE PRECISION */
/* RCOND is used to determine the effective rank of A. */
/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
/* If RCOND < 0, machine precision is used instead. */
/* RANK (output) INTEGER */
/* The effective rank of A, i.e., the number of singular values
*/
/* which are greater than RCOND*S(1). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 1, and also: */
/* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) */
/* For good performance, LWORK should generally be larger. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: the algorithm for computing the SVD failed to converge;
*/
/* if INFO = i, i off-diagonal elements of an intermediate
*/
/* bidiagonal form did not converge to zero. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = b_dim1 + 1;
b -= b_offset;
--s;
--work;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
maxmn = max(*m,*n);
mnthr = ilaenv_(&c__6, "DGELSS", " ", m, n, nrhs, &c_n1, 6L, 1L);
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
} else if (*ldb < max(1,maxmn)) {
*info = -7;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = 0;
mm = *m;
if (*m >= *n && *m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than co
lumns */
mm = *n;
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m,
n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", "LT",
m, nrhs, n, &c_n1, 6L, 2L);
maxwrk = max(i__1,i__2);
}
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined */
/* Compute workspace neede for DBDSQR */
/* Computing MAX */
i__1 = 1, i__2 = *n * 5 - 4;
bdspac = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, "DGEBRD"
, " ", &mm, n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR",
"QLT", &mm, nrhs, n, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, "DORGBR",
"P", n, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *nrhs;
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2);
minwrk = max(i__1,bdspac);
maxwrk = max(minwrk,maxwrk);
}
if (*n > *m) {
/* Compute workspace neede for DBDSQR */
/* Computing MAX */
i__1 = 1, i__2 = *m * 5 - 4;
bdspac = max(i__1,i__2);
/* Computing MAX */
i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *n, i__1 = max(i__1,i__2);
minwrk = max(i__1,bdspac);
if (*n >= mnthr) {
/* Path 2a - underdetermined, with many more colu
mns */
/* than rows */
maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1,
&c_n1, 6L, 1L);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1, 6L,
1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(&
c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
ilaenv_(&c__1, "DORGBR", "P", m, m, m, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + bdspac;
maxwrk = max(i__1,i__2);
if (*nrhs > 1) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
maxwrk = max(i__1,i__2);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ",
"LT", n, nrhs, m, &c_n1, 6L, 2L);
maxwrk = max(i__1,i__2);
} else {
/* Path 2 - underdetermined */
maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", " ", m,
n, &c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, "DORMBR"
, "QLT", m, nrhs, m, &c_n1, 6L, 3L);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR",
"P", m, n, m, &c_n1, 6L, 1L);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *nrhs;
maxwrk = max(i__1,i__2);
}
}
maxwrk = max(minwrk,maxwrk);
work[1] = (doublereal) maxwrk;
}
minwrk = max(minwrk,1);
if (*lwork < minwrk) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGELSS", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
*rank = 0;
return 0;
}
/* Get machine parameters */
eps = dlamch_("P", 1L);
sfmin = dlamch_("S", 1L);
smlnum = sfmin / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1], 1L);
iascl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
info, 1L);
iascl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
info, 1L);
iascl = 2;
} else if (anrm == 0.) {
/* Matrix all zero. Return zero solution. */
i__1 = max(*m,*n);
dlaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[b_offset], ldb, 1L);
dlaset_("F", &minmn, &c__1, &c_b74, &c_b74, &s[1], &c__1, 1L);
*rank = 0;
goto L70;
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1], 1L);
ibscl = 0;
if (bnrm > 0. && bnrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
info, 1L);
ibscl = 1;
} else if (bnrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
info, 1L);
ibscl = 2;
}
/* Overdetermined case */
if (*m >= *n) {
/* Path 1 - overdetermined or exactly determined */
mm = *m;
if (*m >= mnthr) {
/* Path 1a - overdetermined, with many more rows than co
lumns */
mm = *n;
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R */
/* (Workspace: need 2*N, prefer N+N*NB) */
i__1 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1,
info);
/* Multiply B by transpose(Q) */
/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */
i__1 = *lwork - iwork + 1;
dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L);
/* Zero out below R */
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
dlaset_("L", &i__1, &i__2, &c_b74, &c_b74, &a[a_dim1 + 2],
lda, 1L);
}
}
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in A */
/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
i__1 = *lwork - iwork + 1;
dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[iwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors of R
*/
/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
i__1 = *lwork - iwork + 1;
dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
&b[b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L, 1L);
/* Generate right bidiagonalizing vectors of R in A */
/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
i__1 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &
i__1, info, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration */
/* multiply B by transpose of left singular vectors */
/* compute right singular vectors in A */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], lda,
vdum, &c__1, &b[b_offset], ldb, &work[iwork], info, 1L);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values */
/* Computing MAX */
d__1 = *rcond * s[1];
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * s[1];
thr = max(d__1,sfmin);
}
*rank = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] > thr) {
drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
++(*rank);
} else {
dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1],
ldb, 1L);
}
/* L10: */
}
/* Multiply B by right singular vectors */
/* (Workspace: need N, prefer N*NRHS) */
if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
dgemm_("T", "N", n, nrhs, n, &c_b108, &a[a_offset], lda, &b[
b_offset], ldb, &c_b74, &work[1], ldb, 1L, 1L);
dlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb, 1L);
} else if (*nrhs > 1) {
chunk = *lwork / *n;
i__1 = *nrhs;
i__2 = chunk;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = *nrhs - i__ + 1;
bl = min(i__3,chunk);
dgemm_("T", "N", n, &bl, n, &c_b108, &a[a_offset], lda, &b[
b_offset], ldb, &c_b74, &work[1], n, 1L, 1L);
dlacpy_("G", n, &bl, &work[1], n, &b[b_offset], ldb, 1L);
/* L20: */
}
} else {
dgemv_("T", n, n, &c_b108, &a[a_offset], lda, &b[b_offset], &c__1,
&c_b74, &work[1], &c__1, 1L);
dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
}
} else /* if(complicated condition) */ {
/* Computing MAX */
i__2 = *m, i__1 = (*m << 1) - 4, i__2 = max(i__2,i__1), i__2 = max(
i__2,*nrhs), i__1 = *n - *m * 3;
if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__2,i__1)) {
/* Path 2a - underdetermined, with many more columns than r
ows */
/* and sufficient workspace for an efficient algorithm */
ldwork = *m;
/* Computing MAX */
/* Computing MAX */
i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
max(i__3,*nrhs), i__4 = *n - *m * 3;
i__2 = (*m << 2) + *m * *lda + max(i__3,i__4), i__1 = *m * *lda +
*m + *m * *nrhs;
if (*lwork >= max(i__2,i__1)) {
ldwork = *lda;
}
itau = 1;
iwork = *m + 1;
/* Compute A=L*Q */
/* (Workspace: need 2*M, prefer M+M*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2,
info);
il = iwork;
/* Copy L to WORK(IL), zeroing out above it */
dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork, 1L);
i__2 = *m - 1;
i__1 = *m - 1;
dlaset_("U", &i__2, &i__1, &c_b74, &c_b74, &work[il + ldwork], &
ldwork, 1L);
ie = il + ldwork * *m;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IL) */
/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
&work[itaup], &work[iwork], &i__2, info);
/* Multiply B by transpose of left bidiagonalizing vectors
of L */
/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
*/
i__2 = *lwork - iwork + 1;
dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
itauq], &b[b_offset], ldb, &work[iwork], &i__2, info, 1L,
1L, 1L);
/* Generate right bidiagonalizing vectors of R in WORK(IL)
*/
/* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[
iwork], &i__2, info, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration, */
/* computing right singular vectors of L in WORK(IL) and
*/
/* multiplying B by transpose of left singular vectors
*/
/* (Workspace: need M*M+M+BDSPAC) */
dbdsqr_("U", m, m, &c__0, nrhs, &s[1], &work[ie], &work[il], &
ldwork, &a[a_offset], lda, &b[b_offset], ldb, &work[iwork]
, info, 1L);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values */
/* Computing MAX */
d__1 = *rcond * s[1];
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * s[1];
thr = max(d__1,sfmin);
}
*rank = 0;
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
if (s[i__] > thr) {
drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
++(*rank);
} else {
dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1]
, ldb, 1L);
}
/* L30: */
}
iwork = ie;
/* Multiply B by right singular vectors of L in WORK(IL) */
/* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) */
if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) {
dgemm_("T", "N", m, nrhs, m, &c_b108, &work[il], &ldwork, &b[
b_offset], ldb, &c_b74, &work[iwork], ldb, 1L, 1L);
dlacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb,
1L);
} else if (*nrhs > 1) {
chunk = (*lwork - iwork + 1) / *m;
i__2 = *nrhs;
i__1 = chunk;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
i__1) {
/* Computing MIN */
i__3 = *nrhs - i__ + 1;
bl = min(i__3,chunk);
dgemm_("T", "N", m, &bl, m, &c_b108, &work[il], &ldwork, &
b[i__ * b_dim1 + 1], ldb, &c_b74, &work[iwork], n,
1L, 1L);
dlacpy_("G", m, &bl, &work[iwork], n, &b[b_offset], ldb,
1L);
/* L40: */
}
} else {
dgemv_("T", m, m, &c_b108, &work[il], &ldwork, &b[b_dim1 + 1],
&c__1, &c_b74, &work[iwork], &c__1, 1L);
dcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1);
}
/* Zero out below first M rows of B */
i__1 = *n - *m;
dlaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[*m + 1 + b_dim1],
ldb, 1L);
iwork = itau + *m;
/* Multiply transpose(Q) by B */
/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */
i__1 = *lwork - iwork + 1;
dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L);
} else {
/* Path 2 - remaining underdetermined cases */
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize A */
/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
i__1 = *lwork - iwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[iwork], &i__1, info);
/* Multiply B by transpose of left bidiagonalizing vectors
*/
/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
i__1 = *lwork - iwork + 1;
dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
, &b[b_offset], ldb, &work[iwork], &i__1, info, 1L, 1L,
1L);
/* Generate right bidiagonalizing vectors in A */
/* (Workspace: need 4*M, prefer 3*M+M*NB) */
i__1 = *lwork - iwork + 1;
dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
iwork], &i__1, info, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration, */
/* computing right singular vectors of A in A and */
/* multiplying B by transpose of left singular vectors
*/
/* (Workspace: need BDSPAC) */
dbdsqr_("L", m, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset],
lda, vdum, &c__1, &b[b_offset], ldb, &work[iwork], info,
1L);
if (*info != 0) {
goto L70;
}
/* Multiply B by reciprocals of singular values */
/* Computing MAX */
d__1 = *rcond * s[1];
thr = max(d__1,sfmin);
if (*rcond < 0.) {
/* Computing MAX */
d__1 = eps * s[1];
thr = max(d__1,sfmin);
}
*rank = 0;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] > thr) {
drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
++(*rank);
} else {
dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1]
, ldb, 1L);
}
/* L50: */
}
/* Multiply B by right singular vectors of A */
/* (Workspace: need N, prefer N*NRHS) */
if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
dgemm_("T", "N", n, nrhs, m, &c_b108, &a[a_offset], lda, &b[
b_offset], ldb, &c_b74, &work[1], ldb, 1L, 1L);
dlacpy_("F", n, nrhs, &work[1], ldb, &b[b_offset], ldb, 1L);
} else if (*nrhs > 1) {
chunk = *lwork / *n;
i__1 = *nrhs;
i__2 = chunk;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
i__2) {
/* Computing MIN */
i__3 = *nrhs - i__ + 1;
bl = min(i__3,chunk);
dgemm_("T", "N", n, &bl, m, &c_b108, &a[a_offset], lda, &
b[i__ * b_dim1 + 1], ldb, &c_b74, &work[1], n, 1L,
1L);
dlacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1],
ldb, 1L);
/* L60: */
}
} else {
dgemv_("T", m, n, &c_b108, &a[a_offset], lda, &b[b_offset], &
c__1, &c_b74, &work[1], &c__1, 1L);
dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
}
}
}
/* Undo scaling */
if (iascl == 1) {
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
info, 1L);
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
minmn, info, 1L);
} else if (iascl == 2) {
dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
info, 1L);
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
minmn, info, 1L);
}
if (ibscl == 1) {
dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
info, 1L);
} else if (ibscl == 2) {
dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
info, 1L);
}
L70:
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGELSS */
} /* dgelss_ */
/* dlacpy.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlacpy_(uplo, m, n, a, lda, b, ldb, uplo_len)
char *uplo;
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *b;
integer *ldb;
ftnlen uplo_len;
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer i__, j;
extern logical lsame_();
/* -- LAPACK auxiliary routine (version 2.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 */
/* ======= */
/* DLACPY copies all or part of a two-dimensional matrix A to another */
/* matrix B. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies the part of the matrix A to be copied to B. */
/* = 'U': Upper triangular part */
/* = 'L': Lower triangular part */
/* Otherwise: All of the matrix A */
/* 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* The m by n matrix A. If UPLO = 'U', only the upper triangle
*/
/* or trapezoid is accessed; if UPLO = 'L', only the lower */
/* triangle or trapezoid is accessed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (output) DOUBLE PRECISION array, dimension (LDB,N) */
/* On exit, B = A in the locations specified by UPLO. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,M). */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = b_dim1 + 1;
b -= b_offset;
/* Function Body */
if (lsame_(uplo, "U", 1L, 1L)) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
/* L10: */
}
/* L20: */
}
} else if (lsame_(uplo, "L", 1L, 1L)) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
/* L30: */
}
/* L40: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
/* L50: */
}
/* L60: */
}
}
return 0;
/* End of DLACPY */
} /* dlacpy_ */
/* dlabrd.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b4
#undef c_b4
#endif
#define c_b4 c_b4b
#ifdef c_b5
#undef c_b5
#endif
#define c_b5 c_b5
#ifdef c_b16
#undef c_b16
#endif
#define c_b16 c_b16
/* Subroutine */ int dlabrd_(m, n, nb, a, lda, d__, e, tauq, taup, x, ldx, y,
ldy)
integer *m, *n, *nb;
doublereal *a;
integer *lda;
doublereal *d__, *e, *tauq, *taup, *x;
integer *ldx;
doublereal *y;
integer *ldy;
{
/* System generated locals */
integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
i__3;
/* Local variables */
static integer i__;
extern /* Subroutine */ int dscal_(), dgemv_(), dlarfg_();
/* -- LAPACK auxiliary routine (version 2.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 */
/* ======= */
/* DLABRD reduces the first NB rows and columns of a real general */
/* m by n matrix A to upper or lower bidiagonal form by an orthogonal */
/* transformation Q' * A * P, and returns the matrices X and Y which */
/* are needed to apply the transformation to the unreduced part of A. */
/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
*/
/* bidiagonal form. */
/* This is an auxiliary routine called by DGEBRD */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows in the matrix A. */
/* N (input) INTEGER */
/* The number of columns in the matrix A. */
/* NB (input) INTEGER */
/* The number of leading rows and columns of A to be reduced. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the m by n general matrix to be reduced. */
/* On exit, the first NB rows and columns of the matrix are */
/* overwritten; the rest of the array is unchanged. */
/* If m >= n, elements on and below the diagonal in the first NB
*/
/* columns, with the array TAUQ, represent the orthogonal */
/* matrix Q as a product of elementary reflectors; and */
/* elements above the diagonal in the first NB rows, with the
*/
/* array TAUP, represent the orthogonal matrix P as a product
*/
/* of elementary reflectors. */
/* If m < n, elements below the diagonal in the first NB */
/* columns, with the array TAUQ, represent the orthogonal */
/* matrix Q as a product of elementary reflectors, and */
/* elements on and above the diagonal in the first NB rows, */
/* 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) DOUBLE PRECISION array, dimension (NB) */
/* The diagonal elements of the first NB rows and columns of */
/* the reduced matrix. D(i) = A(i,i). */
/* E (output) DOUBLE PRECISION array, dimension (NB) */
/* The off-diagonal elements of the first NB rows and columns of
*/
/* the reduced matrix. */
/* TAUQ (output) DOUBLE PRECISION array dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix Q. See Further Details. */
/* TAUP (output) DOUBLE PRECISION array, dimension (NB) */
/* The scalar factors of the elementary reflectors which */
/* represent the orthogonal matrix P. See Further Details. */
/* X (output) DOUBLE PRECISION array, dimension (LDX,NB) */
/* The m-by-nb matrix X required to update the unreduced part */
/* of A. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= M. */
/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
/* The n-by-nb matrix Y required to update the unreduced part */
/* of A. */
/* LDY (output) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrices Q and P are represented as products of elementary */
/* reflectors: */
/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
/* 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. */
/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
/* A(i:m,i); u(1:i) = 0, u(i+1) = 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). */
/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
/* The elements of the vectors v and u together form the m-by-nb matrix
*/
/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply
*/
/* the transformation to the unreduced part of the matrix, using a block
*/
/* update of the form: A := A - V*Y' - X*U'. */
/* The contents of A on exit are illustrated by the following examples */
/* with nb = 2: */
/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
/* ( v1 v2 a a a ) ( v1 1 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix which is unchanged,
*/
/* 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 .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--d__;
--e;
--tauq;
--taup;
x_dim1 = *ldx;
x_offset = x_dim1 + 1;
x -= x_offset;
y_dim1 = *ldy;
y_offset = y_dim1 + 1;
y -= y_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (*m >= *n) {
/* Reduce to upper bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:m,i) */
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda,
&y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], &
c__1, 12L);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx,
&a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ *
a_dim1], &c__1, 12L);
/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&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];
if (i__ < *n) {
a[i__ + i__ * a_dim1] = 1.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) *
a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &
y[i__ + 1 + i__ * y_dim1], &c__1, 9L);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1],
lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ *
y_dim1 + 1], &c__1, 9L);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
i__ + 1 + i__ * y_dim1], &c__1, 12L);
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1],
ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ *
y_dim1 + 1], &c__1, 9L);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5,
&y[i__ + 1 + i__ * y_dim1], &c__1, 9L);
i__2 = *n - i__;
dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
/* Update A(i,i+1:n) */
i__2 = *n - i__;
dgemv_("No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 +
y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + (
i__ + 1) * a_dim1], lda, 12L);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[
i__ + (i__ + 1) * a_dim1], lda, 9L);
/* Generate reflection P(i) to annihilate A(i,i+2
:n) */
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&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.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__
+ 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = *n - i__;
dgemv_("Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1],
ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[
i__ * x_dim1 + 1], &c__1, 9L);
i__2 = *m - i__;
dgemv_("No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = i__ - 1;
i__3 = *n - i__;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b16, &x[i__ * x_dim1 + 1], &c__1, 12L);
i__2 = *m - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = *m - i__;
dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
}
/* L10: */
}
} else {
/* Reduce to lower bidiagonal form */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i,i:n) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy,
&a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1],
lda, 12L);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1],
lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1],
lda, 9L);
/* Generate reflection P(i) to annihilate A(i,i+1:n) */
i__2 = *n - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
dlarfg_(&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];
if (i__ < *m) {
a[i__ + i__ * a_dim1] = 1.;
/* Compute X(i+1:m,i) */
i__2 = *m - i__;
i__3 = *n - i__ + 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ *
a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &
x[i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1],
ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
x_dim1 + 1], &c__1, 9L);
i__2 = *m - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 +
a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 +
1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
x_dim1 + 1], &c__1, 12L);
i__2 = *m - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 +
x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
i__ + 1 + i__ * x_dim1], &c__1, 12L);
i__2 = *m - i__;
dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
/* Update A(i+1:m,i) */
i__2 = *m - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 +
a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ +
1 + i__ * a_dim1], &c__1, 12L);
i__2 = *m - i__;
dgemv_("No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 +
x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[
i__ + 1 + i__ * a_dim1], &c__1, 12L);
/* Generate reflection Q(i) to annihilate A(i+2:m
,i) */
i__2 = *m - i__;
/* Computing MIN */
i__3 = i__ + 2;
dlarfg_(&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.;
/* Compute Y(i+1:n,i) */
i__2 = *m - i__;
i__3 = *n - i__;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ +
1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1,
&c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1, 9L);
i__2 = *m - i__;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1],
lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
i__ * y_dim1 + 1], &c__1, 9L);
i__2 = *n - i__;
i__3 = i__ - 1;
dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 +
y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
i__ + 1 + i__ * y_dim1], &c__1, 12L);
i__2 = *m - i__;
dgemv_("Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1],
ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
i__ * y_dim1 + 1], &c__1, 9L);
i__2 = *n - i__;
dgemv_("Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1
+ 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__
+ 1 + i__ * y_dim1], &c__1, 9L);
i__2 = *n - i__;
dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of DLABRD */
} /* dlabrd_ */
/* ilaenv.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
integer ilaenv_(ispec, name__, opts, n1, n2, n3, n4, name_len, opts_len)
integer *ispec;
char *name__, *opts;
integer *n1, *n2, *n3, *n4;
ftnlen name_len;
ftnlen opts_len;
{
/* System generated locals */
integer ret_val;
/* Builtin functions */
/* Subroutine */ int s_copy();
integer s_cmp();
/* Local variables */
static integer i__;
static logical cname, sname;
static integer nbmin;
static char c1[1], c2[2], c3[3], c4[2];
static integer ic, nb, iz, nx;
static char subnam[6];
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ILAENV is called from the LAPACK routines to choose problem-dependent
*/
/* parameters for the local environment. See ISPEC for a description of
*/
/* the parameters. */
/* This version provides a set of parameters which should give good, */
/* but not optimal, performance on many of the currently available */
/* computers. Users are encouraged to modify this subroutine to set */
/* the tuning parameters for their particular machine using the option */
/* and problem size information in the arguments. */
/* This routine will not function correctly if it is converted to all */
/* lower case. Converting it to all upper case is allowed. */
/* Arguments */
/* ========= */
/* ISPEC (input) INTEGER */
/* Specifies the parameter to be returned as the value of */
/* ILAENV. */
/* = 1: the optimal blocksize; if this value is 1, an unblocked
*/
/* algorithm will give the best performance. */
/* = 2: the minimum block size for which the block routine */
/* should be used; if the usable block size is less than */
/* this value, an unblocked routine should be used. */
/* = 3: the crossover point (in a block routine, for N less */
/* than this value, an unblocked routine should be used) */
/* = 4: the number of shifts, used in the nonsymmetric */
/* eigenvalue routines */
/* = 5: the minimum column dimension for blocking to be used; */
/* rectangular blocks must have dimension at least k by m,
*/
/* where k is given by ILAENV(2,...) and m by ILAENV(5,...)
*/
/* = 6: the crossover point for the SVD (when reducing an m by n
*/
/* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
*/
/* this value, a QR factorization is used first to reduce */
/* the matrix to a triangular form.) */
/* = 7: the number of processors */
/* = 8: the crossover point for the multishift QR and QZ methods
*/
/* for nonsymmetric eigenvalue problems. */
/* NAME (input) CHARACTER*(*) */
/* The name of the calling subroutine, in either upper case or */
/* lower case. */
/* OPTS (input) CHARACTER*(*) */
/* The character options to the subroutine NAME, concatenated */
/* into a single character string. For example, UPLO = 'U', */
/* TRANS = 'T', and DIAG = 'N' for a triangular routine would */
/* be specified as OPTS = 'UTN'. */
/* N1 (input) INTEGER */
/* N2 (input) INTEGER */
/* N3 (input) INTEGER */
/* N4 (input) INTEGER */
/* Problem dimensions for the subroutine NAME; these may not all
*/
/* be required. */
/* (ILAENV) (output) INTEGER */
/* >= 0: the value of the parameter specified by ISPEC */
/* < 0: if ILAENV = -k, the k-th argument had an illegal value.
*/
/* Further Details */
/* =============== */
/* The following conventions have been used when calling ILAENV from the
*/
/* LAPACK routines: */
/* 1) OPTS is a concatenation of all of the character options to */
/* subroutine NAME, in the same order that they appear in the */
/* argument list for NAME, even if they are not used in determining
*/
/* the value of the parameter specified by ISPEC. */
/* 2) The problem dimensions N1, N2, N3, N4 are specified in the order
*/
/* that they appear in the argument list for NAME. N1 is used */
/* first, N2 second, and so on, and unused problem dimensions are */
/* passed a value of -1. */
/* 3) The parameter value returned by ILAENV is checked for validity in
*/
/* the calling subroutine. For example, ILAENV is used to retrieve
*/
/* the optimal blocksize for STRTRI as follows: */
/* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */
/* IF( NB.LE.1 ) NB = MAX( 1, N ) */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
switch ((int)*ispec) {
case 1: goto L100;
case 2: goto L100;
case 3: goto L100;
case 4: goto L400;
case 5: goto L500;
case 6: goto L600;
case 7: goto L700;
case 8: goto L800;
}
/* Invalid value for ISPEC */
ret_val = -1;
return ret_val;
L100:
/* Convert NAME to upper case if the first character is lower case. */
ret_val = 1;
s_copy(subnam, name__, 6L, name_len);
ic = *(unsigned char *)subnam;
iz = 'Z';
if (iz == 90 || iz == 122) {
/* ASCII character set */
if (ic >= 97 && ic <= 122) {
*(unsigned char *)subnam = (char) (ic - 32);
for (i__ = 2; i__ <= 6; ++i__) {
ic = *(unsigned char *)&subnam[i__ - 1];
if (ic >= 97 && ic <= 122) {
*(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
}
/* L10: */
}
}
} else if (iz == 233 || iz == 169) {
/* EBCDIC character set */
if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 &&
ic <= 169) {
*(unsigned char *)subnam = (char) (ic + 64);
for (i__ = 2; i__ <= 6; ++i__) {
ic = *(unsigned char *)&subnam[i__ - 1];
if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >=
162 && ic <= 169) {
*(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64);
}
/* L20: */
}
}
} else if (iz == 218 || iz == 250) {
/* Prime machines: ASCII+128 */
if (ic >= 225 && ic <= 250) {
*(unsigned char *)subnam = (char) (ic - 32);
for (i__ = 2; i__ <= 6; ++i__) {
ic = *(unsigned char *)&subnam[i__ - 1];
if (ic >= 225 && ic <= 250) {
*(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
}
/* L30: */
}
}
}
*(unsigned char *)c1 = *(unsigned char *)subnam;
sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
if (! (cname || sname)) {
return ret_val;
}
s_copy(c2, subnam + 1, 2L, 2L);
s_copy(c3, subnam + 3, 3L, 3L);
s_copy(c4, c3 + 1, 2L, 2L);
switch ((int)*ispec) {
case 1: goto L110;
case 2: goto L200;
case 3: goto L300;
}
L110:
/* ISPEC = 1: block size */
/* In these examples, separate code is provided for setting NB for */
/* real and complex. We assume that NB will take the same value in */
/* single or double precision. */
nb = 1;
if (s_cmp(c2, "GE", 2L, 2L) == 0) {
if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
} else if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L)
== 0 || s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L,
3L) == 0) {
if (sname) {
nb = 32;
} else {
nb = 32;
}
} else if (s_cmp(c3, "HRD", 3L, 3L) == 0) {
if (sname) {
nb = 32;
} else {
nb = 32;
}
} else if (s_cmp(c3, "BRD", 3L, 3L) == 0) {
if (sname) {
nb = 32;
} else {
nb = 32;
}
} else if (s_cmp(c3, "TRI", 3L, 3L) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (s_cmp(c2, "PO", 2L, 2L) == 0) {
if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (s_cmp(c2, "SY", 2L, 2L) == 0) {
if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
} else if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) {
nb = 1;
} else if (sname && s_cmp(c3, "GST", 3L, 3L) == 0) {
nb = 64;
}
} else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) {
if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
nb = 64;
} else if (s_cmp(c3, "TRD", 3L, 3L) == 0) {
nb = 1;
} else if (s_cmp(c3, "GST", 3L, 3L) == 0) {
nb = 64;
}
} else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0
|| s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
== 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR",
2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
nb = 32;
}
} else if (*(unsigned char *)c3 == 'M') {
if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0
|| s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
== 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR",
2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
nb = 32;
}
}
} else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0
|| s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
== 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR",
2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
nb = 32;
}
} else if (*(unsigned char *)c3 == 'M') {
if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0
|| s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
== 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR",
2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
nb = 32;
}
}
} else if (s_cmp(c2, "GB", 2L, 2L) == 0) {
if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
if (sname) {
if (*n4 <= 64) {
nb = 1;
} else {
nb = 32;
}
} else {
if (*n4 <= 64) {
nb = 1;
} else {
nb = 32;
}
}
}
} else if (s_cmp(c2, "PB", 2L, 2L) == 0) {
if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
if (sname) {
if (*n2 <= 64) {
nb = 1;
} else {
nb = 32;
}
} else {
if (*n2 <= 64) {
nb = 1;
} else {
nb = 32;
}
}
}
} else if (s_cmp(c2, "TR", 2L, 2L) == 0) {
if (s_cmp(c3, "TRI", 3L, 3L) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (s_cmp(c2, "LA", 2L, 2L) == 0) {
if (s_cmp(c3, "UUM", 3L, 3L) == 0) {
if (sname) {
nb = 64;
} else {
nb = 64;
}
}
} else if (sname && s_cmp(c2, "ST", 2L, 2L) == 0) {
if (s_cmp(c3, "EBZ", 3L, 3L) == 0) {
nb = 1;
}
}
ret_val = nb;
return ret_val;
L200:
/* ISPEC = 2: minimum block size */
nbmin = 2;
if (s_cmp(c2, "GE", 2L, 2L) == 0) {
if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) == 0 ||
s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 3L) ==
0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
} else if (s_cmp(c3, "HRD", 3L, 3L) == 0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
} else if (s_cmp(c3, "BRD", 3L, 3L) == 0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
} else if (s_cmp(c3, "TRI", 3L, 3L) == 0) {
if (sname) {
nbmin = 2;
} else {
nbmin = 2;
}
}
} else if (s_cmp(c2, "SY", 2L, 2L) == 0) {
if (s_cmp(c3, "TRF", 3L, 3L) == 0) {
if (sname) {
nbmin = 8;
} else {
nbmin = 8;
}
} else if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) {
nbmin = 2;
}
} else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) {
if (s_cmp(c3, "TRD", 3L, 3L) == 0) {
nbmin = 2;
}
} else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0
|| s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
== 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR",
2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
nbmin = 2;
}
} else if (*(unsigned char *)c3 == 'M') {
if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0
|| s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
== 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR",
2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
nbmin = 2;
}
}
} else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0
|| s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
== 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR",
2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
nbmin = 2;
}
} else if (*(unsigned char *)c3 == 'M') {
if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0
|| s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
== 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR",
2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
nbmin = 2;
}
}
}
ret_val = nbmin;
return ret_val;
L300:
/* ISPEC = 3: crossover point */
nx = 0;
if (s_cmp(c2, "GE", 2L, 2L) == 0) {
if (s_cmp(c3, "QRF", 3L, 3L) == 0 || s_cmp(c3, "RQF", 3L, 3L) == 0 ||
s_cmp(c3, "LQF", 3L, 3L) == 0 || s_cmp(c3, "QLF", 3L, 3L) ==
0) {
if (sname) {
nx = 128;
} else {
nx = 128;
}
} else if (s_cmp(c3, "HRD", 3L, 3L) == 0) {
if (sname) {
nx = 128;
} else {
nx = 128;
}
} else if (s_cmp(c3, "BRD", 3L, 3L) == 0) {
if (sname) {
nx = 128;
} else {
nx = 128;
}
}
} else if (s_cmp(c2, "SY", 2L, 2L) == 0) {
if (sname && s_cmp(c3, "TRD", 3L, 3L) == 0) {
nx = 1;
}
} else if (cname && s_cmp(c2, "HE", 2L, 2L) == 0) {
if (s_cmp(c3, "TRD", 3L, 3L) == 0) {
nx = 1;
}
} else if (sname && s_cmp(c2, "OR", 2L, 2L) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0
|| s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
== 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR",
2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
nx = 128;
}
}
} else if (cname && s_cmp(c2, "UN", 2L, 2L) == 0) {
if (*(unsigned char *)c3 == 'G') {
if (s_cmp(c4, "QR", 2L, 2L) == 0 || s_cmp(c4, "RQ", 2L, 2L) == 0
|| s_cmp(c4, "LQ", 2L, 2L) == 0 || s_cmp(c4, "QL", 2L, 2L)
== 0 || s_cmp(c4, "HR", 2L, 2L) == 0 || s_cmp(c4, "TR",
2L, 2L) == 0 || s_cmp(c4, "BR", 2L, 2L) == 0) {
nx = 128;
}
}
}
ret_val = nx;
return ret_val;
L400:
/* ISPEC = 4: number of shifts (used by xHSEQR) */
ret_val = 6;
return ret_val;
L500:
/* ISPEC = 5: minimum column dimension (not used) */
ret_val = 2;
return ret_val;
L600:
/* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */
ret_val = (integer) ((real) min(*n1,*n2) * (float)1.6);
return ret_val;
L700:
/* ISPEC = 7: number of processors (not used) */
ret_val = 1;
return ret_val;
L800:
/* ISPEC = 8: crossover point for multishift (used by xHSEQR) */
ret_val = 50;
return ret_val;
/* End of ILAENV */
} /* ilaenv_ */
/* dgetrf.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b16
#undef c_b16
#endif
#define c_b16 c_b16a
#ifdef c_b19
#undef c_b19
#endif
#define c_b19 c_b19
/* Subroutine */ int dgetrf_(m, n, a, lda, ipiv, info)
integer *m, *n;
doublereal *a;
integer *lda, *ipiv, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
/* Local variables */
static integer i__, j;
extern /* Subroutine */ int dgemm_();
static integer iinfo;
extern /* Subroutine */ int dtrsm_(), dgetf2_();
static integer jb, nb;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int dlaswp_();
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGETRF computes an LU factorization of a general M-by-N matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This is the right-looking Level 3 BLAS version of the algorithm. */
/* 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
*/
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used
*/
/* to solve a system of equations. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--ipiv;
/* 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_("DGETRF", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "DGETRF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
if (nb <= 1 || nb >= min(*m,*n)) {
/* Use unblocked code. */
dgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
} else {
/* Use blocked code. */
i__1 = min(*m,*n);
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = min(*m,*n) - j + 1;
jb = min(i__3,nb);
/* Factor diagonal and subdiagonal blocks and test for e
xact */
/* singularity. */
i__3 = *m - j + 1;
dgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
/* Adjust INFO and the pivot indices. */
if (*info == 0 && iinfo > 0) {
*info = iinfo + j - 1;
}
/* Computing MIN */
i__4 = *m, i__5 = j + jb - 1;
i__3 = min(i__4,i__5);
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = j - 1 + ipiv[i__];
/* L10: */
}
/* Apply interchanges to columns 1:J-1. */
i__3 = j - 1;
i__4 = j + jb - 1;
dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
if (j + jb <= *n) {
/* Apply interchanges to columns J+JB:N. */
i__3 = *n - j - jb + 1;
i__4 = j + jb - 1;
dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
ipiv[1], &c__1);
/* Compute block row of U. */
i__3 = *n - j - jb + 1;
dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
c_b16, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
a_dim1], lda, 4L, 5L, 12L, 4L);
if (j + jb <= *m) {
/* Update trailing submatrix. */
i__3 = *m - j - jb + 1;
i__4 = *n - j - jb + 1;
dgemm_("No transpose", "No transpose", &i__3, &i__4, &jb,
&c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j +
jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) *
a_dim1], lda, 12L, 12L);
}
}
/* L20: */
}
}
return 0;
/* End of DGETRF */
} /* dgetrf_ */
/* dlasr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlasr_(side, pivot, direct, m, n, c__, s, a, lda,
side_len, pivot_len, direct_len)
char *side, *pivot, *direct;
integer *m, *n;
doublereal *c__, *s, *a;
integer *lda;
ftnlen side_len;
ftnlen pivot_len;
ftnlen direct_len;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer info;
static doublereal temp;
static integer i__, j;
extern logical lsame_();
static doublereal ctemp, stemp;
extern /* Subroutine */ int xerbla_();
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASR performs the transformation */
/* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) */
/* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) */
/* where A is an m by n real matrix and P is an orthogonal matrix, */
/* consisting of a sequence of plane rotations determined by the */
/* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
*/
/* and z = n when SIDE = 'R' or 'r' ): */
/* When DIRECT = 'F' or 'f' ( Forward sequence ) then */
/* P = P( z - 1 )*...*P( 2 )*P( 1 ), */
/* and when DIRECT = 'B' or 'b' ( Backward sequence ) then */
/* P = P( 1 )*P( 2 )*...*P( z - 1 ), */
/* where P( k ) is a plane rotation matrix for the following planes: */
/* when PIVOT = 'V' or 'v' ( Variable pivot ), */
/* the plane ( k, k + 1 ) */
/* when PIVOT = 'T' or 't' ( Top pivot ), */
/* the plane ( 1, k + 1 ) */
/* when PIVOT = 'B' or 'b' ( Bottom pivot ), */
/* the plane ( k, z ) */
/* c( k ) and s( k ) must contain the cosine and sine that define the
*/
/* matrix P( k ). The two by two plane rotation part of the matrix */
/* P( k ), R( k ), is assumed to be of the form */
/* R( k ) = ( c( k ) s( k ) ). */
/* ( -s( k ) c( k ) ) */
/* This version vectorises across rows of the array A when SIDE = 'L'. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* Specifies whether the plane rotation matrix P is applied to */
/* A on the left or the right. */
/* = 'L': Left, compute A := P*A */
/* = 'R': Right, compute A:= A*P' */
/* DIRECT (input) CHARACTER*1 */
/* Specifies whether P is a forward or backward sequence of */
/* plane rotations. */
/* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) */
/* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) */
/* PIVOT (input) CHARACTER*1 */
/* Specifies the plane for which P(k) is a plane rotation */
/* matrix. */
/* = 'V': Variable pivot, the plane (k,k+1) */
/* = 'T': Top pivot, the plane (1,k+1) */
/* = 'B': Bottom pivot, the plane (k,z) */
/* M (input) INTEGER */
/* The number of rows of the matrix A. If m <= 1, an immediate
*/
/* return is effected. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. If n <= 1, an */
/* immediate return is effected. */
/* C, S (input) DOUBLE PRECISION arrays, dimension */
/* (M-1) if SIDE = 'L' */
/* (N-1) if SIDE = 'R' */
/* c(k) and s(k) contain the cosine and sine that define the */
/* matrix P(k). The two by two plane rotation part of the */
/* matrix P(k), R(k), is assumed to be of the form */
/* R( k ) = ( c( k ) s( k ) ). */
/* ( -s( k ) c( k ) ) */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* The m by n matrix A. On exit, A is overwritten by P*A if */
/* SIDE = 'R' or by A*P' if SIDE = 'L'. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
--c__;
--s;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
info = 0;
if (! (lsame_(side, "L", 1L, 1L) || lsame_(side, "R", 1L, 1L))) {
info = 1;
} else if (! (lsame_(pivot, "V", 1L, 1L) || lsame_(pivot, "T", 1L, 1L) ||
lsame_(pivot, "B", 1L, 1L))) {
info = 2;
} else if (! (lsame_(direct, "F", 1L, 1L) || lsame_(direct, "B", 1L, 1L)))
{
info = 3;
} else if (*m < 0) {
info = 4;
} else if (*n < 0) {
info = 5;
} else if (*lda < max(1,*m)) {
info = 9;
}
if (info != 0) {
xerbla_("DLASR ", &info, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
if (lsame_(side, "L", 1L, 1L)) {
/* Form P * A */
if (lsame_(pivot, "V", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + 1 + i__ * a_dim1];
a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ i__ * a_dim1];
/* L10: */
}
}
/* L20: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *m - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + 1 + i__ * a_dim1];
a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ i__ * a_dim1];
/* L30: */
}
}
/* L40: */
}
}
} else if (lsame_(pivot, "T", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *m;
for (j = 2; j <= i__1; ++j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
i__ * a_dim1 + 1];
a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
i__ * a_dim1 + 1];
/* L50: */
}
}
/* L60: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *m; j >= 2; --j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
i__ * a_dim1 + 1];
a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
i__ * a_dim1 + 1];
/* L70: */
}
}
/* L80: */
}
}
} else if (lsame_(pivot, "B", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ ctemp * temp;
a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
a_dim1] - stemp * temp;
/* L90: */
}
}
/* L100: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *m - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[j + i__ * a_dim1];
a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ ctemp * temp;
a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
a_dim1] - stemp * temp;
/* L110: */
}
}
/* L120: */
}
}
}
} else if (lsame_(side, "R", 1L, 1L)) {
/* Form A * P' */
if (lsame_(pivot, "V", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + (j + 1) * a_dim1];
a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
i__ + j * a_dim1];
/* L130: */
}
}
/* L140: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *n - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + (j + 1) * a_dim1];
a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
i__ + j * a_dim1];
/* L150: */
}
}
/* L160: */
}
}
} else if (lsame_(pivot, "T", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
i__ + a_dim1];
a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
a_dim1];
/* L170: */
}
}
/* L180: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *n; j >= 2; --j) {
ctemp = c__[j - 1];
stemp = s[j - 1];
if (ctemp != 1. || stemp != 0.) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
i__ + a_dim1];
a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
a_dim1];
/* L190: */
}
}
/* L200: */
}
}
} else if (lsame_(pivot, "B", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ ctemp * temp;
a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
a_dim1] - stemp * temp;
/* L210: */
}
}
/* L220: */
}
} else if (lsame_(direct, "B", 1L, 1L)) {
for (j = *n - 1; j >= 1; --j) {
ctemp = c__[j];
stemp = s[j];
if (ctemp != 1. || stemp != 0.) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = a[i__ + j * a_dim1];
a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ ctemp * temp;
a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
a_dim1] - stemp * temp;
/* L230: */
}
}
/* L240: */
}
}
}
}
return 0;
/* End of DLASR */
} /* dlasr_ */
/* dlabad.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlabad_(small, large)
doublereal *small, *large;
{
/* Builtin functions */
double d_lg10(), sqrt();
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLABAD takes as input the values computed by SLAMCH for underflow and
*/
/* overflow, and returns the square root of each of these values if the
*/
/* log of LARGE is sufficiently large. This subroutine is intended to */
/* identify machines with a large exponent range, such as the Crays, and
*/
/* redefine the underflow and overflow limits to be the square roots of
*/
/* the values computed by DLAMCH. This subroutine is needed because */
/* DLAMCH does not compensate for poor arithmetic in the upper half of */
/* the exponent range, as is found on a Cray. */
/* Arguments */
/* ========= */
/* SMALL (input/output) DOUBLE PRECISION */
/* On entry, the underflow threshold as computed by DLAMCH. */
/* On exit, if LOG10(LARGE) is sufficiently large, the square */
/* root of SMALL, otherwise unchanged. */
/* LARGE (input/output) DOUBLE PRECISION */
/* On entry, the overflow threshold as computed by DLAMCH. */
/* On exit, if LOG10(LARGE) is sufficiently large, the square */
/* root of LARGE, otherwise unchanged. */
/* =====================================================================
*/
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* If it looks like we're on a Cray, take the square root of */
/* SMALL and LARGE to avoid overflow and underflow problems. */
if (d_lg10(large) > 2e3) {
*small = sqrt(*small);
*large = sqrt(*large);
}
return 0;
/* End of DLABAD */
} /* dlabad_ */
/* dgetrs.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b12
#undef c_b12
#endif
#define c_b12 c_b12
/* Subroutine */ int dgetrs_(trans, n, nrhs, a, lda, ipiv, b, ldb, info,
trans_len)
char *trans;
integer *n, *nrhs;
doublereal *a;
integer *lda, *ipiv;
doublereal *b;
integer *ldb, *info;
ftnlen trans_len;
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern logical lsame_();
extern /* Subroutine */ int dtrsm_(), xerbla_(), dlaswp_();
static logical notran;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGETRS solves a system of linear equations */
/* A * X = B or A' * X = B */
/* with a general N-by-N matrix A using the LU factorization computed */
/* by DGETRF. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A'* X = B (Transpose) */
/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The factors L and U from the factorization A = P*L*U */
/* as computed by DGETRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
/* matrix was interchanged with row IPIV(i). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, the solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* 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 parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = b_dim1 + 1;
b -= b_offset;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N", 1L, 1L);
if (! notran && ! lsame_(trans, "T", 1L, 1L) && ! lsame_(trans, "C", 1L,
1L)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGETRS", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (notran) {
/* Solve A * X = B. */
/* Apply row interchanges to the right hand sides. */
dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
/* Solve L*X = B, overwriting B with X. */
dtrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b12, &a[
a_offset], lda, &b[b_offset], ldb, 4L, 5L, 12L, 4L);
/* Solve U*X = B, overwriting B with X. */
dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b12, &
a[a_offset], lda, &b[b_offset], ldb, 4L, 5L, 12L, 8L);
} else {
/* Solve A' * X = B. */
/* Solve U'*X = B, overwriting B with X. */
dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b12, &a[
a_offset], lda, &b[b_offset], ldb, 4L, 5L, 9L, 8L);
/* Solve L'*X = B, overwriting B with X. */
dtrsm_("Left", "Lower", "Transpose", "Unit", n, nrhs, &c_b12, &a[
a_offset], lda, &b[b_offset], ldb, 4L, 5L, 9L, 4L);
/* Apply row interchanges to the solution vectors. */
dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
}
return 0;
/* End of DGETRS */
} /* dgetrs_ */
/* dlasrt.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlasrt_(id0, n, d__, info, id_len)
char *id0;
integer *n;
doublereal *d__;
integer *info;
ftnlen id_len;
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer endd, i__, j;
extern logical lsame_();
static integer stack[64] /* was [2][32] */;
static doublereal dmnmx, d1, d2, d3;
static integer start;
extern /* Subroutine */ int xerbla_();
static integer stkpnt, dir;
static doublereal tmp;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* Sort the numbers in D in increasing order (if ID = 'I') or */
/* in decreasing order (if ID = 'D' ). */
/* Use Quick Sort, reverting to Insertion sort on arrays of */
/* size <= 20. Dimension of STACK limits N to about 2**32. */
/* Arguments */
/* ========= */
/* ID (input) CHARACTER*1 */
/* = 'I': sort D in increasing order; */
/* = 'D': sort D in decreasing order. */
/* N (input) INTEGER */
/* The length of the array D. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the array to be sorted. */
/* On exit, D has been sorted into increasing order */
/* (D(1) <= ... <= D(N) ) or into decreasing order */
/* (D(1) >= ... >= D(N) ), depending on ID. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input paramters. */
/* Parameter adjustments */
--d__;
/* Function Body */
*info = 0;
dir = -1;
if (lsame_(id0, "D", 1L, 1L)) {
dir = 0;
} else if (lsame_(id0, "I", 1L, 1L)) {
dir = 1;
}
if (dir == -1) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLASRT", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*n <= 1) {
return 0;
}
stkpnt = 1;
stack[0] = 1;
stack[1] = *n;
L10:
start = stack[(stkpnt << 1) - 2];
endd = stack[(stkpnt << 1) - 1];
--stkpnt;
if (endd - start <= 20 && endd - start > 0) {
/* Do Insertion sort on D( START:ENDD ) */
if (dir == 0) {
/* Sort into decreasing order */
i__1 = endd;
for (i__ = start + 1; i__ <= i__1; ++i__) {
i__2 = start + 1;
for (j = i__; j >= i__2; --j) {
if (d__[j] > d__[j - 1]) {
dmnmx = d__[j];
d__[j] = d__[j - 1];
d__[j - 1] = dmnmx;
} else {
goto L30;
}
/* L20: */
}
L30:
;
}
} else {
/* Sort into increasing order */
i__1 = endd;
for (i__ = start + 1; i__ <= i__1; ++i__) {
i__2 = start + 1;
for (j = i__; j >= i__2; --j) {
if (d__[j] < d__[j - 1]) {
dmnmx = d__[j];
d__[j] = d__[j - 1];
d__[j - 1] = dmnmx;
} else {
goto L50;
}
/* L40: */
}
L50:
;
}
}
} else if (endd - start > 20) {
/* Partition D( START:ENDD ) and stack parts, largest one first
*/
/* Choose partition entry as median of 3 */
d1 = d__[start];
d2 = d__[endd];
i__ = (start + endd) / 2;
d3 = d__[i__];
if (d1 < d2) {
if (d3 < d1) {
dmnmx = d1;
} else if (d3 < d2) {
dmnmx = d3;
} else {
dmnmx = d2;
}
} else {
if (d3 < d2) {
dmnmx = d2;
} else if (d3 < d1) {
dmnmx = d3;
} else {
dmnmx = d1;
}
}
if (dir == 0) {
/* Sort into decreasing order */
i__ = start - 1;
j = endd + 1;
L60:
L70:
--j;
if (d__[j] < dmnmx) {
goto L70;
}
L80:
++i__;
if (d__[i__] > dmnmx) {
goto L80;
}
if (i__ < j) {
tmp = d__[i__];
d__[i__] = d__[j];
d__[j] = tmp;
goto L60;
}
if (j - start > endd - j - 1) {
++stkpnt;
stack[(stkpnt << 1) - 2] = start;
stack[(stkpnt << 1) - 1] = j;
++stkpnt;
stack[(stkpnt << 1) - 2] = j + 1;
stack[(stkpnt << 1) - 1] = endd;
} else {
++stkpnt;
stack[(stkpnt << 1) - 2] = j + 1;
stack[(stkpnt << 1) - 1] = endd;
++stkpnt;
stack[(stkpnt << 1) - 2] = start;
stack[(stkpnt << 1) - 1] = j;
}
} else {
/* Sort into increasing order */
i__ = start - 1;
j = endd + 1;
L90:
L100:
--j;
if (d__[j] > dmnmx) {
goto L100;
}
L110:
++i__;
if (d__[i__] < dmnmx) {
goto L110;
}
if (i__ < j) {
tmp = d__[i__];
d__[i__] = d__[j];
d__[j] = tmp;
goto L90;
}
if (j - start > endd - j - 1) {
++stkpnt;
stack[(stkpnt << 1) - 2] = start;
stack[(stkpnt << 1) - 1] = j;
++stkpnt;
stack[(stkpnt << 1) - 2] = j + 1;
stack[(stkpnt << 1) - 1] = endd;
} else {
++stkpnt;
stack[(stkpnt << 1) - 2] = j + 1;
stack[(stkpnt << 1) - 1] = endd;
++stkpnt;
stack[(stkpnt << 1) - 2] = start;
stack[(stkpnt << 1) - 1] = j;
}
}
}
if (stkpnt > 0) {
goto L10;
}
return 0;
/* End of DLASRT */
} /* dlasrt_ */
/* dgesvd.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b416
#undef c_b416
#endif
#define c_b416 c_b416
#ifdef c_b438
#undef c_b438
#endif
#define c_b438 c_b438
/* Subroutine */ int dgesvd_(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt,
work, lwork, info, jobu_len, jobvt_len)
char *jobu, *jobvt;
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *s, *u;
integer *ldu;
doublereal *vt;
integer *ldvt;
doublereal *work;
integer *lwork, *info;
ftnlen jobu_len;
ftnlen jobvt_len;
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2],
i__2, i__3, i__4;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat();
double sqrt();
/* Local variables */
static integer iscl;
static doublereal anrm;
static integer ierr, itau, ncvt, nrvt, i__;
extern /* Subroutine */ int dgemm_();
extern logical lsame_();
static integer chunk, minmn, wrkbl, itaup, itauq, mnthr, iwork;
static logical wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs;
static integer ie;
extern /* Subroutine */ int dgebrd_();
extern doublereal dlamch_(), dlange_();
static integer ir, bdspac, iu;
extern /* Subroutine */ int dgelqf_(), dlascl_(), dgeqrf_(), dlacpy_(),
dlaset_(), dbdsqr_(), dorgbr_();
static doublereal bignum;
extern /* Subroutine */ int xerbla_();
extern integer ilaenv_();
extern /* Subroutine */ int dormbr_(), dorglq_(), dorgqr_();
static integer ldwrkr, minwrk, ldwrku, maxwrk;
static doublereal smlnum;
static logical wntuas, wntvas;
static integer blk, ncu;
static doublereal dum[1], eps;
static integer nru;
/* -- LAPACK driver routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGESVD computes the singular value decomposition (SVD) of a real */
/* M-by-N matrix A, optionally computing the left and/or right singular
*/
/* vectors. The SVD is written */
/* A = U * SIGMA * transpose(V) */
/* where SIGMA is an M-by-N matrix which is zero except for its */
/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */
/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */
/* are the singular values of A; they are real and non-negative, and */
/* are returned in descending order. The first min(m,n) columns of */
/* U and V are the left and right singular vectors of A. */
/* Note that the routine returns V**T, not V. */
/* Arguments */
/* ========= */
/* JOBU (input) CHARACTER*1 */
/* Specifies options for computing all or part of the matrix U:
*/
/* = 'A': all M columns of U are returned in array U: */
/* = 'S': the first min(m,n) columns of U (the left singular */
/* vectors) are returned in the array U; */
/* = 'O': the first min(m,n) columns of U (the left singular */
/* vectors) are overwritten on the array A; */
/* = 'N': no columns of U (no left singular vectors) are */
/* computed. */
/* JOBVT (input) CHARACTER*1 */
/* Specifies options for computing all or part of the matrix */
/* V**T: */
/* = 'A': all N rows of V**T are returned in the array VT; */
/* = 'S': the first min(m,n) rows of V**T (the right singular */
/* vectors) are returned in the array VT; */
/* = 'O': the first min(m,n) rows of V**T (the right singular */
/* vectors) are overwritten on the array A; */
/* = 'N': no rows of V**T (no right singular vectors) are */
/* computed. */
/* JOBVT and JOBU cannot both be 'O'. */
/* M (input) INTEGER */
/* The number of rows of the input matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the input matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, */
/* if JOBU = 'O', A is overwritten with the first min(m,n) */
/* columns of U (the left singular vectors, */
/* stored columnwise); */
/* if JOBVT = 'O', A is overwritten with the first min(m,n) */
/* rows of V**T (the right singular vectors, */
/* stored rowwise); */
/* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A */
/* are destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The singular values of A, sorted so that S(i) >= S(i+1). */
/* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL) */
/* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. */
/* If JOBU = 'A', U contains the M-by-M orthogonal matrix U; */
/* if JOBU = 'S', U contains the first min(m,n) columns of U */
/* (the left singular vectors, stored columnwise); */
/* if JOBU = 'N' or 'O', U is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= 1; if */
/* JOBU = 'S' or 'A', LDU >= M. */
/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */
/* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix */
/* V**T; */
/* if JOBVT = 'S', VT contains the first min(m,n) rows of */
/* V**T (the right singular vectors, stored rowwise); */
/* if JOBVT = 'N' or 'O', VT is not referenced. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. LDVT >= 1; if */
/* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK; */
/* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged */
/* superdiagonal elements of an upper bidiagonal matrix B */
/* whose diagonal is in S (not necessarily sorted). B */
/* satisfies A = U * B * VT, so it has the same singular values
*/
/* as A, and singular vectors related by U and VT. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= 1. */
/* LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)-4). */
/* For good performance, LWORK should generally be larger. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if DBDSQR did not converge, INFO specifies how many */
/* superdiagonals of an intermediate bidiagonal form B */
/* did not converge to zero. See the description of WORK */
/* above for details. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--s;
u_dim1 = *ldu;
u_offset = u_dim1 + 1;
u -= u_offset;
vt_dim1 = *ldvt;
vt_offset = vt_dim1 + 1;
vt -= vt_offset;
--work;
/* Function Body */
*info = 0;
minmn = min(*m,*n);
/* Writing concatenation */
i__1[0] = 1, a__1[0] = jobu;
i__1[1] = 1, a__1[1] = jobvt;
s_cat(ch__1, a__1, i__1, &c__2, 2L);
mnthr = ilaenv_(&c__6, "DGESVD", ch__1, m, n, &c__0, &c__0, 6L, 2L);
wntua = lsame_(jobu, "A", 1L, 1L);
wntus = lsame_(jobu, "S", 1L, 1L);
wntuas = wntua || wntus;
wntuo = lsame_(jobu, "O", 1L, 1L);
wntun = lsame_(jobu, "N", 1L, 1L);
wntva = lsame_(jobvt, "A", 1L, 1L);
wntvs = lsame_(jobvt, "S", 1L, 1L);
wntvas = wntva || wntvs;
wntvo = lsame_(jobvt, "O", 1L, 1L);
wntvn = lsame_(jobvt, "N", 1L, 1L);
minwrk = 1;
if (! (wntua || wntus || wntuo || wntun)) {
*info = -1;
} else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -6;
} else if (*ldu < 1 || wntuas && *ldu < *m) {
*info = -9;
} else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) {
*info = -11;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
if (*info == 0 && *lwork >= 1 && *m > 0 && *n > 0) {
if (*m >= *n) {
/* Compute space needed for DBDSQR */
/* Computing MAX */
i__2 = *n * 3, i__3 = *n * 5 - 4;
bdspac = max(i__2,i__3);
if (*m >= mnthr) {
if (wntun) {
/* Path 1 (M much larger than N, JOBU='N')
*/
maxwrk = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = maxwrk, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
"DGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
if (wntvo || wntvas) {
/* Computing MAX */
i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(&
c__1, "DORGBR", "P", n, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
maxwrk = max(maxwrk,bdspac);
/* Computing MAX */
i__2 = *n << 2;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntuo && wntvn) {
/* Path 2 (M much larger than N, JOBU='O',
JOBVT='N') */
wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR",
" ", m, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
"DGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
, "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
/* Computing MAX */
i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n;
maxwrk = max(i__2,i__3);
/* Computing MAX */
i__2 = *n * 3 + *m;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntuo && wntvas) {
/* Path 3 (M much larger than N, JOBU='O',
JOBVT='S' or */
/* 'A') */
wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR",
" ", m, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
"DGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
, "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
"DORGBR", "P", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
/* Computing MAX */
i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n;
maxwrk = max(i__2,i__3);
/* Computing MAX */
i__2 = *n * 3 + *m;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntus && wntvn) {
/* Path 4 (M much larger than N, JOBU='S',
JOBVT='N') */
wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR",
" ", m, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
"DGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
, "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = *n * *n + wrkbl;
/* Computing MAX */
i__2 = *n * 3 + *m;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntus && wntvo) {
/* Path 5 (M much larger than N, JOBU='S',
JOBVT='O') */
wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR",
" ", m, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
"DGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
, "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
"DORGBR", "P", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = (*n << 1) * *n + wrkbl;
/* Computing MAX */
i__2 = *n * 3 + *m;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntus && wntvas) {
/* Path 6 (M much larger than N, JOBU='S',
JOBVT='S' or */
/* 'A') */
wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR",
" ", m, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
"DGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
, "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
"DORGBR", "P", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = *n * *n + wrkbl;
/* Computing MAX */
i__2 = *n * 3 + *m;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntua && wntvn) {
/* Path 7 (M much larger than N, JOBU='A',
JOBVT='N') */
wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR",
" ", m, m, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
"DGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
, "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = *n * *n + wrkbl;
/* Computing MAX */
i__2 = *n * 3 + *m;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntua && wntvo) {
/* Path 8 (M much larger than N, JOBU='A',
JOBVT='O') */
wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR",
" ", m, m, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
"DGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
, "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
"DORGBR", "P", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = (*n << 1) * *n + wrkbl;
/* Computing MAX */
i__2 = *n * 3 + *m;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntua && wntvas) {
/* Path 9 (M much larger than N, JOBU='A',
JOBVT='S' or */
/* 'A') */
wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR",
" ", m, m, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
"DGEBRD", " ", n, n, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
, "Q", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
"DORGBR", "P", n, n, n, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = *n * *n + wrkbl;
/* Computing MAX */
i__2 = *n * 3 + *m;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
}
} else {
/* Path 10 (M at least N, but not much larger) */
maxwrk = *n * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m,
n, &c_n1, &c_n1, 6L, 1L);
if (wntus || wntuo) {
/* Computing MAX */
i__2 = maxwrk, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORG\
BR", "Q", m, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
if (wntua) {
/* Computing MAX */
i__2 = maxwrk, i__3 = *n * 3 + *m * ilaenv_(&c__1, "DORG\
BR", "Q", m, m, n, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
if (! wntvn) {
/* Computing MAX */
i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
"DORGBR", "P", n, n, n, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
maxwrk = max(maxwrk,bdspac);
/* Computing MAX */
i__2 = *n * 3 + *m;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
}
} else {
/* Compute space needed for DBDSQR */
/* Computing MAX */
i__2 = *m * 3, i__3 = *m * 5 - 4;
bdspac = max(i__2,i__3);
if (*n >= mnthr) {
if (wntvn) {
/* Path 1t(N much larger than M, JOBVT='N'
) */
maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = maxwrk, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
"DGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
if (wntuo || wntuas) {
/* Computing MAX */
i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1,
"DORGBR", "Q", m, m, m, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
maxwrk = max(maxwrk,bdspac);
/* Computing MAX */
i__2 = *m << 2;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntvo && wntun) {
/* Path 2t(N much larger than M, JOBU='N',
JOBVT='O') */
wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ",
" ", m, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
"DGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
"DORGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
/* Computing MAX */
i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m;
maxwrk = max(i__2,i__3);
/* Computing MAX */
i__2 = *m * 3 + *n;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntvo && wntuas) {
/* Path 3t(N much larger than M, JOBU='S'
or 'A', */
/* JOBVT='O') */
wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ",
" ", m, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
"DGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
"DORGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR"
, "Q", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
/* Computing MAX */
i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m;
maxwrk = max(i__2,i__3);
/* Computing MAX */
i__2 = *m * 3 + *n;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntvs && wntun) {
/* Path 4t(N much larger than M, JOBU='N',
JOBVT='S') */
wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ",
" ", m, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
"DGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
"DORGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = *m * *m + wrkbl;
/* Computing MAX */
i__2 = *m * 3 + *n;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntvs && wntuo) {
/* Path 5t(N much larger than M, JOBU='O',
JOBVT='S') */
wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ",
" ", m, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
"DGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
"DORGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR"
, "Q", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = (*m << 1) * *m + wrkbl;
/* Computing MAX */
i__2 = *m * 3 + *n;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntvs && wntuas) {
/* Path 6t(N much larger than M, JOBU='S'
or 'A', */
/* JOBVT='S') */
wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ",
" ", m, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
"DGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
"DORGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR"
, "Q", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = *m * *m + wrkbl;
/* Computing MAX */
i__2 = *m * 3 + *n;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntva && wntun) {
/* Path 7t(N much larger than M, JOBU='N',
JOBVT='A') */
wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ",
" ", n, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
"DGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
"DORGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = *m * *m + wrkbl;
/* Computing MAX */
i__2 = *m * 3 + *n;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntva && wntuo) {
/* Path 8t(N much larger than M, JOBU='O',
JOBVT='A') */
wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ",
" ", n, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
"DGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
"DORGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR"
, "Q", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = (*m << 1) * *m + wrkbl;
/* Computing MAX */
i__2 = *m * 3 + *n;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
} else if (wntva && wntuas) {
/* Path 9t(N much larger than M, JOBU='S'
or 'A', */
/* JOBVT='A') */
wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
c_n1, &c_n1, 6L, 1L);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ",
" ", n, n, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
"DGEBRD", " ", m, m, &c_n1, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
"DORGBR", "P", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
/* Computing MAX */
i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR"
, "Q", m, m, m, &c_n1, 6L, 1L);
wrkbl = max(i__2,i__3);
wrkbl = max(wrkbl,bdspac);
maxwrk = *m * *m + wrkbl;
/* Computing MAX */
i__2 = *m * 3 + *n;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
}
} else {
/* Path 10t(N greater than M, but not much larger
) */
maxwrk = *m * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m,
n, &c_n1, &c_n1, 6L, 1L);
if (wntvs || wntvo) {
/* Computing MAX */
i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORG\
BR", "P", m, n, m, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
if (wntva) {
/* Computing MAX */
i__2 = maxwrk, i__3 = *m * 3 + *n * ilaenv_(&c__1, "DORG\
BR", "P", n, n, m, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
if (! wntun) {
/* Computing MAX */
i__2 = maxwrk, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
"DORGBR", "Q", m, m, m, &c_n1, 6L, 1L);
maxwrk = max(i__2,i__3);
}
maxwrk = max(maxwrk,bdspac);
/* Computing MAX */
i__2 = *m * 3 + *n;
minwrk = max(i__2,bdspac);
maxwrk = max(maxwrk,minwrk);
}
}
work[1] = (doublereal) maxwrk;
}
if (*lwork < minwrk) {
*info = -13;
}
if (*info != 0) {
i__2 = -(*info);
xerbla_("DGESVD", &i__2, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
if (*lwork >= 1) {
work[1] = 1.;
}
return 0;
}
/* Get machine constants */
eps = dlamch_("P", 1L);
smlnum = sqrt(dlamch_("S", 1L)) / eps;
bignum = 1. / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", m, n, &a[a_offset], lda, dum, 1L);
iscl = 0;
if (anrm > 0. && anrm < smlnum) {
iscl = 1;
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
ierr, 1L);
} else if (anrm > bignum) {
iscl = 1;
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
ierr, 1L);
}
if (*m >= *n) {
/* A has at least as many rows as columns. If A has sufficientl
y */
/* more rows than columns, first reduce using the QR */
/* decomposition (if sufficient workspace available) */
if (*m >= mnthr) {
if (wntun) {
/* Path 1 (M much larger than N, JOBU='N') */
/* No left singular vectors to be computed */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R */
/* (Workspace: need 2*N, prefer N+N*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
i__2, &ierr);
/* Zero out below R */
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &a[a_dim1 + 2],
lda, 1L);
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in A */
/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[
itauq], &work[itaup], &work[iwork], &i__2, &ierr);
ncvt = 0;
if (wntvo || wntvas) {
/* If right singular vectors desired, gene
rate P'. */
/* (Workspace: need 4*N-1, prefer 3*N+(N-1
)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &
work[iwork], &i__2, &ierr, 1L);
ncvt = *n;
}
iwork = ie + *n;
/* Perform bidiagonal QR iteration, computing rig
ht */
/* singular vectors of A in A if desired */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, &ncvt, &c__0, &c__0, &s[1], &work[ie], &a[
a_offset], lda, dum, &c__1, dum, &c__1, &work[iwork],
info, 1L);
/* If right singular vectors desired in VT, copy
them there */
if (wntvas) {
dlacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
}
} else if (wntuo && wntvn) {
/* Path 2 (M much larger than N, JOBU='O', JOBVT=
'N') */
/* N left singular vectors to be overwritten on A
and */
/* no right singular vectors to be computed */
/* Computing MAX */
i__2 = *n << 2;
if (*lwork >= *n * *n + max(i__2,bdspac)) {
/* Sufficient workspace for a fast algorit
hm */
ir = 1;
/* Computing MAX */
i__2 = wrkbl, i__3 = *lda * *n + *n;
if (*lwork >= max(i__2,i__3) + *lda * *n) {
/* WORK(IU) is LDA by N, WORK(IR) i
s LDA by N */
ldwrku = *lda;
ldwrkr = *lda;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__2 = wrkbl, i__3 = *lda * *n + *n;
if (*lwork >= max(i__2,i__3) + *n * *n) {
/* WORK(IU) is LDA by N, WORK(I
R) is N by N */
ldwrku = *lda;
ldwrkr = *n;
} else {
/* WORK(IU) is LDWRKU by N, WOR
K(IR) is N by N */
ldwrku = (*lwork - *n * *n - *n) / *n;
ldwrkr = *n;
}
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R */
/* (Workspace: need N*N+2*N, prefer N*N+N+
N*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__2, &ierr);
/* Copy R to WORK(IR) and zero out below i
t */
dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr,
1L);
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[ir + 1]
, &ldwrkr, 1L);
/* Generate Q in A */
/* (Workspace: need N*N+2*N, prefer N*N+N+
N*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IR) */
/* (Workspace: need N*N+4*N, prefer N*N+3*
N+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
itauq], &work[itaup], &work[iwork], &i__2, &ierr);
/* Generate left vectors bidiagonalizing R
*/
/* (Workspace: need N*N+4*N, prefer N*N+3*
N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of R in WORK(IR) */
/* (Workspace: need N*N+BDSPAC) */
dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, &
c__1, &work[ir], &ldwrkr, dum, &c__1, &work[iwork]
, info, 1L);
iu = ie + *n;
/* Multiply Q in A by left singular vector
s of R in */
/* WORK(IR), storing result in WORK(IU) an
d copying to A */
/* (Workspace: need N*N+2*N, prefer N*N+M*
N+N) */
i__2 = *m;
i__3 = ldwrku;
for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
i__3) {
/* Computing MIN */
i__4 = *m - i__ + 1;
chunk = min(i__4,ldwrku);
dgemm_("N", "N", &chunk, n, n, &c_b438, &a[i__ +
a_dim1], lda, &work[ir], &ldwrkr, &c_b416, &
work[iu], &ldwrku, 1L, 1L);
dlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
a_dim1], lda, 1L);
/* L10: */
}
} else {
/* Insufficient workspace for a fast algor
ithm */
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize A */
/* (Workspace: need 3*N+M, prefer 3*N+(M+N
)*NB) */
i__3 = *lwork - iwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[
itauq], &work[itaup], &work[iwork], &i__3, &ierr);
/* Generate left vectors bidiagonalizing A
*/
/* (Workspace: need 4*N, prefer 3*N+N*NB)
*/
i__3 = *lwork - iwork + 1;
dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
work[iwork], &i__3, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of A in A */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, &
c__1, &a[a_offset], lda, dum, &c__1, &work[iwork],
info, 1L);
}
} else if (wntuo && wntvas) {
/* Path 3 (M much larger than N, JOBU='O', JOBVT=
'S' or 'A') */
/* N left singular vectors to be overwritten on A
and */
/* N right singular vectors to be computed in VT
*/
/* Computing MAX */
i__3 = *n << 2;
if (*lwork >= *n * *n + max(i__3,bdspac)) {
/* Sufficient workspace for a fast algorit
hm */
ir = 1;
/* Computing MAX */
i__3 = wrkbl, i__2 = *lda * *n + *n;
if (*lwork >= max(i__3,i__2) + *lda * *n) {
/* WORK(IU) is LDA by N and WORK(IR
) is LDA by N */
ldwrku = *lda;
ldwrkr = *lda;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__3 = wrkbl, i__2 = *lda * *n + *n;
if (*lwork >= max(i__3,i__2) + *n * *n) {
/* WORK(IU) is LDA by N and WOR
K(IR) is N by N */
ldwrku = *lda;
ldwrkr = *n;
} else {
/* WORK(IU) is LDWRKU by N and
WORK(IR) is N by N */
ldwrku = (*lwork - *n * *n - *n) / *n;
ldwrkr = *n;
}
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R */
/* (Workspace: need N*N+2*N, prefer N*N+N+
N*NB) */
i__3 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__3, &ierr);
/* Copy R to VT, zeroing out below it */
dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
i__3 = *n - 1;
i__2 = *n - 1;
dlaset_("L", &i__3, &i__2, &c_b416, &c_b416, &vt[vt_dim1
+ 2], ldvt, 1L);
/* Generate Q in A */
/* (Workspace: need N*N+2*N, prefer N*N+N+
N*NB) */
i__3 = *lwork - iwork + 1;
dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__3, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in VT, copying result t
o WORK(IR) */
/* (Workspace: need N*N+4*N, prefer N*N+3*
N+2*N*NB) */
i__3 = *lwork - iwork + 1;
dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &i__3, &
ierr);
dlacpy_("L", n, n, &vt[vt_offset], ldvt, &work[ir], &
ldwrkr, 1L);
/* Generate left vectors bidiagonalizing R
in WORK(IR) */
/* (Workspace: need N*N+4*N, prefer N*N+3*
N+N*NB) */
i__3 = *lwork - iwork + 1;
dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
work[iwork], &i__3, &ierr, 1L);
/* Generate right vectors bidiagonalizing
R in VT */
/* (Workspace: need N*N+4*N-1, prefer N*N+
3*N+(N-1)*NB) */
i__3 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
&work[iwork], &i__3, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of R in WORK(IR) and c
omputing right */
/* singular vectors of R in VT */
/* (Workspace: need N*N+BDSPAC) */
dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &work[ir], &ldwrkr, dum, &c__1,
&work[iwork], info, 1L);
iu = ie + *n;
/* Multiply Q in A by left singular vector
s of R in */
/* WORK(IR), storing result in WORK(IU) an
d copying to A */
/* (Workspace: need N*N+2*N, prefer N*N+M*
N+N) */
i__3 = *m;
i__2 = ldwrku;
for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
i__2) {
/* Computing MIN */
i__4 = *m - i__ + 1;
chunk = min(i__4,ldwrku);
dgemm_("N", "N", &chunk, n, n, &c_b438, &a[i__ +
a_dim1], lda, &work[ir], &ldwrkr, &c_b416, &
work[iu], &ldwrku, 1L, 1L);
dlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
a_dim1], lda, 1L);
/* L20: */
}
} else {
/* Insufficient workspace for a fast algor
ithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R */
/* (Workspace: need 2*N, prefer N+N*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__2, &ierr);
/* Copy R to VT, zeroing out below it */
dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &vt[vt_dim1
+ 2], ldvt, 1L);
/* Generate Q in A */
/* (Workspace: need 2*N, prefer N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in VT */
/* (Workspace: need 4*N, prefer 3*N+2*N*NB
) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &i__2, &
ierr);
/* Multiply Q in A by left vectors bidiago
nalizing R */
/* (Workspace: need 3*N+M, prefer 3*N+M*NB
) */
i__2 = *lwork - iwork + 1;
dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, &
work[itauq], &a[a_offset], lda, &work[iwork], &
i__2, &ierr, 1L, 1L, 1L);
/* Generate right vectors bidiagonalizing
R in VT */
/* (Workspace: need 4*N-1, prefer 3*N+(N-1
)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
&work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of A in A and computin
g right */
/* singular vectors of A in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
work[iwork], info, 1L);
}
} else if (wntus) {
if (wntvn) {
/* Path 4 (M much larger than N, JOBU='S',
JOBVT='N') */
/* N left singular vectors to be computed
in U and */
/* no right singular vectors to be compute
d */
/* Computing MAX */
i__2 = *n << 2;
if (*lwork >= *n * *n + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
ir = 1;
if (*lwork >= wrkbl + *lda * *n) {
/* WORK(IR) is LDA by N */
ldwrkr = *lda;
} else {
/* WORK(IR) is N by N */
ldwrkr = *n;
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R */
/* (Workspace: need N*N+2*N, prefer
N*N+N+N*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy R to WORK(IR), zeroing out
below it */
dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
ldwrkr, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[ir
+ 1], &ldwrkr, 1L);
/* Generate Q in A */
/* (Workspace: need N*N+2*N, prefer
N*N+N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IR) */
/* (Workspace: need N*N+4*N, prefer
N*N+3*N+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Generate left vectors bidiagonal
izing R in WORK(IR) */
/* (Workspace: need N*N+4*N, prefer
N*N+3*N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IR
) */
/* (Workspace: need N*N+BDSPAC) */
dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie],
dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, &
work[iwork], info, 1L);
/* Multiply Q in A by left singular
vectors of R in */
/* WORK(IR), storing result in U */
/* (Workspace: need N*N) */
dgemm_("N", "N", m, n, n, &c_b438, &a[a_offset], lda,
&work[ir], &ldwrkr, &c_b416, &u[u_offset],
ldu, 1L, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (Workspace: need 2*N, prefer N+N
*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (Workspace: need 2*N, prefer N+N
*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Zero out below R in A */
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &a[
a_dim1 + 2], lda, 1L);
/* Bidiagonalize R in A */
/* (Workspace: need 4*N, prefer 3*N
+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left vectors
bidiagonalizing R */
/* (Workspace: need 3*N+M, prefer 3
*N+M*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie],
dum, &c__1, &u[u_offset], ldu, dum, &c__1, &
work[iwork], info, 1L);
}
} else if (wntvo) {
/* Path 5 (M much larger than N, JOBU='S',
JOBVT='O') */
/* N left singular vectors to be computed
in U and */
/* N right singular vectors to be overwrit
ten on A */
/* Computing MAX */
i__2 = *n << 2;
if (*lwork >= (*n << 1) * *n + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + (*lda << 1) * *n) {
/* WORK(IU) is LDA by N and
WORK(IR) is LDA by N */
ldwrku = *lda;
ir = iu + ldwrku * *n;
ldwrkr = *lda;
} else if (*lwork >= wrkbl + (*lda + *n) * *n) {
/* WORK(IU) is LDA by N and
WORK(IR) is N by N */
ldwrku = *lda;
ir = iu + ldwrku * *n;
ldwrkr = *n;
} else {
/* WORK(IU) is N by N and WO
RK(IR) is N by N */
ldwrku = *n;
ir = iu + ldwrku * *n;
ldwrkr = *n;
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R */
/* (Workspace: need 2*N*N+2*N, pref
er 2*N*N+N+N*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy R to WORK(IU), zeroing out
below it */
dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[iu
+ 1], &ldwrku, 1L);
/* Generate Q in A */
/* (Workspace: need 2*N*N+2*N, pref
er 2*N*N+N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IU), cop
ying result to */
/* WORK(IR) */
/* (Workspace: need 2*N*N+4*N, */
/* prefer 2*N*N+3*N+2*N
*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
dlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
ldwrkr, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IU) */
/* (Workspace: need 2*N*N+4*N, pref
er 2*N*N+3*N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IR) */
/* (Workspace: need 2*N*N+4*N-1, */
/* prefer 2*N*N+3*N+(N-
1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IU
) and computing */
/* right singular vectors of R in W
ORK(IR) */
/* (Workspace: need 2*N*N+BDSPAC)
*/
dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[
ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1,
&work[iwork], info, 1L);
/* Multiply Q in A by left singular
vectors of R in */
/* WORK(IU), storing result in U */
/* (Workspace: need N*N) */
dgemm_("N", "N", m, n, n, &c_b438, &a[a_offset], lda,
&work[iu], &ldwrku, &c_b416, &u[u_offset],
ldu, 1L, 1L);
/* Copy right singular vectors of R
to A */
/* (Workspace: need N*N) */
dlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
lda, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (Workspace: need 2*N, prefer N+N
*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (Workspace: need 2*N, prefer N+N
*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Zero out below R in A */
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &a[
a_dim1 + 2], lda, 1L);
/* Bidiagonalize R in A */
/* (Workspace: need 4*N, prefer 3*N
+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left vectors
bidiagonalizing R */
/* (Workspace: need 3*N+M, prefer 3
*N+M*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
/* Generate right vectors bidiagona
lizing R in A */
/* (Workspace: need 4*N-1, prefer 3
*N+(N-1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
&work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in A */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[
a_offset], lda, &u[u_offset], ldu, dum, &c__1,
&work[iwork], info, 1L);
}
} else if (wntvas) {
/* Path 6 (M much larger than N, JOBU='S',
JOBVT='S' */
/* or 'A') */
/* N left singular vectors to be computed
in U and */
/* N right singular vectors to be computed
in VT */
/* Computing MAX */
i__2 = *n << 2;
if (*lwork >= *n * *n + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + *lda * *n) {
/* WORK(IU) is LDA by N */
ldwrku = *lda;
} else {
/* WORK(IU) is N by N */
ldwrku = *n;
}
itau = iu + ldwrku * *n;
iwork = itau + *n;
/* Compute A=Q*R */
/* (Workspace: need N*N+2*N, prefer
N*N+N+N*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy R to WORK(IU), zeroing out
below it */
dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[iu
+ 1], &ldwrku, 1L);
/* Generate Q in A */
/* (Workspace: need N*N+2*N, prefer
N*N+N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IU), cop
ying result to VT */
/* (Workspace: need N*N+4*N, prefer
N*N+3*N+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
dlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
ldvt, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IU) */
/* (Workspace: need N*N+4*N, prefer
N*N+3*N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate right bidiagonalizing v
ectors in VT */
/* (Workspace: need N*N+4*N-1, */
/* prefer N*N+3*N+(N-1)
*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
itaup], &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IU
) and computing */
/* right singular vectors of R in V
T */
/* (Workspace: need N*N+BDSPAC) */
dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &work[iu], &ldwrku, dum, &
c__1, &work[iwork], info, 1L);
/* Multiply Q in A by left singular
vectors of R in */
/* WORK(IU), storing result in U */
/* (Workspace: need N*N) */
dgemm_("N", "N", m, n, n, &c_b438, &a[a_offset], lda,
&work[iu], &ldwrku, &c_b416, &u[u_offset],
ldu, 1L, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (Workspace: need 2*N, prefer N+N
*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (Workspace: need 2*N, prefer N+N
*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy R to VT, zeroing out below
it */
dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &vt[
vt_dim1 + 2], ldvt, 1L);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in VT */
/* (Workspace: need 4*N, prefer 3*N
+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie],
&work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left bidiagon
alizing vectors */
/* in VT */
/* (Workspace: need 3*N+M, prefer 3
*N+M*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
&work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
/* Generate right bidiagonalizing v
ectors in VT */
/* (Workspace: need 4*N-1, prefer 3
*N+(N-1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
itaup], &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, dum, &
c__1, &work[iwork], info, 1L);
}
}
} else if (wntua) {
if (wntvn) {
/* Path 7 (M much larger than N, JOBU='A',
JOBVT='N') */
/* M left singular vectors to be computed
in U and */
/* no right singular vectors to be compute
d */
/* Computing MAX */
i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3);
if (*lwork >= *n * *n + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
ir = 1;
if (*lwork >= wrkbl + *lda * *n) {
/* WORK(IR) is LDA by N */
ldwrkr = *lda;
} else {
/* WORK(IR) is N by N */
ldwrkr = *n;
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (Workspace: need N*N+2*N, prefer
N*N+N+N*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Copy R to WORK(IR), zeroing out
below it */
dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
ldwrkr, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[ir
+ 1], &ldwrkr, 1L);
/* Generate Q in U */
/* (Workspace: need N*N+N+M, prefer
N*N+N+M*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IR) */
/* (Workspace: need N*N+4*N, prefer
N*N+3*N+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Generate left bidiagonalizing ve
ctors in WORK(IR) */
/* (Workspace: need N*N+4*N, prefer
N*N+3*N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IR
) */
/* (Workspace: need N*N+BDSPAC) */
dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie],
dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, &
work[iwork], info, 1L);
/* Multiply Q in U by left singular
vectors of R in */
/* WORK(IR), storing result in A */
/* (Workspace: need N*N) */
dgemm_("N", "N", m, n, n, &c_b438, &u[u_offset], ldu,
&work[ir], &ldwrkr, &c_b416, &a[a_offset],
lda, 1L, 1L);
/* Copy left singular vectors of A
from A to U */
dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (Workspace: need 2*N, prefer N+N
*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (Workspace: need N+M, prefer N+M
*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Zero out below R in A */
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &a[
a_dim1 + 2], lda, 1L);
/* Bidiagonalize R in A */
/* (Workspace: need 4*N, prefer 3*N
+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left bidiagon
alizing vectors */
/* in A */
/* (Workspace: need 3*N+M, prefer 3
*N+M*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie],
dum, &c__1, &u[u_offset], ldu, dum, &c__1, &
work[iwork], info, 1L);
}
} else if (wntvo) {
/* Path 8 (M much larger than N, JOBU='A',
JOBVT='O') */
/* M left singular vectors to be computed
in U and */
/* N right singular vectors to be overwrit
ten on A */
/* Computing MAX */
i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3);
if (*lwork >= (*n << 1) * *n + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + (*lda << 1) * *n) {
/* WORK(IU) is LDA by N and
WORK(IR) is LDA by N */
ldwrku = *lda;
ir = iu + ldwrku * *n;
ldwrkr = *lda;
} else if (*lwork >= wrkbl + (*lda + *n) * *n) {
/* WORK(IU) is LDA by N and
WORK(IR) is N by N */
ldwrku = *lda;
ir = iu + ldwrku * *n;
ldwrkr = *n;
} else {
/* WORK(IU) is N by N and WO
RK(IR) is N by N */
ldwrku = *n;
ir = iu + ldwrku * *n;
ldwrkr = *n;
}
itau = ir + ldwrkr * *n;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (Workspace: need 2*N*N+2*N, pref
er 2*N*N+N+N*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (Workspace: need 2*N*N+N+M, pref
er 2*N*N+N+M*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy R to WORK(IU), zeroing out
below it */
dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[iu
+ 1], &ldwrku, 1L);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IU), cop
ying result to */
/* WORK(IR) */
/* (Workspace: need 2*N*N+4*N, */
/* prefer 2*N*N+3*N+2*N
*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
dlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
ldwrkr, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IU) */
/* (Workspace: need 2*N*N+4*N, pref
er 2*N*N+3*N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IR) */
/* (Workspace: need 2*N*N+4*N-1, */
/* prefer 2*N*N+3*N+(N-
1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IU
) and computing */
/* right singular vectors of R in W
ORK(IR) */
/* (Workspace: need 2*N*N+BDSPAC)
*/
dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[
ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1,
&work[iwork], info, 1L);
/* Multiply Q in U by left singular
vectors of R in */
/* WORK(IU), storing result in A */
/* (Workspace: need N*N) */
dgemm_("N", "N", m, n, n, &c_b438, &u[u_offset], ldu,
&work[iu], &ldwrku, &c_b416, &a[a_offset],
lda, 1L, 1L);
/* Copy left singular vectors of A
from A to U */
dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Copy right singular vectors of R
from WORK(IR) to A */
dlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
lda, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (Workspace: need 2*N, prefer N+N
*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (Workspace: need N+M, prefer N+M
*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Zero out below R in A */
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &a[
a_dim1 + 2], lda, 1L);
/* Bidiagonalize R in A */
/* (Workspace: need 4*N, prefer 3*N
+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left bidiagon
alizing vectors */
/* in A */
/* (Workspace: need 3*N+M, prefer 3
*N+M*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
/* Generate right bidiagonalizing v
ectors in A */
/* (Workspace: need 4*N-1, prefer 3
*N+(N-1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
&work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in A */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[
a_offset], lda, &u[u_offset], ldu, dum, &c__1,
&work[iwork], info, 1L);
}
} else if (wntvas) {
/* Path 9 (M much larger than N, JOBU='A',
JOBVT='S' */
/* or 'A') */
/* M left singular vectors to be computed
in U and */
/* N right singular vectors to be computed
in VT */
/* Computing MAX */
i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3);
if (*lwork >= *n * *n + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + *lda * *n) {
/* WORK(IU) is LDA by N */
ldwrku = *lda;
} else {
/* WORK(IU) is N by N */
ldwrku = *n;
}
itau = iu + ldwrku * *n;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (Workspace: need N*N+2*N, prefer
N*N+N+N*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (Workspace: need N*N+N+M, prefer
N*N+N+M*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy R to WORK(IU), zeroing out
below it */
dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &work[iu
+ 1], &ldwrku, 1L);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in WORK(IU), cop
ying result to VT */
/* (Workspace: need N*N+4*N, prefer
N*N+3*N+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
dlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
ldvt, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IU) */
/* (Workspace: need N*N+4*N, prefer
N*N+3*N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate right bidiagonalizing v
ectors in VT */
/* (Workspace: need N*N+4*N-1, */
/* prefer N*N+3*N+(N-1)
*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
itaup], &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of R in WORK(IU
) and computing */
/* right singular vectors of R in V
T */
/* (Workspace: need N*N+BDSPAC) */
dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &work[iu], &ldwrku, dum, &
c__1, &work[iwork], info, 1L);
/* Multiply Q in U by left singular
vectors of R in */
/* WORK(IU), storing result in A */
/* (Workspace: need N*N) */
dgemm_("N", "N", m, n, n, &c_b438, &u[u_offset], ldu,
&work[iu], &ldwrku, &c_b416, &a[a_offset],
lda, 1L, 1L);
/* Copy left singular vectors of A
from A to U */
dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *n;
/* Compute A=Q*R, copying result to
U */
/* (Workspace: need 2*N, prefer N+N
*NB) */
i__2 = *lwork - iwork + 1;
dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
/* Generate Q in U */
/* (Workspace: need N+M, prefer N+M
*NB) */
i__2 = *lwork - iwork + 1;
dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy R from A to VT, zeroing out
below it */
dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
i__2 = *n - 1;
i__3 = *n - 1;
dlaset_("L", &i__2, &i__3, &c_b416, &c_b416, &vt[
vt_dim1 + 2], ldvt, 1L);
ie = itau;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize R in VT */
/* (Workspace: need 4*N, prefer 3*N
+2*N*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie],
&work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply Q in U by left bidiagon
alizing vectors */
/* in VT */
/* (Workspace: need 3*N+M, prefer 3
*N+M*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
&work[itauq], &u[u_offset], ldu, &work[iwork],
&i__2, &ierr, 1L, 1L, 1L);
/* Generate right bidiagonalizing v
ectors in VT */
/* (Workspace: need 4*N-1, prefer 3
*N+(N-1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
itaup], &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *n;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, dum, &
c__1, &work[iwork], info, 1L);
}
}
}
} else {
/* M .LT. MNTHR */
/* Path 10 (M at least N, but not much larger) */
/* Reduce to bidiagonal form without QR decomposition */
ie = 1;
itauq = ie + *n;
itaup = itauq + *n;
iwork = itaup + *n;
/* Bidiagonalize A */
/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[iwork], &i__2, &ierr);
if (wntuas) {
/* If left singular vectors desired in U, copy re
sult to U */
/* and generate left bidiagonalizing vectors in U
*/
/* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB)
*/
dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu, 1L);
if (wntus) {
ncu = *n;
}
if (wntua) {
ncu = *m;
}
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], &
work[iwork], &i__2, &ierr, 1L);
}
if (wntvas) {
/* If right singular vectors desired in VT, copy
result to */
/* VT and generate right bidiagonalizing vectors
in VT */
/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*/
dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt,
1L);
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
work[iwork], &i__2, &ierr, 1L);
}
if (wntuo) {
/* If left singular vectors desired in A, generat
e left */
/* bidiagonalizing vectors in A */
/* (Workspace: need 4*N, prefer 3*N+N*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[
iwork], &i__2, &ierr, 1L);
}
if (wntvo) {
/* If right singular vectors desired in A, genera
te right */
/* bidiagonalizing vectors in A */
/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
*/
i__2 = *lwork - iwork + 1;
dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[
iwork], &i__2, &ierr, 1L);
}
iwork = ie + *n;
if (wntuas || wntuo) {
nru = *m;
}
if (wntun) {
nru = 0;
}
if (wntvas || wntvo) {
ncvt = *n;
}
if (wntvn) {
ncvt = 0;
}
if (! wntuo && ! wntvo) {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in U and computing right
singular */
/* vectors in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, &
work[iwork], info, 1L);
} else if (! wntuo && wntvo) {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in U and computing right
singular */
/* vectors in A */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[
a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[
iwork], info, 1L);
} else {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in A and computing right
singular */
/* vectors in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
work[iwork], info, 1L);
}
}
} else {
/* A has more columns than rows. If A has sufficiently more */
/* columns than rows, first reduce using the LQ decomposition (
if */
/* sufficient workspace available) */
if (*n >= mnthr) {
if (wntvn) {
/* Path 1t(N much larger than M, JOBVT='N') */
/* No right singular vectors to be computed */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q */
/* (Workspace: need 2*M, prefer M+M*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
i__2, &ierr);
/* Zero out above L */
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &a[(a_dim1 << 1)
+ 1], lda, 1L);
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in A */
/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[
itauq], &work[itaup], &work[iwork], &i__2, &ierr);
if (wntuo || wntuas) {
/* If left singular vectors desired, gener
ate Q */
/* (Workspace: need 4*M, prefer 3*M+M*NB)
*/
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], &
work[iwork], &i__2, &ierr, 1L);
}
iwork = ie + *m;
nru = 0;
if (wntuo || wntuas) {
nru = *m;
}
/* Perform bidiagonal QR iteration, computing lef
t singular */
/* vectors of A in A if desired */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", m, &c__0, &nru, &c__0, &s[1], &work[ie], dum, &
c__1, &a[a_offset], lda, dum, &c__1, &work[iwork],
info, 1L);
/* If left singular vectors desired in U, copy th
em there */
if (wntuas) {
dlacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu,
1L);
}
} else if (wntvo && wntun) {
/* Path 2t(N much larger than M, JOBU='N', JOBVT=
'O') */
/* M right singular vectors to be overwritten on
A and */
/* no left singular vectors to be computed */
/* Computing MAX */
i__2 = *m << 2;
if (*lwork >= *m * *m + max(i__2,bdspac)) {
/* Sufficient workspace for a fast algorit
hm */
ir = 1;
/* Computing MAX */
i__2 = wrkbl, i__3 = *lda * *n + *m;
if (*lwork >= max(i__2,i__3) + *lda * *m) {
/* WORK(IU) is LDA by N and WORK(IR
) is LDA by M */
ldwrku = *lda;
chunk = *n;
ldwrkr = *lda;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__2 = wrkbl, i__3 = *lda * *n + *m;
if (*lwork >= max(i__2,i__3) + *m * *m) {
/* WORK(IU) is LDA by N and WOR
K(IR) is M by M */
ldwrku = *lda;
chunk = *n;
ldwrkr = *m;
} else {
/* WORK(IU) is M by CHUNK and W
ORK(IR) is M by M */
ldwrku = *m;
chunk = (*lwork - *m * *m - *m) / *m;
ldwrkr = *m;
}
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q */
/* (Workspace: need M*M+2*M, prefer M*M+M+
M*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__2, &ierr);
/* Copy L to WORK(IR) and zero out above i
t */
dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr,
1L);
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[ir +
ldwrkr], &ldwrkr, 1L);
/* Generate Q in A */
/* (Workspace: need M*M+2*M, prefer M*M+M+
M*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IR) */
/* (Workspace: need M*M+4*M, prefer M*M+3*
M+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
itauq], &work[itaup], &work[iwork], &i__2, &ierr);
/* Generate right vectors bidiagonalizing
L */
/* (Workspace: need M*M+4*M-1, prefer M*M+
3*M+(M-1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration, comput
ing right */
/* singular vectors of L in WORK(IR) */
/* (Workspace: need M*M+BDSPAC) */
dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[
ir], &ldwrkr, dum, &c__1, dum, &c__1, &work[iwork]
, info, 1L);
iu = ie + *m;
/* Multiply right singular vectors of L in
WORK(IR) by Q */
/* in A, storing result in WORK(IU) and co
pying to A */
/* (Workspace: need M*M+2*M, prefer M*M+M*
N+M) */
i__2 = *n;
i__3 = chunk;
for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
i__3) {
/* Computing MIN */
i__4 = *n - i__ + 1;
blk = min(i__4,chunk);
dgemm_("N", "N", m, &blk, m, &c_b438, &work[ir], &
ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b416, &
work[iu], &ldwrku, 1L, 1L);
dlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
a_dim1 + 1], lda, 1L);
/* L30: */
}
} else {
/* Insufficient workspace for a fast algor
ithm */
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize A */
/* (Workspace: need 3*M+N, prefer 3*M+(M+N
)*NB) */
i__3 = *lwork - iwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[
itauq], &work[itaup], &work[iwork], &i__3, &ierr);
/* Generate right vectors bidiagonalizing
A */
/* (Workspace: need 4*M, prefer 3*M+M*NB)
*/
i__3 = *lwork - iwork + 1;
dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
work[iwork], &i__3, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration, comput
ing right */
/* singular vectors of A in A */
/* (Workspace: need BDSPAC) */
dbdsqr_("L", m, n, &c__0, &c__0, &s[1], &work[ie], &a[
a_offset], lda, dum, &c__1, dum, &c__1, &work[
iwork], info, 1L);
}
} else if (wntvo && wntuas) {
/* Path 3t(N much larger than M, JOBU='S' or 'A',
JOBVT='O') */
/* M right singular vectors to be overwritten on
A and */
/* M left singular vectors to be computed in U */
/* Computing MAX */
i__3 = *m << 2;
if (*lwork >= *m * *m + max(i__3,bdspac)) {
/* Sufficient workspace for a fast algorit
hm */
ir = 1;
/* Computing MAX */
i__3 = wrkbl, i__2 = *lda * *n + *m;
if (*lwork >= max(i__3,i__2) + *lda * *m) {
/* WORK(IU) is LDA by N and WORK(IR
) is LDA by M */
ldwrku = *lda;
chunk = *n;
ldwrkr = *lda;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__3 = wrkbl, i__2 = *lda * *n + *m;
if (*lwork >= max(i__3,i__2) + *m * *m) {
/* WORK(IU) is LDA by N and WOR
K(IR) is M by M */
ldwrku = *lda;
chunk = *n;
ldwrkr = *m;
} else {
/* WORK(IU) is M by CHUNK and W
ORK(IR) is M by M */
ldwrku = *m;
chunk = (*lwork - *m * *m - *m) / *m;
ldwrkr = *m;
}
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q */
/* (Workspace: need M*M+2*M, prefer M*M+M+
M*NB) */
i__3 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__3, &ierr);
/* Copy L to U, zeroing about above it */
dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu,
1L);
i__3 = *m - 1;
i__2 = *m - 1;
dlaset_("U", &i__3, &i__2, &c_b416, &c_b416, &u[(u_dim1 <<
1) + 1], ldu, 1L);
/* Generate Q in A */
/* (Workspace: need M*M+2*M, prefer M*M+M+
M*NB) */
i__3 = *lwork - iwork + 1;
dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
iwork], &i__3, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in U, copying result to
WORK(IR) */
/* (Workspace: need M*M+4*M, prefer M*M+3*
M+2*M*NB) */
i__3 = *lwork - iwork + 1;
dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[
itauq], &work[itaup], &work[iwork], &i__3, &ierr);
dlacpy_("U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr,
1L);
/* Generate right vectors bidiagonalizing
L in WORK(IR) */
/* (Workspace: need M*M+4*M-1, prefer M*M+
3*M+(M-1)*NB) */
i__3 = *lwork - iwork + 1;
dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
work[iwork], &i__3, &ierr, 1L);
/* Generate left vectors bidiagonalizing L
in U */
/* (Workspace: need M*M+4*M, prefer M*M+3*
M+M*NB) */
i__3 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
work[iwork], &i__3, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of L in U, and computi
ng right */
/* singular vectors of L in WORK(IR) */
/* (Workspace: need M*M+BDSPAC) */
dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ir],
&ldwrkr, &u[u_offset], ldu, dum, &c__1, &work[
iwork], info, 1L);
iu = ie + *m;
/* Multiply right singular vectors of L in
WORK(IR) by Q */
/* in A, storing result in WORK(IU) and co
pying to A */
/* (Workspace: need M*M+2*M, prefer M*M+M*
N+M)) */
i__3 = *n;
i__2 = chunk;
for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
i__2) {
/* Computing MIN */
i__4 = *n - i__ + 1;
blk = min(i__4,chunk);
dgemm_("N", "N", m, &blk, m, &c_b438, &work[ir], &
ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b416, &
work[iu], &ldwrku, 1L, 1L);
dlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
a_dim1 + 1], lda, 1L);
/* L40: */
}
} else {
/* Insufficient workspace for a fast algor
ithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q */
/* (Workspace: need 2*M, prefer M+M*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
, &i__2, &ierr);
/* Copy L to U, zeroing out above it */
dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu,
1L);
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &u[(u_dim1 <<
1) + 1], ldu, 1L);
/* Generate Q in A */
/* (Workspace: need 2*M, prefer M+M*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in U */
/* (Workspace: need 4*M, prefer 3*M+2*M*NB
) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[
itauq], &work[itaup], &work[iwork], &i__2, &ierr);
/* Multiply right vectors bidiagonalizing
L by Q in A */
/* (Workspace: need 3*M+N, prefer 3*M+N*NB
) */
i__2 = *lwork - iwork + 1;
dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &work[
itaup], &a[a_offset], lda, &work[iwork], &i__2, &
ierr, 1L, 1L, 1L);
/* Generate left vectors bidiagonalizing L
in U */
/* (Workspace: need 4*M, prefer 3*M+M*NB)
*/
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration, comput
ing left */
/* singular vectors of A in U and computin
g right */
/* singular vectors of A in A */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &a[
a_offset], lda, &u[u_offset], ldu, dum, &c__1, &
work[iwork], info, 1L);
}
} else if (wntvs) {
if (wntun) {
/* Path 4t(N much larger than M, JOBU='N',
JOBVT='S') */
/* M right singular vectors to be computed
in VT and */
/* no left singular vectors to be computed
*/
/* Computing MAX */
i__2 = *m << 2;
if (*lwork >= *m * *m + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
ir = 1;
if (*lwork >= wrkbl + *lda * *m) {
/* WORK(IR) is LDA by M */
ldwrkr = *lda;
} else {
/* WORK(IR) is M by M */
ldwrkr = *m;
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q */
/* (Workspace: need M*M+2*M, prefer
M*M+M+M*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy L to WORK(IR), zeroing out
above it */
dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
ldwrkr, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[ir
+ ldwrkr], &ldwrkr, 1L);
/* Generate Q in A */
/* (Workspace: need M*M+2*M, prefer
M*M+M+M*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IR) */
/* (Workspace: need M*M+4*M, prefer
M*M+3*M+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Generate right vectors bidiagona
lizing L in */
/* WORK(IR) */
/* (Workspace: need M*M+4*M, prefer
M*M+3*M+(M-1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right */
/* singular vectors of L in WORK(IR
) */
/* (Workspace: need M*M+BDSPAC) */
dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &
work[ir], &ldwrkr, dum, &c__1, dum, &c__1, &
work[iwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IR) by */
/* Q in A, storing result in VT */
/* (Workspace: need M*M) */
dgemm_("N", "N", m, n, m, &c_b438, &work[ir], &ldwrkr,
&a[a_offset], lda, &c_b416, &vt[vt_offset],
ldvt, 1L, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q */
/* (Workspace: need 2*M, prefer M+M
*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy result to VT */
dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (Workspace: need 2*M, prefer M+M
*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Zero out above L in A */
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &a[(
a_dim1 << 1) + 1], lda, 1L);
/* Bidiagonalize L in A */
/* (Workspace: need 4*M, prefer 3*M
+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right vectors bidiagona
lizing L by Q in VT */
/* (Workspace: need 3*M+N, prefer 3
*M+N*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right */
/* singular vectors of A in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], &
vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, &
work[iwork], info, 1L);
}
} else if (wntuo) {
/* Path 5t(N much larger than M, JOBU='O',
JOBVT='S') */
/* M right singular vectors to be computed
in VT and */
/* M left singular vectors to be overwritt
en on A */
/* Computing MAX */
i__2 = *m << 2;
if (*lwork >= (*m << 1) * *m + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + (*lda << 1) * *m) {
/* WORK(IU) is LDA by M and
WORK(IR) is LDA by M */
ldwrku = *lda;
ir = iu + ldwrku * *m;
ldwrkr = *lda;
} else if (*lwork >= wrkbl + (*lda + *m) * *m) {
/* WORK(IU) is LDA by M and
WORK(IR) is M by M */
ldwrku = *lda;
ir = iu + ldwrku * *m;
ldwrkr = *m;
} else {
/* WORK(IU) is M by M and WO
RK(IR) is M by M */
ldwrku = *m;
ir = iu + ldwrku * *m;
ldwrkr = *m;
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q */
/* (Workspace: need 2*M*M+2*M, pref
er 2*M*M+M+M*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy L to WORK(IU), zeroing out
below it */
dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[iu
+ ldwrku], &ldwrku, 1L);
/* Generate Q in A */
/* (Workspace: need 2*M*M+2*M, pref
er 2*M*M+M+M*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IU), cop
ying result to */
/* WORK(IR) */
/* (Workspace: need 2*M*M+4*M, */
/* prefer 2*M*M+3*M+2*M
*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
dlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
ldwrkr, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IU) */
/* (Workspace: need 2*M*M+4*M-1, */
/* prefer 2*M*M+3*M+(M-
1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IR) */
/* (Workspace: need 2*M*M+4*M, pref
er 2*M*M+3*M+M*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of L in WORK(IR
) and computing */
/* right singular vectors of L in W
ORK(IU) */
/* (Workspace: need 2*M*M+BDSPAC)
*/
dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1,
&work[iwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IU) by */
/* Q in A, storing result in VT */
/* (Workspace: need M*M) */
dgemm_("N", "N", m, n, m, &c_b438, &work[iu], &ldwrku,
&a[a_offset], lda, &c_b416, &vt[vt_offset],
ldvt, 1L, 1L);
/* Copy left singular vectors of L
to A */
/* (Workspace: need M*M) */
dlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
lda, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (Workspace: need 2*M, prefer M+M
*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (Workspace: need 2*M, prefer M+M
*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Zero out above L in A */
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &a[(
a_dim1 << 1) + 1], lda, 1L);
/* Bidiagonalize L in A */
/* (Workspace: need 4*M, prefer 3*M
+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right vectors bidiagona
lizing L by Q in VT */
/* (Workspace: need 3*M+N, prefer 3
*M+N*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
/* Generate left bidiagonalizing ve
ctors of L in A */
/* (Workspace: need 4*M, prefer 3*M
+M*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
compute left */
/* singular vectors of A in A and c
ompute right */
/* singular vectors of A in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &a[a_offset], lda, dum, &
c__1, &work[iwork], info, 1L);
}
} else if (wntuas) {
/* Path 6t(N much larger than M, JOBU='S'
or 'A', */
/* JOBVT='S') */
/* M right singular vectors to be computed
in VT and */
/* M left singular vectors to be computed
in U */
/* Computing MAX */
i__2 = *m << 2;
if (*lwork >= *m * *m + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + *lda * *m) {
/* WORK(IU) is LDA by N */
ldwrku = *lda;
} else {
/* WORK(IU) is LDA by M */
ldwrku = *m;
}
itau = iu + ldwrku * *m;
iwork = itau + *m;
/* Compute A=L*Q */
/* (Workspace: need M*M+2*M, prefer
M*M+M+M*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
/* Copy L to WORK(IU), zeroing out
above it */
dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[iu
+ ldwrku], &ldwrku, 1L);
/* Generate Q in A */
/* (Workspace: need M*M+2*M, prefer
M*M+M+M*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IU), cop
ying result to U */
/* (Workspace: need M*M+4*M, prefer
M*M+3*M+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
dlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
ldu, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IU) */
/* (Workspace: need M*M+4*M-1, */
/* prefer M*M+3*M+(M-1)
*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate left bidiagonalizing ve
ctors in U */
/* (Workspace: need M*M+4*M, prefer
M*M+3*M+M*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of L in U and c
omputing right */
/* singular vectors of L in WORK(IU
) */
/* (Workspace: need M*M+BDSPAC) */
dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, &
work[iwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IU) by */
/* Q in A, storing result in VT */
/* (Workspace: need M*M) */
dgemm_("N", "N", m, n, m, &c_b438, &work[iu], &ldwrku,
&a[a_offset], lda, &c_b416, &vt[vt_offset],
ldvt, 1L, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (Workspace: need 2*M, prefer M+M
*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (Workspace: need 2*M, prefer M+M
*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy L to U, zeroing out above i
t */
dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &u[(
u_dim1 << 1) + 1], ldu, 1L);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in U */
/* (Workspace: need 4*M, prefer 3*M
+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right bidiagonalizing v
ectors in U by Q */
/* in VT */
/* (Workspace: need 3*M+N, prefer 3
*M+N*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
/* Generate left bidiagonalizing ve
ctors in U */
/* (Workspace: need 4*M, prefer 3*M
+M*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, dum, &
c__1, &work[iwork], info, 1L);
}
}
} else if (wntva) {
if (wntun) {
/* Path 7t(N much larger than M, JOBU='N',
JOBVT='A') */
/* N right singular vectors to be computed
in VT and */
/* no left singular vectors to be computed
*/
/* Computing MAX */
i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3);
if (*lwork >= *m * *m + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
ir = 1;
if (*lwork >= wrkbl + *lda * *m) {
/* WORK(IR) is LDA by M */
ldwrkr = *lda;
} else {
/* WORK(IR) is M by M */
ldwrkr = *m;
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (Workspace: need M*M+2*M, prefer
M*M+M+M*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Copy L to WORK(IR), zeroing out
above it */
dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
ldwrkr, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[ir
+ ldwrkr], &ldwrkr, 1L);
/* Generate Q in VT */
/* (Workspace: need M*M+M+N, prefer
M*M+M+N*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IR) */
/* (Workspace: need M*M+4*M, prefer
M*M+3*M+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Generate right bidiagonalizing v
ectors in WORK(IR) */
/* (Workspace: need M*M+4*M-1, */
/* prefer M*M+3*M+(M-1)
*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right */
/* singular vectors of L in WORK(IR
) */
/* (Workspace: need M*M+BDSPAC) */
dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &
work[ir], &ldwrkr, dum, &c__1, dum, &c__1, &
work[iwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IR) by */
/* Q in VT, storing result in A */
/* (Workspace: need M*M) */
dgemm_("N", "N", m, n, m, &c_b438, &work[ir], &ldwrkr,
&vt[vt_offset], ldvt, &c_b416, &a[a_offset],
lda, 1L, 1L);
/* Copy right singular vectors of A
from A to VT */
dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (Workspace: need 2*M, prefer M+M
*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (Workspace: need M+N, prefer M+N
*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Zero out above L in A */
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &a[(
a_dim1 << 1) + 1], lda, 1L);
/* Bidiagonalize L in A */
/* (Workspace: need 4*M, prefer 3*M
+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right bidiagonalizing v
ectors in A by Q */
/* in VT */
/* (Workspace: need 3*M+N, prefer 3
*M+N*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing right */
/* singular vectors of A in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], &
vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, &
work[iwork], info, 1L);
}
} else if (wntuo) {
/* Path 8t(N much larger than M, JOBU='O',
JOBVT='A') */
/* N right singular vectors to be computed
in VT and */
/* M left singular vectors to be overwritt
en on A */
/* Computing MAX */
i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3);
if (*lwork >= (*m << 1) * *m + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + (*lda << 1) * *m) {
/* WORK(IU) is LDA by M and
WORK(IR) is LDA by M */
ldwrku = *lda;
ir = iu + ldwrku * *m;
ldwrkr = *lda;
} else if (*lwork >= wrkbl + (*lda + *m) * *m) {
/* WORK(IU) is LDA by M and
WORK(IR) is M by M */
ldwrku = *lda;
ir = iu + ldwrku * *m;
ldwrkr = *m;
} else {
/* WORK(IU) is M by M and WO
RK(IR) is M by M */
ldwrku = *m;
ir = iu + ldwrku * *m;
ldwrkr = *m;
}
itau = ir + ldwrkr * *m;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (Workspace: need 2*M*M+2*M, pref
er 2*M*M+M+M*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (Workspace: need 2*M*M+M+N, pref
er 2*M*M+M+N*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy L to WORK(IU), zeroing out
above it */
dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[iu
+ ldwrku], &ldwrku, 1L);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IU), cop
ying result to */
/* WORK(IR) */
/* (Workspace: need 2*M*M+4*M, */
/* prefer 2*M*M+3*M+2*M
*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
dlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
ldwrkr, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IU) */
/* (Workspace: need 2*M*M+4*M-1, */
/* prefer 2*M*M+3*M+(M-
1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate left bidiagonalizing ve
ctors in WORK(IR) */
/* (Workspace: need 2*M*M+4*M, pref
er 2*M*M+3*M+M*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
, &work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of L in WORK(IR
) and computing */
/* right singular vectors of L in W
ORK(IU) */
/* (Workspace: need 2*M*M+BDSPAC)
*/
dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1,
&work[iwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IU) by */
/* Q in VT, storing result in A */
/* (Workspace: need M*M) */
dgemm_("N", "N", m, n, m, &c_b438, &work[iu], &ldwrku,
&vt[vt_offset], ldvt, &c_b416, &a[a_offset],
lda, 1L, 1L);
/* Copy right singular vectors of A
from A to VT */
dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Copy left singular vectors of A
from WORK(IR) to A */
dlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
lda, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (Workspace: need 2*M, prefer M+M
*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (Workspace: need M+N, prefer M+N
*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Zero out above L in A */
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &a[(
a_dim1 << 1) + 1], lda, 1L);
/* Bidiagonalize L in A */
/* (Workspace: need 4*M, prefer 3*M
+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right bidiagonalizing v
ectors in A by Q */
/* in VT */
/* (Workspace: need 3*M+N, prefer 3
*M+N*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
/* Generate left bidiagonalizing ve
ctors in A */
/* (Workspace: need 4*M, prefer 3*M
+M*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in A and c
omputing right */
/* singular vectors of A in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &a[a_offset], lda, dum, &
c__1, &work[iwork], info, 1L);
}
} else if (wntuas) {
/* Path 9t(N much larger than M, JOBU='S'
or 'A', */
/* JOBVT='A') */
/* N right singular vectors to be computed
in VT and */
/* M left singular vectors to be computed
in U */
/* Computing MAX */
i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3);
if (*lwork >= *m * *m + max(i__2,bdspac)) {
/* Sufficient workspace for a fast
algorithm */
iu = 1;
if (*lwork >= wrkbl + *lda * *m) {
/* WORK(IU) is LDA by M */
ldwrku = *lda;
} else {
/* WORK(IU) is M by M */
ldwrku = *m;
}
itau = iu + ldwrku * *m;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (Workspace: need M*M+2*M, prefer
M*M+M+M*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (Workspace: need M*M+M+N, prefer
M*M+M+N*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy L to WORK(IU), zeroing out
above it */
dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
ldwrku, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &work[iu
+ ldwrku], &ldwrku, 1L);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in WORK(IU), cop
ying result to U */
/* (Workspace: need M*M+4*M, prefer
M*M+3*M+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
dlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
ldu, 1L);
/* Generate right bidiagonalizing v
ectors in WORK(IU) */
/* (Workspace: need M*M+4*M, prefer
M*M+3*M+(M-1)*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
, &work[iwork], &i__2, &ierr, 1L);
/* Generate left bidiagonalizing ve
ctors in U */
/* (Workspace: need M*M+4*M, prefer
M*M+3*M+M*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of L in U and c
omputing right */
/* singular vectors of L in WORK(IU
) */
/* (Workspace: need M*M+BDSPAC) */
dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, &
work[iwork], info, 1L);
/* Multiply right singular vectors
of L in WORK(IU) by */
/* Q in VT, storing result in A */
/* (Workspace: need M*M) */
dgemm_("N", "N", m, n, m, &c_b438, &work[iu], &ldwrku,
&vt[vt_offset], ldvt, &c_b416, &a[a_offset],
lda, 1L, 1L);
/* Copy right singular vectors of A
from A to VT */
dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
} else {
/* Insufficient workspace for a fas
t algorithm */
itau = 1;
iwork = itau + *m;
/* Compute A=L*Q, copying result to
VT */
/* (Workspace: need 2*M, prefer M+M
*NB) */
i__2 = *lwork - iwork + 1;
dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
iwork], &i__2, &ierr);
dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
ldvt, 1L);
/* Generate Q in VT */
/* (Workspace: need M+N, prefer M+N
*NB) */
i__2 = *lwork - iwork + 1;
dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
work[iwork], &i__2, &ierr);
/* Copy L to U, zeroing out above i
t */
dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
ldu, 1L);
i__2 = *m - 1;
i__3 = *m - 1;
dlaset_("U", &i__2, &i__3, &c_b416, &c_b416, &u[(
u_dim1 << 1) + 1], ldu, 1L);
ie = itau;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize L in U */
/* (Workspace: need 4*M, prefer 3*M
+2*M*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &
work[itauq], &work[itaup], &work[iwork], &
i__2, &ierr);
/* Multiply right bidiagonalizing v
ectors in U by Q */
/* in VT */
/* (Workspace: need 3*M+N, prefer 3
*M+N*NB) */
i__2 = *lwork - iwork + 1;
dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &
work[itaup], &vt[vt_offset], ldvt, &work[
iwork], &i__2, &ierr, 1L, 1L, 1L);
/* Generate left bidiagonalizing ve
ctors in U */
/* (Workspace: need 4*M, prefer 3*M
+M*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
&work[iwork], &i__2, &ierr, 1L);
iwork = ie + *m;
/* Perform bidiagonal QR iteration,
computing left */
/* singular vectors of A in U and c
omputing right */
/* singular vectors of A in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, dum, &
c__1, &work[iwork], info, 1L);
}
}
}
} else {
/* N .LT. MNTHR */
/* Path 10t(N greater than M, but not much larger) */
/* Reduce to bidiagonal form without LQ decomposition */
ie = 1;
itauq = ie + *m;
itaup = itauq + *m;
iwork = itaup + *m;
/* Bidiagonalize A */
/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
i__2 = *lwork - iwork + 1;
dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
work[itaup], &work[iwork], &i__2, &ierr);
if (wntuas) {
/* If left singular vectors desired in U, copy re
sult to U */
/* and generate left bidiagonalizing vectors in U
*/
/* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
*/
dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu, 1L);
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
iwork], &i__2, &ierr, 1L);
}
if (wntvas) {
/* If right singular vectors desired in VT, copy
result to */
/* VT and generate right bidiagonalizing vectors
in VT */
/* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB)
*/
dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt,
1L);
if (wntva) {
nrvt = *n;
}
if (wntvs) {
nrvt = *m;
}
i__2 = *lwork - iwork + 1;
dorgbr_("P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup],
&work[iwork], &i__2, &ierr, 1L);
}
if (wntuo) {
/* If left singular vectors desired in A, generat
e left */
/* bidiagonalizing vectors in A */
/* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
*/
i__2 = *lwork - iwork + 1;
dorgbr_("Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[
iwork], &i__2, &ierr, 1L);
}
if (wntvo) {
/* If right singular vectors desired in A, genera
te right */
/* bidiagonalizing vectors in A */
/* (Workspace: need 4*M, prefer 3*M+M*NB) */
i__2 = *lwork - iwork + 1;
dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
iwork], &i__2, &ierr, 1L);
}
iwork = ie + *m;
if (wntuas || wntuo) {
nru = *m;
}
if (wntun) {
nru = 0;
}
if (wntvas || wntvo) {
ncvt = *n;
}
if (wntvn) {
ncvt = 0;
}
if (! wntuo && ! wntvo) {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in U and computing right
singular */
/* vectors in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, &
work[iwork], info, 1L);
} else if (! wntuo && wntvo) {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in U and computing right
singular */
/* vectors in A */
/* (Workspace: need BDSPAC) */
dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[
a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[
iwork], info, 1L);
} else {
/* Perform bidiagonal QR iteration, if desired, c
omputing */
/* left singular vectors in A and computing right
singular */
/* vectors in VT */
/* (Workspace: need BDSPAC) */
dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
work[iwork], info, 1L);
}
}
}
/* If DBDSQR failed to converge, copy unconverged superdiagonals */
/* to WORK( 2:MINMN ) */
if (*info != 0) {
if (ie > 2) {
i__2 = minmn - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[i__ + 1] = work[i__ + ie - 1];
/* L50: */
}
}
if (ie < 2) {
for (i__ = minmn - 1; i__ >= 1; --i__) {
work[i__ + 1] = work[i__ + ie - 1];
/* L60: */
}
}
}
/* Undo scaling if necessary */
if (iscl == 1) {
if (anrm > bignum) {
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
minmn, &ierr, 1L);
}
if (*info != 0 && anrm > bignum) {
i__2 = minmn - 1;
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &work[2],
&minmn, &ierr, 1L);
}
if (anrm < smlnum) {
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
minmn, &ierr, 1L);
}
if (*info != 0 && anrm < smlnum) {
i__2 = minmn - 1;
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &work[2],
&minmn, &ierr, 1L);
}
}
/* Return optimal workspace in WORK(1) */
work[1] = (doublereal) maxwrk;
return 0;
/* End of DGESVD */
} /* dgesvd_ */
/* dtrevc.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b23
#undef c_b23
#endif
#define c_b23 c_b23
#ifdef c_b26
#undef c_b26
#endif
#define c_b26 c_b26
/* Subroutine */ int dtrevc_(side, howmny, select, n, t, ldt, vl, ldvl, vr,
ldvr, mm, m, work, info, side_len, howmny_len)
char *side, *howmny;
logical *select;
integer *n;
doublereal *t;
integer *ldt;
doublereal *vl;
integer *ldvl;
doublereal *vr;
integer *ldvr, *mm, *m;
doublereal *work;
integer *info;
ftnlen side_len;
ftnlen howmny_len;
{
/* System generated locals */
integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt();
/* Local variables */
static doublereal beta, emax;
static logical pair;
extern doublereal ddot_();
static logical allv;
static integer ierr;
static doublereal unfl, ovfl, smin;
static logical over;
static doublereal vmax;
static integer jnxt, i__, j, k;
extern /* Subroutine */ int dscal_();
static doublereal scale, x[4] /* was [2][2] */;
extern logical lsame_();
extern /* Subroutine */ int dgemv_();
static doublereal remax;
extern /* Subroutine */ int dcopy_();
static logical leftv, bothv;
extern /* Subroutine */ int daxpy_();
static doublereal vcrit;
static logical somev;
static integer j1, j2, n2;
static doublereal xnorm;
extern /* Subroutine */ int dlaln2_(), dlabad_();
static integer ii, ki;
extern doublereal dlamch_();
static integer ip, is;
static doublereal wi;
extern integer idamax_();
static doublereal wr;
extern /* Subroutine */ int xerbla_();
static doublereal bignum;
static logical rightv;
static doublereal smlnum, rec, ulp;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DTREVC computes some or all of the right and/or left eigenvectors of
*/
/* a real upper quasi-triangular matrix T. */
/* The right eigenvector x and the left eigenvector y of T corresponding
*/
/* to an eigenvalue w are defined by: */
/* T*x = w*x, y'*T = w*y' */
/* where y' denotes the conjugate transpose of the vector y. */
/* If all eigenvectors are requested, the routine may either return the
*/
/* matrices X and/or Y of right or left eigenvectors of T, or the */
/* products Q*X and/or Q*Y, where Q is an input orthogonal */
/* matrix. If T was obtained from the real-Schur factorization of an */
/* original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of */
/* right or left eigenvectors of A. */
/* T must be in Schur canonical form (as returned by DHSEQR), that is, */
/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
/* 2-by-2 diagonal block has its diagonal elements equal and its */
/* off-diagonal elements of opposite sign. Corresponding to each 2-by-2
*/
/* diagonal block is a complex conjugate pair of eigenvalues and */
/* eigenvectors; only one eigenvector of the pair is computed, namely */
/* the one corresponding to the eigenvalue with positive imaginary part.
*/
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'R': compute right eigenvectors only; */
/* = 'L': compute left eigenvectors only; */
/* = 'B': compute both right and left eigenvectors. */
/* HOWMNY (input) CHARACTER*1 */
/* = 'A': compute all right and/or left eigenvectors; */
/* = 'B': compute all right and/or left eigenvectors, */
/* and backtransform them using the input matrices */
/* supplied in VR and/or VL; */
/* = 'S': compute selected right and/or left eigenvectors, */
/* specified by the logical array SELECT. */
/* SELECT (input/output) LOGICAL array, dimension (N) */
/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
/* computed. */
/* If HOWMNY = 'A' or 'B', SELECT is not referenced. */
/* To select the real eigenvector corresponding to a real */
/* eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select
*/
/* the complex eigenvector corresponding to a complex conjugate
*/
/* pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be
*/
/* set to .TRUE.; then on exit SELECT(j) is .TRUE. and */
/* SELECT(j+1) is .FALSE.. */
/* N (input) INTEGER */
/* The order of the matrix T. N >= 0. */
/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */
/* The upper quasi-triangular matrix T in Schur canonical form.
*/
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= max(1,N). */
/* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */
/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
/* of Schur vectors returned by DHSEQR). */
/* On exit, if SIDE = 'L' or 'B', VL contains: */
/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
/* if HOWMNY = 'B', the matrix Q*Y; */
/* if HOWMNY = 'S', the left eigenvectors of T specified by */
/* SELECT, stored consecutively in the columns
*/
/* of VL, in the same order as their */
/* eigenvalues. */
/* A complex eigenvector corresponding to a complex eigenvalue */
/* is stored in two consecutive columns, the first holding the */
/* real part, and the second the imaginary part. */
/* If SIDE = 'R', VL is not referenced. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= max(1,N) if */
/* SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */
/* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */
/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
/* of Schur vectors returned by DHSEQR). */
/* On exit, if SIDE = 'R' or 'B', VR contains: */
/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
/* if HOWMNY = 'B', the matrix Q*X; */
/* if HOWMNY = 'S', the right eigenvectors of T specified by */
/* SELECT, stored consecutively in the columns
*/
/* of VR, in the same order as their */
/* eigenvalues. */
/* A complex eigenvector corresponding to a complex eigenvalue */
/* is stored in two consecutive columns, the first holding the */
/* real part and the second the imaginary part. */
/* If SIDE = 'L', VR is not referenced. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= max(1,N) if */
/* SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */
/* MM (input) INTEGER */
/* The number of columns in the arrays VL and/or VR. MM >= M. */
/* M (output) INTEGER */
/* The number of columns in the arrays VL and/or VR actually */
/* used to store the eigenvectors. */
/* If HOWMNY = 'A' or 'B', M is set to N. */
/* Each selected real eigenvector occupies one column and each */
/* selected complex eigenvector occupies two columns. */
/* WORK (workspace) DOUBLE PRECISION 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 algorithm used in this program is basically backward (forward) */
/* substitution, with scaling to make the the code robust against */
/* possible overflow. */
/* Each eigenvector is normalized so that the element of largest */
/* magnitude has magnitude 1; here the magnitude of a complex number */
/* (x,y) is taken to be |x| + |y|. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and test the input parameters */
/* Parameter adjustments */
--select;
t_dim1 = *ldt;
t_offset = t_dim1 + 1;
t -= t_offset;
vl_dim1 = *ldvl;
vl_offset = vl_dim1 + 1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = vr_dim1 + 1;
vr -= vr_offset;
--work;
/* Function Body */
bothv = lsame_(side, "B", 1L, 1L);
rightv = lsame_(side, "R", 1L, 1L) || bothv;
leftv = lsame_(side, "L", 1L, 1L) || bothv;
allv = lsame_(howmny, "A", 1L, 1L);
over = lsame_(howmny, "B", 1L, 1L) || lsame_(howmny, "O", 1L, 1L);
somev = lsame_(howmny, "S", 1L, 1L);
*info = 0;
if (! rightv && ! leftv) {
*info = -1;
} else if (! allv && ! over && ! somev) {
*info = -2;
} else if (*n < 0) {
*info = -4;
} else if (*ldt < max(1,*n)) {
*info = -6;
} else if (*ldvl < 1 || leftv && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || rightv && *ldvr < *n) {
*info = -10;
} else {
/* Set M to the number of columns required to store the selecte
d */
/* eigenvectors, standardize the array SELECT if necessary, and
*/
/* test MM. */
if (somev) {
*m = 0;
pair = FALSE_;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (pair) {
pair = FALSE_;
select[j] = FALSE_;
} else {
if (j < *n) {
if (t[j + 1 + j * t_dim1] == 0.) {
if (select[j]) {
++(*m);
}
} else {
pair = TRUE_;
if (select[j] || select[j + 1]) {
select[j] = TRUE_;
*m += 2;
}
}
} else {
if (select[*n]) {
++(*m);
}
}
}
/* L10: */
}
} else {
*m = *n;
}
if (*mm < *m) {
*info = -11;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTREVC", &i__1, 6L);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
/* Set the constants to control overflow. */
unfl = dlamch_("Safe minimum", 12L);
ovfl = 1. / unfl;
dlabad_(&unfl, &ovfl);
ulp = dlamch_("Precision", 9L);
smlnum = unfl * (*n / ulp);
bignum = (1. - ulp) / smlnum;
/* Compute 1-norm of each column of strictly upper triangular */
/* part of T to control overflow in triangular solver. */
work[1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
work[j] = 0.;
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[j] += (d__1 = t[i__ + j * t_dim1], abs(d__1));
/* L20: */
}
/* L30: */
}
/* Index IP is used to specify the real or complex eigenvalue: */
/* IP = 0, real eigenvalue, */
/* 1, first of conjugate complex pair: (wr,wi) */
/* -1, second of conjugate complex pair: (wr,wi) */
n2 = *n << 1;
if (rightv) {
/* Compute right eigenvectors. */
ip = 0;
is = *m;
for (ki = *n; ki >= 1; --ki) {
if (ip == 1) {
goto L130;
}
if (ki == 1) {
goto L40;
}
if (t[ki + (ki - 1) * t_dim1] == 0.) {
goto L40;
}
ip = -1;
L40:
if (somev) {
if (ip == 0) {
if (! select[ki]) {
goto L130;
}
} else {
if (! select[ki - 1]) {
goto L130;
}
}
}
/* Compute the KI-th eigenvalue (WR,WI). */
wr = t[ki + ki * t_dim1];
wi = 0.;
if (ip != 0) {
wi = sqrt((d__1 = t[ki + (ki - 1) * t_dim1], abs(d__1))) *
sqrt((d__2 = t[ki - 1 + ki * t_dim1], abs(d__2)));
}
/* Computing MAX */
d__1 = ulp * (abs(wr) + abs(wi));
smin = max(d__1,smlnum);
if (ip == 0) {
/* Real right eigenvector */
work[ki + *n] = 1.;
/* Form right-hand side */
i__1 = ki - 1;
for (k = 1; k <= i__1; ++k) {
work[k + *n] = -t[k + ki * t_dim1];
/* L50: */
}
/* Solve the upper quasi-triangular system: */
/* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. */
jnxt = ki - 1;
for (j = ki - 1; j >= 1; --j) {
if (j > jnxt) {
goto L60;
}
j1 = j;
j2 = j;
jnxt = j - 1;
if (j > 1) {
if (t[j + (j - 1) * t_dim1] != 0.) {
j1 = j - 1;
jnxt = j - 2;
}
}
if (j1 == j2) {
/* 1-by-1 diagonal block */
dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b23, &t[j +
j * t_dim1], ldt, &c_b23, &c_b23, &work[j + *
n], n, &wr, &c_b26, x, &c__2, &scale, &xnorm,
&ierr);
/* Scale X(1,1) to avoid overflow w
hen updating */
/* the right-hand side. */
if (xnorm > 1.) {
if (work[j] > bignum / xnorm) {
x[0] /= xnorm;
scale /= xnorm;
}
}
/* Scale if necessary */
if (scale != 1.) {
dscal_(&ki, &scale, &work[*n + 1], &c__1);
}
work[j + *n] = x[0];
/* Update right-hand side */
i__1 = j - 1;
d__1 = -x[0];
daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
*n + 1], &c__1);
} else {
/* 2-by-2 diagonal block */
dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b23, &t[j -
1 + (j - 1) * t_dim1], ldt, &c_b23, &c_b23, &
work[j - 1 + *n], n, &wr, &c_b26, x, &c__2, &
scale, &xnorm, &ierr);
/* Scale X(1,1) and X(2,1) to avoid
overflow when */
/* updating the right-hand side. */
if (xnorm > 1.) {
/* Computing MAX */
d__1 = work[j - 1], d__2 = work[j];
beta = max(d__1,d__2);
if (beta > bignum / xnorm) {
x[0] /= xnorm;
x[1] /= xnorm;
scale /= xnorm;
}
}
/* Scale if necessary */
if (scale != 1.) {
dscal_(&ki, &scale, &work[*n + 1], &c__1);
}
work[j - 1 + *n] = x[0];
work[j + *n] = x[1];
/* Update right-hand side */
i__1 = j - 2;
d__1 = -x[0];
daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1,
&work[*n + 1], &c__1);
i__1 = j - 2;
d__1 = -x[1];
daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
*n + 1], &c__1);
}
L60:
;
}
/* Copy the vector x or Q*x to VR and normalize.
*/
if (! over) {
dcopy_(&ki, &work[*n + 1], &c__1, &vr[is * vr_dim1 + 1], &
c__1);
ii = idamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
remax = 1. / (d__1 = vr[ii + is * vr_dim1], abs(d__1));
dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
i__1 = *n;
for (k = ki + 1; k <= i__1; ++k) {
vr[k + is * vr_dim1] = 0.;
/* L70: */
}
} else {
if (ki > 1) {
i__1 = ki - 1;
dgemv_("N", n, &i__1, &c_b23, &vr[vr_offset], ldvr, &
work[*n + 1], &c__1, &work[ki + *n], &vr[ki *
vr_dim1 + 1], &c__1, 1L);
}
ii = idamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
remax = 1. / (d__1 = vr[ii + ki * vr_dim1], abs(d__1));
dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
}
} else {
/* Complex right eigenvector. */
/* Initial solve */
/* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]
*X = 0. */
/* [ (T(KI,KI-1) T(KI,KI) ) ]
*/
if ((d__1 = t[ki - 1 + ki * t_dim1], abs(d__1)) >= (d__2 = t[
ki + (ki - 1) * t_dim1], abs(d__2))) {
work[ki - 1 + *n] = 1.;
work[ki + n2] = wi / t[ki - 1 + ki * t_dim1];
} else {
work[ki - 1 + *n] = -wi / t[ki + (ki - 1) * t_dim1];
work[ki + n2] = 1.;
}
work[ki + *n] = 0.;
work[ki - 1 + n2] = 0.;
/* Form right-hand side */
i__1 = ki - 2;
for (k = 1; k <= i__1; ++k) {
work[k + *n] = -work[ki - 1 + *n] * t[k + (ki - 1) *
t_dim1];
work[k + n2] = -work[ki + n2] * t[k + ki * t_dim1];
/* L80: */
}
/* Solve upper quasi-triangular system: */
/* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK
+i*WORK2) */
jnxt = ki - 2;
for (j = ki - 2; j >= 1; --j) {
if (j > jnxt) {
goto L90;
}
j1 = j;
j2 = j;
jnxt = j - 1;
if (j > 1) {
if (t[j + (j - 1) * t_dim1] != 0.) {
j1 = j - 1;
jnxt = j - 2;
}
}
if (j1 == j2) {
/* 1-by-1 diagonal block */
dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b23, &t[j +
j * t_dim1], ldt, &c_b23, &c_b23, &work[j + *
n], n, &wr, &wi, x, &c__2, &scale, &xnorm, &
ierr);
/* Scale X(1,1) and X(1,2) to avoid
overflow when */
/* updating the right-hand side. */
if (xnorm > 1.) {
if (work[j] > bignum / xnorm) {
x[0] /= xnorm;
x[2] /= xnorm;
scale /= xnorm;
}
}
/* Scale if necessary */
if (scale != 1.) {
dscal_(&ki, &scale, &work[*n + 1], &c__1);
dscal_(&ki, &scale, &work[n2 + 1], &c__1);
}
work[j + *n] = x[0];
work[j + n2] = x[2];
/* Update the right-hand side */
i__1 = j - 1;
d__1 = -x[0];
daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
*n + 1], &c__1);
i__1 = j - 1;
d__1 = -x[2];
daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
n2 + 1], &c__1);
} else {
/* 2-by-2 diagonal block */
dlaln2_(&c_false, &c__2, &c__2, &smin, &c_b23, &t[j -
1 + (j - 1) * t_dim1], ldt, &c_b23, &c_b23, &
work[j - 1 + *n], n, &wr, &wi, x, &c__2, &
scale, &xnorm, &ierr);
/* Scale X to avoid overflow when u
pdating */
/* the right-hand side. */
if (xnorm > 1.) {
/* Computing MAX */
d__1 = work[j - 1], d__2 = work[j];
beta = max(d__1,d__2);
if (beta > bignum / xnorm) {
rec = 1. / xnorm;
x[0] *= rec;
x[2] *= rec;
x[1] *= rec;
x[3] *= rec;
scale *= rec;
}
}
/* Scale if necessary */
if (scale != 1.) {
dscal_(&ki, &scale, &work[*n + 1], &c__1);
dscal_(&ki, &scale, &work[n2 + 1], &c__1);
}
work[j - 1 + *n] = x[0];
work[j + *n] = x[1];
work[j - 1 + n2] = x[2];
work[j + n2] = x[3];
/* Update the right-hand side */
i__1 = j - 2;
d__1 = -x[0];
daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1,
&work[*n + 1], &c__1);
i__1 = j - 2;
d__1 = -x[1];
daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
*n + 1], &c__1);
i__1 = j - 2;
d__1 = -x[2];
daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1,
&work[n2 + 1], &c__1);
i__1 = j - 2;
d__1 = -x[3];
daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
n2 + 1], &c__1);
}
L90:
;
}
/* Copy the vector x or Q*x to VR and normalize.
*/
if (! over) {
dcopy_(&ki, &work[*n + 1], &c__1, &vr[(is - 1) * vr_dim1
+ 1], &c__1);
dcopy_(&ki, &work[n2 + 1], &c__1, &vr[is * vr_dim1 + 1], &
c__1);
emax = 0.;
i__1 = ki;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__3 = emax, d__4 = (d__1 = vr[k + (is - 1) * vr_dim1]
, abs(d__1)) + (d__2 = vr[k + is * vr_dim1],
abs(d__2));
emax = max(d__3,d__4);
/* L100: */
}
remax = 1. / emax;
dscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1);
dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
i__1 = *n;
for (k = ki + 1; k <= i__1; ++k) {
vr[k + (is - 1) * vr_dim1] = 0.;
vr[k + is * vr_dim1] = 0.;
/* L110: */
}
} else {
if (ki > 2) {
i__1 = ki - 2;
dgemv_("N", n, &i__1, &c_b23, &vr[vr_offset], ldvr, &
work[*n + 1], &c__1, &work[ki - 1 + *n], &vr[(
ki - 1) * vr_dim1 + 1], &c__1, 1L);
i__1 = ki - 2;
dgemv_("N", n, &i__1, &c_b23, &vr[vr_offset], ldvr, &
work[n2 + 1], &c__1, &work[ki + n2], &vr[ki *
vr_dim1 + 1], &c__1, 1L);
} else {
dscal_(n, &work[ki - 1 + *n], &vr[(ki - 1) * vr_dim1
+ 1], &c__1);
dscal_(n, &work[ki + n2], &vr[ki * vr_dim1 + 1], &
c__1);
}
emax = 0.;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__3 = emax, d__4 = (d__1 = vr[k + (ki - 1) * vr_dim1]
, abs(d__1)) + (d__2 = vr[k + ki * vr_dim1],
abs(d__2));
emax = max(d__3,d__4);
/* L120: */
}
remax = 1. / emax;
dscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1);
dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
}
}
--is;
if (ip != 0) {
--is;
}
L130:
if (ip == 1) {
ip = 0;
}
if (ip == -1) {
ip = 1;
}
/* L140: */
}
}
if (leftv) {
/* Compute left eigenvectors. */
ip = 0;
is = 1;
i__1 = *n;
for (ki = 1; ki <= i__1; ++ki) {
if (ip == -1) {
goto L250;
}
if (ki == *n) {
goto L150;
}
if (t[ki + 1 + ki * t_dim1] == 0.) {
goto L150;
}
ip = 1;
L150:
if (somev) {
if (! select[ki]) {
goto L250;
}
}
/* Compute the KI-th eigenvalue (WR,WI). */
wr = t[ki + ki * t_dim1];
wi = 0.;
if (ip != 0) {
wi = sqrt((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1))) *
sqrt((d__2 = t[ki + 1 + ki * t_dim1], abs(d__2)));
}
/* Computing MAX */
d__1 = ulp * (abs(wr) + abs(wi));
smin = max(d__1,smlnum);
if (ip == 0) {
/* Real left eigenvector. */
work[ki + *n] = 1.;
/* Form right-hand side */
i__2 = *n;
for (k = ki + 1; k <= i__2; ++k) {
work[k + *n] = -t[ki + k * t_dim1];
/* L160: */
}
/* Solve the quasi-triangular system: */
/* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK */
vmax = 1.;
vcrit = bignum;
jnxt = ki + 1;
i__2 = *n;
for (j = ki + 1; j <= i__2; ++j) {
if (j < jnxt) {
goto L170;
}
j1 = j;
j2 = j;
jnxt = j + 1;
if (j < *n) {
if (t[j + 1 + j * t_dim1] != 0.) {
j2 = j + 1;
jnxt = j + 2;
}
}
if (j1 == j2) {
/* 1-by-1 diagonal block */
/* Scale if necessary to avoid over
flow when forming */
/* the right-hand side. */
if (work[j] > vcrit) {
rec = 1. / vmax;
i__3 = *n - ki + 1;
dscal_(&i__3, &rec, &work[ki + *n], &c__1);
vmax = 1.;
vcrit = bignum;
}
i__3 = j - ki - 1;
work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1],
&c__1, &work[ki + 1 + *n], &c__1);
/* Solve (T(J,J)-WR)'*X = WORK */
dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b23, &t[j +
j * t_dim1], ldt, &c_b23, &c_b23, &work[j + *
n], n, &wr, &c_b26, x, &c__2, &scale, &xnorm,
&ierr);
/* Scale if necessary */
if (scale != 1.) {
i__3 = *n - ki + 1;
dscal_(&i__3, &scale, &work[ki + *n], &c__1);
}
work[j + *n] = x[0];
/* Computing MAX */
d__2 = (d__1 = work[j + *n], abs(d__1));
vmax = max(d__2,vmax);
vcrit = bignum / vmax;
} else {
/* 2-by-2 diagonal block */
/* Scale if necessary to avoid over
flow when forming */
/* the right-hand side. */
/* Computing MAX */
d__1 = work[j], d__2 = work[j + 1];
beta = max(d__1,d__2);
if (beta > vcrit) {
rec = 1. / vmax;
i__3 = *n - ki + 1;
dscal_(&i__3, &rec, &work[ki + *n], &c__1);
vmax = 1.;
vcrit = bignum;
}
i__3 = j - ki - 1;
work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1],
&c__1, &work[ki + 1 + *n], &c__1);
i__3 = j - ki - 1;
work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 1 + (j + 1) *
t_dim1], &c__1, &work[ki + 1 + *n], &c__1);
/* Solve */
/* [T(J,J)-WR T(J,J+1) ]'*
X = SCALE*( WORK1 ) */
/* [T(J+1,J) T(J+1,J+1)-WR]
( WORK2 ) */
dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b23, &t[j +
j * t_dim1], ldt, &c_b23, &c_b23, &work[j + *
n], n, &wr, &c_b26, x, &c__2, &scale, &xnorm,
&ierr);
/* Scale if necessary */
if (scale != 1.) {
i__3 = *n - ki + 1;
dscal_(&i__3, &scale, &work[ki + *n], &c__1);
}
work[j + *n] = x[0];
work[j + 1 + *n] = x[1];
/* Computing MAX */
d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2
= work[j + 1 + *n], abs(d__2)), d__3 = max(
d__3,d__4);
vmax = max(d__3,vmax);
vcrit = bignum / vmax;
}
L170:
;
}
/* Copy the vector x or Q*x to VL and normalize.
*/
if (! over) {
i__2 = *n - ki + 1;
dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is *
vl_dim1], &c__1);
i__2 = *n - ki + 1;
ii = idamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki -
1;
remax = 1. / (d__1 = vl[ii + is * vl_dim1], abs(d__1));
i__2 = *n - ki + 1;
dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
vl[k + is * vl_dim1] = 0.;
/* L180: */
}
} else {
if (ki < *n) {
i__2 = *n - ki;
dgemv_("N", n, &i__2, &c_b23, &vl[(ki + 1) * vl_dim1
+ 1], ldvl, &work[ki + 1 + *n], &c__1, &work[
ki + *n], &vl[ki * vl_dim1 + 1], &c__1, 1L);
}
ii = idamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
remax = 1. / (d__1 = vl[ii + ki * vl_dim1], abs(d__1));
dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
}
} else {
/* Complex left eigenvector. */
/* Initial solve: */
/* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))
*X = 0. */
/* ((T(KI+1,KI) T(KI+1,KI+1)) )
*/
if ((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1)) >= (d__2 =
t[ki + 1 + ki * t_dim1], abs(d__2))) {
work[ki + *n] = wi / t[ki + (ki + 1) * t_dim1];
work[ki + 1 + n2] = 1.;
} else {
work[ki + *n] = 1.;
work[ki + 1 + n2] = -wi / t[ki + 1 + ki * t_dim1];
}
work[ki + 1 + *n] = 0.;
work[ki + n2] = 0.;
/* Form right-hand side */
i__2 = *n;
for (k = ki + 2; k <= i__2; ++k) {
work[k + *n] = -work[ki + *n] * t[ki + k * t_dim1];
work[k + n2] = -work[ki + 1 + n2] * t[ki + 1 + k * t_dim1]
;
/* L190: */
}
/* Solve complex quasi-triangular system: */
/* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*W
ORK2 */
vmax = 1.;
vcrit = bignum;
jnxt = ki + 2;
i__2 = *n;
for (j = ki + 2; j <= i__2; ++j) {
if (j < jnxt) {
goto L200;
}
j1 = j;
j2 = j;
jnxt = j + 1;
if (j < *n) {
if (t[j + 1 + j * t_dim1] != 0.) {
j2 = j + 1;
jnxt = j + 2;
}
}
if (j1 == j2) {
/* 1-by-1 diagonal block */
/* Scale if necessary to avoid over
flow when */
/* forming the right-hand side elem
ents. */
if (work[j] > vcrit) {
rec = 1. / vmax;
i__3 = *n - ki + 1;
dscal_(&i__3, &rec, &work[ki + *n], &c__1);
i__3 = *n - ki + 1;
dscal_(&i__3, &rec, &work[ki + n2], &c__1);
vmax = 1.;
vcrit = bignum;
}
i__3 = j - ki - 2;
work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
&c__1, &work[ki + 2 + *n], &c__1);
i__3 = j - ki - 2;
work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
&c__1, &work[ki + 2 + n2], &c__1);
/* Solve (T(J,J)-(WR-i*WI))*(X11+i*
X12)= WK+I*WK2 */
d__1 = -wi;
dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b23, &t[j +
j * t_dim1], ldt, &c_b23, &c_b23, &work[j + *
n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, &
ierr);
/* Scale if necessary */
if (scale != 1.) {
i__3 = *n - ki + 1;
dscal_(&i__3, &scale, &work[ki + *n], &c__1);
i__3 = *n - ki + 1;
dscal_(&i__3, &scale, &work[ki + n2], &c__1);
}
work[j + *n] = x[0];
work[j + n2] = x[2];
/* Computing MAX */
d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2
= work[j + n2], abs(d__2)), d__3 = max(d__3,
d__4);
vmax = max(d__3,vmax);
vcrit = bignum / vmax;
} else {
/* 2-by-2 diagonal block */
/* Scale if necessary to avoid over
flow when forming */
/* the right-hand side elements. */
/* Computing MAX */
d__1 = work[j], d__2 = work[j + 1];
beta = max(d__1,d__2);
if (beta > vcrit) {
rec = 1. / vmax;
i__3 = *n - ki + 1;
dscal_(&i__3, &rec, &work[ki + *n], &c__1);
i__3 = *n - ki + 1;
dscal_(&i__3, &rec, &work[ki + n2], &c__1);
vmax = 1.;
vcrit = bignum;
}
i__3 = j - ki - 2;
work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
&c__1, &work[ki + 2 + *n], &c__1);
i__3 = j - ki - 2;
work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
&c__1, &work[ki + 2 + n2], &c__1);
i__3 = j - ki - 2;
work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 2 + (j + 1) *
t_dim1], &c__1, &work[ki + 2 + *n], &c__1);
i__3 = j - ki - 2;
work[j + 1 + n2] -= ddot_(&i__3, &t[ki + 2 + (j + 1) *
t_dim1], &c__1, &work[ki + 2 + n2], &c__1);
/* Solve 2-by-2 complex linear equa
tion */
/* ([T(j,j) T(j,j+1) ]'-(wr-i*
wi)*I)*X = SCALE*B */
/* ([T(j+1,j) T(j+1,j+1)]
) */
d__1 = -wi;
dlaln2_(&c_true, &c__2, &c__2, &smin, &c_b23, &t[j +
j * t_dim1], ldt, &c_b23, &c_b23, &work[j + *
n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, &
ierr);
/* Scale if necessary */
if (scale != 1.) {
i__3 = *n - ki + 1;
dscal_(&i__3, &scale, &work[ki + *n], &c__1);
i__3 = *n - ki + 1;
dscal_(&i__3, &scale, &work[ki + n2], &c__1);
}
work[j + *n] = x[0];
work[j + n2] = x[2];
work[j + 1 + *n] = x[1];
work[j + 1 + n2] = x[3];
/* Computing MAX */
d__1 = abs(x[0]), d__2 = abs(x[2]), d__1 = max(d__1,
d__2), d__2 = abs(x[1]), d__1 = max(d__1,d__2)
, d__2 = abs(x[3]), d__1 = max(d__1,d__2);
vmax = max(d__1,vmax);
vcrit = bignum / vmax;
}
L200:
;
}
/* Copy the vector x or Q*x to VL and normalize.
*/
/* L210: */
if (! over) {
i__2 = *n - ki + 1;
dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is *
vl_dim1], &c__1);
i__2 = *n - ki + 1;
dcopy_(&i__2, &work[ki + n2], &c__1, &vl[ki + (is + 1) *
vl_dim1], &c__1);
emax = 0.;
i__2 = *n;
for (k = ki; k <= i__2; ++k) {
/* Computing MAX */
d__3 = emax, d__4 = (d__1 = vl[k + is * vl_dim1], abs(
d__1)) + (d__2 = vl[k + (is + 1) * vl_dim1],
abs(d__2));
emax = max(d__3,d__4);
/* L220: */
}
remax = 1. / emax;
i__2 = *n - ki + 1;
dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
i__2 = *n - ki + 1;
dscal_(&i__2, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1)
;
i__2 = ki - 1;
for (k = 1; k <= i__2; ++k) {
vl[k + is * vl_dim1] = 0.;
vl[k + (is + 1) * vl_dim1] = 0.;
/* L230: */
}
} else {
if (ki < *n - 1) {
i__2 = *n - ki - 1;
dgemv_("N", n, &i__2, &c_b23, &vl[(ki + 2) * vl_dim1
+ 1], ldvl, &work[ki + 2 + *n], &c__1, &work[
ki + *n], &vl[ki * vl_dim1 + 1], &c__1, 1L);
i__2 = *n - ki - 1;
dgemv_("N", n, &i__2, &c_b23, &vl[(ki + 2) * vl_dim1
+ 1], ldvl, &work[ki + 2 + n2], &c__1, &work[
ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + 1], &
c__1, 1L);
} else {
dscal_(n, &work[ki + *n], &vl[ki * vl_dim1 + 1], &
c__1);
dscal_(n, &work[ki + 1 + n2], &vl[(ki + 1) * vl_dim1
+ 1], &c__1);
}
emax = 0.;
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* Computing MAX */
d__3 = emax, d__4 = (d__1 = vl[k + ki * vl_dim1], abs(
d__1)) + (d__2 = vl[k + (ki + 1) * vl_dim1],
abs(d__2));
emax = max(d__3,d__4);
/* L240: */
}
remax = 1. / emax;
dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
dscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1);
}
}
++is;
if (ip != 0) {
++is;
}
L250:
if (ip == -1) {
ip = 0;
}
if (ip == 1) {
ip = -1;
}
/* L260: */
}
}
return 0;
/* End of DTREVC */
} /* dtrevc_ */
/* dlasq3.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dlasq3_(n, q, e, qq, ee, sup, sigma, kend, off, iphase,
iconv, eps, tol2, small2)
integer *n;
doublereal *q, *e, *qq, *ee, *sup, *sigma;
integer *kend, *off, *iphase, *iconv;
doublereal *eps, *tol2, *small2;
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt();
/* Local variables */
static logical ldef;
static integer icnt;
static doublereal tolx, toly, tolz;
static integer k1end, k2end;
static doublereal d__;
static integer i__;
static doublereal qemax;
extern /* Subroutine */ int dcopy_();
static integer maxit, n1, n2;
static doublereal t1;
extern /* Subroutine */ int dlasq4_();
static integer ic, ke;
static doublereal dm;
static integer ip, ks;
static doublereal xx, yy;
static logical lsplit;
static integer ifl;
static doublereal tau;
static integer isp;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLASQ3 is the workhorse of the whole bidiagonal SVD algorithm. */
/* This can be described as the differential qd with shifts. */
/* Arguments */
/* ========= */
/* N (input/output) INTEGER */
/* On entry, N specifies the number of rows and columns */
/* in the matrix. N must be at least 3. */
/* On exit N is non-negative and less than the input value. */
/* Q (input/output) DOUBLE PRECISION array, dimension (N) */
/* Q array in ping (see IPHASE below) */
/* E (input/output) DOUBLE PRECISION array, dimension (N) */
/* E array in ping (see IPHASE below) */
/* QQ (input/output) DOUBLE PRECISION array, dimension (N) */
/* Q array in pong (see IPHASE below) */
/* EE (input/output) DOUBLE PRECISION array, dimension (N) */
/* E array in pong (see IPHASE below) */
/* SUP (input/output) DOUBLE PRECISION */
/* Upper bound for the smallest eigenvalue */
/* SIGMA (input/output) DOUBLE PRECISION */
/* Accumulated shift for the present submatrix */
/* KEND (input/output) INTEGER */
/* Index where minimum D(i) occurs in recurrence for */
/* splitting criterion */
/* OFF (input/output) INTEGER */
/* Offset for arrays */
/* IPHASE (input/output) INTEGER */
/* If IPHASE = 1 (ping) then data is in Q and E arrays */
/* If IPHASE = 2 (pong) then data is in QQ and EE arrays */
/* ICONV (input) INTEGER */
/* If ICONV = 0 a bottom part of a matrix (with a split) */
/* If ICONV =-3 a top part of a matrix (with a split) */
/* EPS (input) DOUBLE PRECISION */
/* Machine epsilon */
/* TOL2 (input) DOUBLE PRECISION */
/* Square of the relative tolerance TOL as defined in DLASQ1 */
/* SMALL2 (input) DOUBLE PRECISION */
/* A threshold value as defined in DLASQ1 */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ee;
--qq;
--e;
--q;
/* Function Body */
icnt = 0;
tau = 0.;
dm = *sup;
tolx = *sigma * *tol2;
tolz = max(*small2,*sigma) * *tol2;
/* Set maximum number of iterations */
maxit = *n * 100;
/* Flipping */
ic = 2;
if (*n > 3) {
if (*iphase == 1) {
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
if (q[i__] > q[i__ + 1]) {
++ic;
}
if (e[i__] > e[i__ + 1]) {
++ic;
}
/* L10: */
}
if (q[*n - 1] > q[*n]) {
++ic;
}
if (ic < *n) {
dcopy_(n, &q[1], &c__1, &qq[1], &c_n1);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &ee[1], &c_n1);
if (*kend != 0) {
*kend = *n - *kend + 1;
}
*iphase = 2;
}
} else {
i__1 = *n - 2;
for (i__ = 1; i__ <= i__1; ++i__) {
if (qq[i__] > qq[i__ + 1]) {
++ic;
}
if (ee[i__] > ee[i__ + 1]) {
++ic;
}
/* L20: */
}
if (qq[*n - 1] > qq[*n]) {
++ic;
}
if (ic < *n) {
dcopy_(n, &qq[1], &c__1, &q[1], &c_n1);
i__1 = *n - 1;
dcopy_(&i__1, &ee[1], &c__1, &e[1], &c_n1);
if (*kend != 0) {
*kend = *n - *kend + 1;
}
*iphase = 1;
}
}
}
if (*iconv == -3) {
if (*iphase == 1) {
goto L180;
} else {
goto L80;
}
}
if (*iphase == 2) {
goto L130;
}
/* The ping section of the code */
L30:
ifl = 0;
/* Compute the shift */
if (*kend == 0 || *sup == 0.) {
tau = 0.;
} else if (icnt > 0 && dm <= tolz) {
tau = 0.;
} else {
/* Computing MAX */
i__1 = 5, i__2 = *n / 32;
ip = max(i__1,i__2);
n2 = (ip << 1) + 1;
if (n2 >= *n) {
n1 = 1;
n2 = *n;
} else if (*kend + ip > *n) {
n1 = *n - (ip << 1);
} else if (*kend - ip < 1) {
n1 = 1;
} else {
n1 = *kend - ip;
}
dlasq4_(&n2, &q[n1], &e[n1], &tau, sup);
}
L40:
++icnt;
if (icnt > maxit) {
*sup = -1.;
return 0;
}
if (tau == 0.) {
/* dqd algorithm */
d__ = q[1];
dm = d__;
ke = 0;
i__1 = *n - 3;
for (i__ = 1; i__ <= i__1; ++i__) {
qq[i__] = d__ + e[i__];
d__ = d__ / qq[i__] * q[i__ + 1];
if (dm > d__) {
dm = d__;
ke = i__;
}
/* L50: */
}
++ke;
/* Penultimate dqd step (in ping) */
k2end = ke;
qq[*n - 2] = d__ + e[*n - 2];
d__ = d__ / qq[*n - 2] * q[*n - 1];
if (dm > d__) {
dm = d__;
ke = *n - 1;
}
/* Final dqd step (in ping) */
k1end = ke;
qq[*n - 1] = d__ + e[*n - 1];
d__ = d__ / qq[*n - 1] * q[*n];
if (dm > d__) {
dm = d__;
ke = *n;
}
qq[*n] = d__;
} else {
/* The dqds algorithm (in ping) */
d__ = q[1] - tau;
dm = d__;
ke = 0;
if (d__ < 0.) {
goto L120;
}
i__1 = *n - 3;
for (i__ = 1; i__ <= i__1; ++i__) {
qq[i__] = d__ + e[i__];
d__ = d__ / qq[i__] * q[i__ + 1] - tau;
if (dm > d__) {
dm = d__;
ke = i__;
if (d__ < 0.) {
goto L120;
}
}
/* L60: */
}
++ke;
/* Penultimate dqds step (in ping) */
k2end = ke;
qq[*n - 2] = d__ + e[*n - 2];
d__ = d__ / qq[*n - 2] * q[*n - 1] - tau;
if (dm > d__) {
dm = d__;
ke = *n - 1;
if (d__ < 0.) {
goto L120;
}
}
/* Final dqds step (in ping) */
k1end = ke;
qq[*n - 1] = d__ + e[*n - 1];
d__ = d__ / qq[*n - 1] * q[*n] - tau;
if (dm > d__) {
dm = d__;
ke = *n;
}
qq[*n] = d__;
}
/* Convergence when QQ(N) is small (in ping) */
if ((d__1 = qq[*n], abs(d__1)) <= *sigma * *tol2) {
qq[*n] = 0.;
dm = 0.;
ke = *n;
}
if (qq[*n] < 0.) {
goto L120;
}
/* Non-negative qd array: Update the e's */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
ee[i__] = e[i__] / qq[i__] * q[i__ + 1];
/* L70: */
}
/* Updating sigma and iphase in ping */
*sigma += tau;
*iphase = 2;
L80:
tolx = *sigma * *tol2;
toly = *sigma * *eps;
tolz = max(*sigma,*small2) * *tol2;
/* Checking for deflation and convergence (in ping) */
L90:
if (*n <= 2) {
return 0;
}
/* Deflation: bottom 1x1 (in ping) */
ldef = FALSE_;
if (ee[*n - 1] <= tolz) {
ldef = TRUE_;
} else if (*sigma > 0.) {
if (ee[*n - 1] <= *eps * (*sigma + qq[*n])) {
if (ee[*n - 1] * (qq[*n] / (qq[*n] + *sigma)) <= *tol2 * (qq[*n]
+ *sigma)) {
ldef = TRUE_;
}
}
} else {
if (ee[*n - 1] <= qq[*n] * *tol2) {
ldef = TRUE_;
}
}
if (ldef) {
q[*n] = qq[*n] + *sigma;
--(*n);
++(*iconv);
goto L90;
}
/* Deflation: bottom 2x2 (in ping) */
ldef = FALSE_;
if (ee[*n - 2] <= tolz) {
ldef = TRUE_;
} else if (*sigma > 0.) {
t1 = *sigma + ee[*n - 1] * (*sigma / (*sigma + qq[*n]));
if (ee[*n - 2] * (t1 / (qq[*n - 1] + t1)) <= toly) {
if (ee[*n - 2] * (qq[*n - 1] / (qq[*n - 1] + t1)) <= tolx) {
ldef = TRUE_;
}
}
} else {
if (ee[*n - 2] <= qq[*n] / (qq[*n] + ee[*n - 1] + qq[*n - 1]) * qq[*n
- 1] * *tol2) {
ldef = TRUE_;
}
}
if (ldef) {
/* Computing MAX */
d__1 = qq[*n], d__2 = qq[*n - 1], d__1 = max(d__1,d__2), d__2 = ee[*n
- 1];
qemax = max(d__1,d__2);
if (qemax != 0.) {
if (qemax == qq[*n - 1]) {
/* Computing 2nd power */
d__1 = (qq[*n] - qq[*n - 1] + ee[*n - 1]) / qemax;
xx = (qq[*n] + qq[*n - 1] + ee[*n - 1] + qemax * sqrt(d__1 *
d__1 + ee[*n - 1] * 4. / qemax)) * .5;
} else if (qemax == qq[*n]) {
/* Computing 2nd power */
d__1 = (qq[*n - 1] - qq[*n] + ee[*n - 1]) / qemax;
xx = (qq[*n] + qq[*n - 1] + ee[*n - 1] + qemax * sqrt(d__1 *
d__1 + ee[*n - 1] * 4. / qemax)) * .5;
} else {
/* Computing 2nd power */
d__1 = (qq[*n] - qq[*n - 1] + ee[*n - 1]) / qemax;
xx = (qq[*n] + qq[*n - 1] + ee[*n - 1] + qemax * sqrt(d__1 *
d__1 + qq[*n - 1] * 4. / qemax)) * .5;
}
/* Computing MAX */
d__1 = qq[*n], d__2 = qq[*n - 1];
/* Computing MIN */
d__3 = qq[*n], d__4 = qq[*n - 1];
yy = max(d__1,d__2) / xx * min(d__3,d__4);
} else {
xx = 0.;
yy = 0.;
}
q[*n - 1] = *sigma + xx;
q[*n] = yy + *sigma;
*n += -2;
*iconv += 2;
goto L90;
}
/* Updating bounds before going to pong */
if (*iconv == 0) {
*kend = ke;
/* Computing MIN */
d__1 = dm, d__2 = *sup - tau;
*sup = min(d__1,d__2);
} else if (*iconv > 0) {
/* Computing MIN */
d__1 = qq[*n], d__2 = qq[*n - 1], d__1 = min(d__1,d__2), d__2 = qq[*n
- 2], d__1 = min(d__1,d__2), d__1 = min(d__1,qq[1]), d__1 =
min(d__1,qq[2]);
*sup = min(d__1,qq[3]);
if (*iconv == 1) {
*kend = k1end;
} else if (*iconv == 2) {
*kend = k2end;
} else {
*kend = *n;
}
icnt = 0;
maxit = *n * 100;
}
/* Checking for splitting in ping */
lsplit = FALSE_;
for (ks = *n - 3; ks >= 3; --ks) {
if (ee[ks] <= toly) {
/* Computing MIN */
d__1 = qq[ks + 1], d__2 = qq[ks];
/* Computing MIN */
d__3 = qq[ks + 1], d__4 = qq[ks];
if (ee[ks] * (min(d__1,d__2) / (min(d__3,d__4) + *sigma)) <= tolx)
{
lsplit = TRUE_;
goto L110;
}
}
/* L100: */
}
ks = 2;
if (ee[2] <= tolz) {
lsplit = TRUE_;
} else if (*sigma > 0.) {
t1 = *sigma + ee[1] * (*sigma / (*sigma + qq[1]));
if (ee[2] * (t1 / (qq[1] + t1)) <= toly) {
if (ee[2] * (qq[1] / (qq[1] + t1)) <= tolx) {
lsplit = TRUE_;
}
}
} else {
if (ee[2] <= qq[1] / (qq[1] + ee[1] + qq[2]) * qq[2] * *tol2) {
lsplit = TRUE_;
}
}
if (lsplit) {
goto L110;
}
ks = 1;
if (ee[1] <= tolz) {
lsplit = TRUE_;
} else if (*sigma > 0.) {
if (ee[1] <= *eps * (*sigma + qq[1])) {
if (ee[1] * (qq[1] / (qq[1] + *sigma)) <= *tol2 * (qq[1] + *sigma)
) {
lsplit = TRUE_;
}
}
} else {
if (ee[1] <= qq[1] * *tol2) {
lsplit = TRUE_;
}
}
L110:
if (lsplit) {
/* Computing MIN */
d__1 = qq[*n], d__2 = qq[*n - 1], d__1 = min(d__1,d__2), d__2 = qq[*n
- 2];
*sup = min(d__1,d__2);
isp = -(*off + 1);
*off += ks;
*n -= ks;
/* Computing MAX */
i__1 = 1, i__2 = *kend - ks;
*kend = max(i__1,i__2);
e[ks] = *sigma;
ee[ks] = (doublereal) isp;
*iconv = 0;
return 0;
}
/* Coincidence */
if (tau == 0. && dm <= tolz && *kend != *n && *iconv == 0 && icnt > 0) {
i__1 = *n - ke;
dcopy_(&i__1, &e[ke], &c__1, &qq[ke], &c__1);
qq[*n] = 0.;
i__1 = *n - ke;
dcopy_(&i__1, &q[ke + 1], &c__1, &ee[ke], &c__1);
*sup = 0.;
}
*iconv = 0;
goto L130;
/* A new shift when the previous failed (in ping) */
L120:
++ifl;
*sup = tau;
/* SUP is small or */
/* Too many bad shifts (ping) */
if (*sup <= tolz || ifl >= 2) {
tau = 0.;
goto L40;
/* The asymptotic shift (in ping) */
} else {
/* Computing MAX */
d__1 = tau + d__;
tau = max(d__1,0.);
if (tau <= tolz) {
tau = 0.;
}
goto L40;
}
/* the pong section of the code */
L130:
ifl = 0;
/* Compute the shift (in pong) */
if (*kend == 0 && *sup == 0.) {
tau = 0.;
} else if (icnt > 0 && dm <= tolz) {
tau = 0.;
} else {
/* Computing MAX */
i__1 = 5, i__2 = *n / 32;
ip = max(i__1,i__2);
n2 = (ip << 1) + 1;
if (n2 >= *n) {
n1 = 1;
n2 = *n;
} else if (*kend + ip > *n) {
n1 = *n - (ip << 1);
} else if (*kend - ip < 1) {
n1 = 1;
} else {
n1 = *kend - ip;
}
dlasq4_(&n2, &qq[n1], &ee[n1], &tau, sup);
}
L140:
++icnt;
if (icnt > maxit) {
*sup = -(*sup);
return 0;
}
if (tau == 0.) {
/* The dqd algorithm (in pong) */
d__ = qq[1];
dm = d__;
ke = 0;
i__1 = *n - 3;
for (i__ = 1; i__ <= i__1; ++i__) {
q[i__] = d__ + ee[i__];
d__ = d__ / q[i__] * qq[i__ + 1];
if (dm > d__) {
dm = d__;
ke = i__;
}
/* L150: */
}
++ke;
/* Penultimate dqd step (in pong) */
k2end = ke;
q[*n - 2] = d__ + ee[*n - 2];
d__ = d__ / q[*n - 2] * qq[*n - 1];
if (dm > d__) {
dm = d__;
ke = *n - 1;
}
/* Final dqd step (in pong) */
k1end = ke;
q[*n - 1] = d__ + ee[*n - 1];
d__ = d__ / q[*n - 1] * qq[*n];
if (dm > d__) {
dm = d__;
ke = *n;
}
q[*n] = d__;
} else {
/* The dqds algorithm (in pong) */
d__ = qq[1] - tau;
dm = d__;
ke = 0;
if (d__ < 0.) {
goto L220;
}
i__1 = *n - 3;
for (i__ = 1; i__ <= i__1; ++i__) {
q[i__] = d__ + ee[i__];
d__ = d__ / q[i__] * qq[i__ + 1] - tau;
if (dm > d__) {
dm = d__;
ke = i__;
if (d__ < 0.) {
goto L220;
}
}
/* L160: */
}
++ke;
/* Penultimate dqds step (in pong) */
k2end = ke;
q[*n - 2] = d__ + ee[*n - 2];
d__ = d__ / q[*n - 2] * qq[*n - 1] - tau;
if (dm > d__) {
dm = d__;
ke = *n - 1;
if (d__ < 0.) {
goto L220;
}
}
/* Final dqds step (in pong) */
k1end = ke;
q[*n - 1] = d__ + ee[*n - 1];
d__ = d__ / q[*n - 1] * qq[*n] - tau;
if (dm > d__) {
dm = d__;
ke = *n;
}
q[*n] = d__;
}
/* Convergence when is small (in pong) */
if ((d__1 = q[*n], abs(d__1)) <= *sigma * *tol2) {
q[*n] = 0.;
dm = 0.;
ke = *n;
}
if (q[*n] < 0.) {
goto L220;
}
/* Non-negative qd array: Update the e's */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
e[i__] = ee[i__] / q[i__] * qq[i__ + 1];
/* L170: */
}
/* Updating sigma and iphase in pong */
*sigma += tau;
L180:
*iphase = 1;
tolx = *sigma * *tol2;
toly = *sigma * *eps;
/* Checking for deflation and convergence (in pong) */
L190:
if (*n <= 2) {
return 0;
}
/* Deflation: bottom 1x1 (in pong) */
ldef = FALSE_;
if (e[*n - 1] <= tolz) {
ldef = TRUE_;
} else if (*sigma > 0.) {
if (e[*n - 1] <= *eps * (*sigma + q[*n])) {
if (e[*n - 1] * (q[*n] / (q[*n] + *sigma)) <= *tol2 * (q[*n] + *
sigma)) {
ldef = TRUE_;
}
}
} else {
if (e[*n - 1] <= q[*n] * *tol2) {
ldef = TRUE_;
}
}
if (ldef) {
q[*n] += *sigma;
--(*n);
++(*iconv);
goto L190;
}
/* Deflation: bottom 2x2 (in pong) */
ldef = FALSE_;
if (e[*n - 2] <= tolz) {
ldef = TRUE_;
} else if (*sigma > 0.) {
t1 = *sigma + e[*n - 1] * (*sigma / (*sigma + q[*n]));
if (e[*n - 2] * (t1 / (q[*n - 1] + t1)) <= toly) {
if (e[*n - 2] * (q[*n - 1] / (q[*n - 1] + t1)) <= tolx) {
ldef = TRUE_;
}
}
} else {
if (e[*n - 2] <= q[*n] / (q[*n] + ee[*n - 1] + q[*n - 1]) * q[*n - 1]
* *tol2) {
ldef = TRUE_;
}
}
if (ldef) {
/* Computing MAX */
d__1 = q[*n], d__2 = q[*n - 1], d__1 = max(d__1,d__2), d__2 = e[*n -
1];
qemax = max(d__1,d__2);
if (qemax != 0.) {
if (qemax == q[*n - 1]) {
/* Computing 2nd power */
d__1 = (q[*n] - q[*n - 1] + e[*n - 1]) / qemax;
xx = (q[*n] + q[*n - 1] + e[*n - 1] + qemax * sqrt(d__1 *
d__1 + e[*n - 1] * 4. / qemax)) * .5;
} else if (qemax == q[*n]) {
/* Computing 2nd power */
d__1 = (q[*n - 1] - q[*n] + e[*n - 1]) / qemax;
xx = (q[*n] + q[*n - 1] + e[*n - 1] + qemax * sqrt(d__1 *
d__1 + e[*n - 1] * 4. / qemax)) * .5;
} else {
/* Computing 2nd power */
d__1 = (q[*n] - q[*n - 1] + e[*n - 1]) / qemax;
xx = (q[*n] + q[*n - 1] + e[*n - 1] + qemax * sqrt(d__1 *
d__1 + q[*n - 1] * 4. / qemax)) * .5;
}
/* Computing MAX */
d__1 = q[*n], d__2 = q[*n - 1];
/* Computing MIN */
d__3 = q[*n], d__4 = q[*n - 1];
yy = max(d__1,d__2) / xx * min(d__3,d__4);
} else {
xx = 0.;
yy = 0.;
}
q[*n - 1] = *sigma + xx;
q[*n] = yy + *sigma;
*n += -2;
*iconv += 2;
goto L190;
}
/* Updating bounds before going to pong */
if (*iconv == 0) {
*kend = ke;
/* Computing MIN */
d__1 = dm, d__2 = *sup - tau;
*sup = min(d__1,d__2);
} else if (*iconv > 0) {
/* Computing MIN */
d__1 = q[*n], d__2 = q[*n - 1], d__1 = min(d__1,d__2), d__2 = q[*n -
2], d__1 = min(d__1,d__2), d__1 = min(d__1,q[1]), d__1 = min(
d__1,q[2]);
*sup = min(d__1,q[3]);
if (*iconv == 1) {
*kend = k1end;
} else if (*iconv == 2) {
*kend = k2end;
} else {
*kend = *n;
}
icnt = 0;
maxit = *n * 100;
}
/* Checking for splitting in pong */
lsplit = FALSE_;
for (ks = *n - 3; ks >= 3; --ks) {
if (e[ks] <= toly) {
/* Computing MIN */
d__1 = q[ks + 1], d__2 = q[ks];
/* Computing MIN */
d__3 = q[ks + 1], d__4 = q[ks];
if (e[ks] * (min(d__1,d__2) / (min(d__3,d__4) + *sigma)) <= tolx)
{
lsplit = TRUE_;
goto L210;
}
}
/* L200: */
}
ks = 2;
if (e[2] <= tolz) {
lsplit = TRUE_;
} else if (*sigma > 0.) {
t1 = *sigma + e[1] * (*sigma / (*sigma + q[1]));
if (e[2] * (t1 / (q[1] + t1)) <= toly) {
if (e[2] * (q[1] / (q[1] + t1)) <= tolx) {
lsplit = TRUE_;
}
}
} else {
if (e[2] <= q[1] / (q[1] + e[1] + q[2]) * q[2] * *tol2) {
lsplit = TRUE_;
}
}
if (lsplit) {
goto L210;
}
ks = 1;
if (e[1] <= tolz) {
lsplit = TRUE_;
} else if (*sigma > 0.) {
if (e[1] <= *eps * (*sigma + q[1])) {
if (e[1] * (q[1] / (q[1] + *sigma)) <= *tol2 * (q[1] + *sigma)) {
lsplit = TRUE_;
}
}
} else {
if (e[1] <= q[1] * *tol2) {
lsplit = TRUE_;
}
}
L210:
if (lsplit) {
/* Computing MIN */
d__1 = q[*n], d__2 = q[*n - 1], d__1 = min(d__1,d__2), d__2 = q[*n -
2];
*sup = min(d__1,d__2);
isp = *off + 1;
*off += ks;
/* Computing MAX */
i__1 = 1, i__2 = *kend - ks;
*kend = max(i__1,i__2);
*n -= ks;
e[ks] = *sigma;
ee[ks] = (doublereal) isp;
*iconv = 0;
return 0;
}
/* Coincidence */
if (tau == 0. && dm <= tolz && *kend != *n && *iconv == 0 && icnt > 0) {
i__1 = *n - ke;
dcopy_(&i__1, &ee[ke], &c__1, &q[ke], &c__1);
q[*n] = 0.;
i__1 = *n - ke;
dcopy_(&i__1, &qq[ke + 1], &c__1, &e[ke], &c__1);
*sup = 0.;
}
*iconv = 0;
goto L30;
/* Computation of a new shift when the previous failed (in pong) */
L220:
++ifl;
*sup = tau;
/* SUP is small or */
/* Too many bad shifts (in pong) */
if (*sup <= tolz || ifl >= 2) {
tau = 0.;
goto L140;
/* The asymptotic shift (in pong) */
} else {
/* Computing MAX */
d__1 = tau + d__;
tau = max(d__1,0.);
if (tau <= tolz) {
tau = 0.;
}
goto L140;
}
/* End of DLASQ3 */
} /* dlasq3_ */
/* dormlq.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dormlq_(side, trans, m, n, k, a, lda, tau, c__, ldc,
work, lwork, info, side_len, trans_len)
char *side, *trans;
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *c__;
integer *ldc;
doublereal *work;
integer *lwork, *info;
ftnlen side_len;
ftnlen trans_len;
{
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
i__5;
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_cat();
/* Local variables */
static logical left;
static integer i__;
static doublereal t[4160] /* was [65][64] */;
extern logical lsame_();
static integer nbmin, iinfo, i1, i2, i3;
extern /* Subroutine */ int dorml2_();
static integer ib, ic, jc, nb, mi, ni;
extern /* Subroutine */ int dlarfb_();
static integer nq, nw;
extern /* Subroutine */ int dlarft_(), xerbla_();
extern integer ilaenv_();
static logical notran;
static integer ldwork;
static char transt[1];
static integer iws;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DORMLQ overwrites the general real M-by-N matrix C with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': Q * C C * Q */
/* TRANS = 'T': Q**T * C C * Q**T */
/* where Q is a real orthogonal matrix defined as the product of k */
/* elementary reflectors */
/* Q = H(k) . . . H(2) H(1) */
/* as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N */
/* if SIDE = 'R'. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q or Q**T from the Left; */
/* = 'R': apply Q or Q**T from the Right. */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, apply Q; */
/* = 'T': Transpose, apply Q**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines */
/* the matrix Q. */
/* If SIDE = 'L', M >= K >= 0; */
/* if SIDE = 'R', N >= K >= 0. */
/* A (input) DOUBLE PRECISION 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
*/
/* DGELQF 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) DOUBLE PRECISION array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i), as returned by DGELQF. */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
*/
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
/* NQ is the order of Q and NW is the minimum dimension of WORK */
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! left && ! lsame_(side, "R", 1L, 1L)) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T", 1L, 1L)) {
*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;
} else if (*lwork < max(1,nw)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DORMLQ", &i__1, 6L);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
work[1] = 1.;
return 0;
}
/* Determine the block size. NB may be at most NBMAX, where NBMAX */
/* is used to define the local array T. */
/* Computing MIN */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
i__1 = 64, i__2 = ilaenv_(&c__1, "DORMLQ", ch__1, m, n, k, &c_n1, 6L, 2L);
nb = min(i__1,i__2);
nbmin = 2;
ldwork = nw;
if (nb > 1 && nb < *k) {
iws = nw * nb;
if (*lwork < iws) {
nb = *lwork / ldwork;
/* Computing MAX */
/* Writing concatenation */
i__3[0] = 1, a__1[0] = side;
i__3[1] = 1, a__1[1] = trans;
s_cat(ch__1, a__1, i__3, &c__2, 2L);
i__1 = 2, i__2 = ilaenv_(&c__2, "DORMLQ", ch__1, m, n, k, &c_n1,
6L, 2L);
nbmin = max(i__1,i__2);
}
} else {
iws = nw;
}
if (nb < nbmin || nb >= *k) {
/* Use unblocked code */
dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], &iinfo, 1L, 1L);
} else {
/* Use blocked code */
if (left && notran || ! left && ! notran) {
i1 = 1;
i2 = *k;
i3 = nb;
} else {
i1 = (*k - 1) / nb * nb + 1;
i2 = 1;
i3 = -nb;
}
if (left) {
ni = *n;
jc = 1;
} else {
mi = *m;
ic = 1;
}
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__4 = nb, i__5 = *k - i__ + 1;
ib = min(i__4,i__5);
/* Form the triangular factor of the block reflector */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__4 = nq - i__ + 1;
dlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1],
lda, &tau[i__], t, &c__65, 7L, 7L);
if (left) {
/* H or H' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H or H' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H or H' */
dlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__
+ i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1],
ldc, &work[1], &ldwork, 1L, 1L, 7L, 7L);
/* L10: */
}
}
work[1] = (doublereal) iws;
return 0;
/* End of DORMLQ */
} /* dormlq_ */
/* dlarf.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b4
#undef c_b4
#endif
#define c_b4 c_b4
#ifdef c_b5
#undef c_b5
#endif
#define c_b5 c_b5a
/* Subroutine */ int dlarf_(side, m, n, v, incv, tau, c__, ldc, work,
side_len)
char *side;
integer *m, *n;
doublereal *v;
integer *incv;
doublereal *tau, *c__;
integer *ldc;
doublereal *work;
ftnlen side_len;
{
/* System generated locals */
integer c_dim1, c_offset;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_();
extern logical lsame_();
extern /* Subroutine */ int dgemv_();
/* -- LAPACK auxiliary routine (version 2.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 */
/* ======= */
/* DLARF 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. */
/* 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) DOUBLE PRECISION array, dimension */
/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
/* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
/* The vector v in the representation of H. V is not used if */
/* TAU = 0. */
/* INCV (input) INTEGER */
/* The increment between elements of v. INCV <> 0. */
/* TAU (input) DOUBLE PRECISION */
/* The value tau in the representation of H. */
/* C (input/output) DOUBLE PRECISION 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. LDC >= max(1,M). */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C */
if (*tau != 0.) {
/* w := C' * v */
dgemv_("Transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], incv,
&c_b5, &work[1], &c__1, 9L);
/* C := C - v * w' */
d__1 = -(*tau);
dger_(m, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset],
ldc);
}
} else {
/* Form C * H */
if (*tau != 0.) {
/* w := C * v */
dgemv_("No transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1],
incv, &c_b5, &work[1], &c__1, 12L);
/* C := C - w * v' */
d__1 = -(*tau);
dger_(m, n, &d__1, &work[1], &c__1, &v[1], incv, &c__[c_offset],
ldc);
}
}
return 0;
/* End of DLARF */
} /* dlarf_ */
/* dormbr.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dormbr_(vect, side, trans, m, n, k, a, lda, tau, c__,
ldc, work, lwork, info, vect_len, side_len, trans_len)
char *vect, *side, *trans;
integer *m, *n, *k;
doublereal *a;
integer *lda;
doublereal *tau, *c__;
integer *ldc;
doublereal *work;
integer *lwork, *info;
ftnlen vect_len;
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 logical left;
extern logical lsame_();
static integer iinfo, i1, i2, mi, ni, nq, nw;
extern /* Subroutine */ int xerbla_(), dormlq_();
static logical notran;
extern /* Subroutine */ int dormqr_();
static logical applyq;
static char transt[1];
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C */
/* with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': Q * C C * Q */
/* TRANS = 'T': Q**T * C C * Q**T */
/* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C */
/* with */
/* SIDE = 'L' SIDE = 'R' */
/* TRANS = 'N': P * C C * P */
/* TRANS = 'T': P**T * C C * P**T */
/* Here Q and P**T are the orthogonal matrices determined by DGEBRD when
*/
/* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
*/
/* P**T are defined as products of elementary reflectors H(i) and G(i) */
/* respectively. */
/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */
/* order of the orthogonal matrix Q or P**T that is applied. */
/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */
/* if nq >= k, Q = H(1) H(2) . . . H(k); */
/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */
/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */
/* if k < nq, P = G(1) G(2) . . . G(k); */
/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */
/* Arguments */
/* ========= */
/* VECT (input) CHARACTER*1 */
/* = 'Q': apply Q or Q**T; */
/* = 'P': apply P or P**T. */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply Q, Q**T, P or P**T from the Left; */
/* = 'R': apply Q, Q**T, P or P**T from the Right. */
/* TRANS (input) CHARACTER*1 */
/* = 'N': No transpose, apply Q or P; */
/* = 'T': Transpose, apply Q**T or P**T. */
/* M (input) INTEGER */
/* The number of rows of the matrix C. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. N >= 0. */
/* K (input) INTEGER */
/* If VECT = 'Q', the number of columns in the original */
/* matrix reduced by DGEBRD. */
/* If VECT = 'P', the number of rows in the original */
/* matrix reduced by DGEBRD. */
/* K >= 0. */
/* A (input) DOUBLE PRECISION array, dimension */
/* (LDA,min(nq,K)) if VECT = 'Q' */
/* (LDA,nq) if VECT = 'P' */
/* The vectors which define the elementary reflectors H(i) and */
/* G(i), whose products determine the matrices Q and P, as */
/* returned by DGEBRD. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If VECT = 'Q', LDA >= max(1,nq); */
/* if VECT = 'P', LDA >= max(1,min(nq,K)). */
/* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i) or G(i) which determines Q or P, as returned */
/* by DGEBRD in the array argument TAUQ or TAUP. */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q */
/* or P*C or P**T*C or C*P or C*P**T. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If SIDE = 'L', LWORK >= max(1,N); */
/* if SIDE = 'R', LWORK >= max(1,M). */
/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
/* blocksize. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--tau;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
applyq = lsame_(vect, "Q", 1L, 1L);
left = lsame_(side, "L", 1L, 1L);
notran = lsame_(trans, "N", 1L, 1L);
/* NQ is the order of Q or P and NW is the minimum dimension of WORK
*/
if (left) {
nq = *m;
nw = *n;
} else {
nq = *n;
nw = *m;
}
if (! applyq && ! lsame_(vect, "P", 1L, 1L)) {
*info = -1;
} else if (! left && ! lsame_(side, "R", 1L, 1L)) {
*info = -2;
} else if (! notran && ! lsame_(trans, "T", 1L, 1L)) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*k < 0) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = min(nq,*k);
if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -11;
} else if (*lwork < max(1,nw)) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DORMBR", &i__1, 6L);
return 0;
}
/* Quick return if possible */
work[1] = 1.;
if (*m == 0 || *n == 0) {
return 0;
}
if (applyq) {
/* Apply Q */
if (nq >= *k) {
/* Q was determined by a call to DGEBRD with nq >= k */
dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], lwork, &iinfo, 1L, 1L);
} else if (nq > 1) {
/* Q was determined by a call to DGEBRD with nq < k */
if (left) {
mi = *m - 1;
ni = *n;
i1 = 2;
i2 = 1;
} else {
mi = *m;
ni = *n - 1;
i1 = 1;
i2 = 2;
}
i__1 = nq - 1;
dormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1]
, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo,
1L, 1L);
}
} else {
/* Apply P */
if (notran) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
if (nq > *k) {
/* P was determined by a call to DGEBRD with nq > k */
dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[
c_offset], ldc, &work[1], lwork, &iinfo, 1L, 1L);
} else if (nq > 1) {
/* P was determined by a call to DGEBRD with nq <= k */
if (left) {
mi = *m - 1;
ni = *n;
i1 = 2;
i2 = 1;
} else {
mi = *m;
ni = *n - 1;
i1 = 1;
i2 = 2;
}
i__1 = nq - 1;
dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda,
&tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &
iinfo, 1L, 1L);
}
}
return 0;
/* End of DORMBR */
} /* dormbr_ */
/* dlaln2.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Subroutine */ int dlaln2_(ltrans, na, nw, smin, ca, a, lda, d1, d2, b, ldb,
wr, wi, x, ldx, scale, xnorm, info)
logical *ltrans;
integer *na, *nw;
doublereal *smin, *ca, *a;
integer *lda;
doublereal *d1, *d2, *b;
integer *ldb;
doublereal *wr, *wi, *x;
integer *ldx;
doublereal *scale, *xnorm;
integer *info;
{
/* Initialized data */
static logical zswap[4] = { FALSE_,FALSE_,TRUE_,TRUE_ };
static logical rswap[4] = { FALSE_,TRUE_,FALSE_,TRUE_ };
static integer ipivot[16] /* was [4][4] */ = { 1,2,3,4,2,1,4,3,3,4,1,2,
4,3,2,1 };
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
static doublereal equiv_0[4], equiv_1[4];
/* Local variables */
static doublereal bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s;
static integer j;
static doublereal u22abs;
static integer icmax;
static doublereal bnorm, cnorm, smini;
#define ci (equiv_0)
#define cr (equiv_1)
extern doublereal dlamch_();
extern /* Subroutine */ int dladiv_();
static doublereal bignum, bi1, bi2, br1, br2, smlnum, xi1, xi2, xr1, xr2,
ci21, ci22, cr21, cr22, li21, csi, ui11, lr21, ui12, ui22;
#define civ (equiv_0)
static doublereal csr, ur11, ur12, ur22;
#define crv (equiv_1)
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLALN2 solves a system of the form (ca A - w D ) X = s B */
/* or (ca A' - w D) X = s B with possible scaling ("s") and */
/* perturbation of A. (A' means A-transpose.) */
/* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA */
/* real diagonal matrix, w is a real or complex value, and X and B are */
/* NA x 1 matrices -- real if w is real, complex if w is complex. NA */
/* may be 1 or 2. */
/* If w is complex, X and B are represented as NA x 2 matrices, */
/* the first column of each being the real part and the second */
/* being the imaginary part. */
/* "s" is a scaling factor (.LE. 1), computed by DLALN2, which is */
/* so chosen that X can be computed without overflow. X is further */
/* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less */
/* than overflow. */
/* If both singular values of (ca A - w D) are less than SMIN, */
/* SMIN*identity will be used instead of (ca A - w D). If only one */
/* singular value is less than SMIN, one element of (ca A - w D) will be
*/
/* perturbed enough to make the smallest singular value roughly SMIN. */
/* If both singular values are at least SMIN, (ca A - w D) will not be */
/* perturbed. In any case, the perturbation will be at most some small
*/
/* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values */
/* are computed by infinity-norm approximations, and thus will only be */
/* correct to a factor of 2 or so. */
/* Note: all input quantities are assumed to be smaller than overflow */
/* by a reasonable factor. (See BIGNUM.) */
/* Arguments */
/* ========== */
/* LTRANS (input) LOGICAL */
/* =.TRUE.: A-transpose will be used. */
/* =.FALSE.: A will be used (not transposed.) */
/* NA (input) INTEGER */
/* The size of the matrix A. It may (only) be 1 or 2. */
/* NW (input) INTEGER */
/* 1 if "w" is real, 2 if "w" is complex. It may only be 1 */
/* or 2. */
/* SMIN (input) DOUBLE PRECISION */
/* The desired lower bound on the singular values of A. This */
/* should be a safe distance away from underflow or overflow, */
/* say, between (underflow/machine precision) and (machine */
/* precision * overflow ). (See BIGNUM and ULP.) */
/* CA (input) DOUBLE PRECISION */
/* The coefficient c, which A is multiplied by. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,NA) */
/* The NA x NA matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least NA. */
/* D1 (input) DOUBLE PRECISION */
/* The 1,1 element in the diagonal matrix D. */
/* D2 (input) DOUBLE PRECISION */
/* The 2,2 element in the diagonal matrix D. Not used if NW=1.
*/
/* B (input) DOUBLE PRECISION array, dimension (LDB,NW) */
/* The NA x NW matrix B (right-hand side). If NW=2 ("w" is */
/* complex), column 1 contains the real part of B and column 2 */
/* contains the imaginary part. */
/* LDB (input) INTEGER */
/* The leading dimension of B. It must be at least NA. */
/* WR (input) DOUBLE PRECISION */
/* The real part of the scalar "w". */
/* WI (input) DOUBLE PRECISION */
/* The imaginary part of the scalar "w". Not used if NW=1. */
/* X (output) DOUBLE PRECISION array, dimension (LDX,NW) */
/* The NA x NW matrix X (unknowns), as computed by DLALN2. */
/* If NW=2 ("w" is complex), on exit, column 1 will contain */
/* the real part of X and column 2 will contain the imaginary */
/* part. */
/* LDX (input) INTEGER */
/* The leading dimension of X. It must be at least NA. */
/* SCALE (output) DOUBLE PRECISION */
/* The scale factor that B must be multiplied by to insure */
/* that overflow does not occur when computing X. Thus, */
/* (ca A - w D) X will be SCALE*B, not B (ignoring */
/* perturbations of A.) It will be at most 1. */
/* XNORM (output) DOUBLE PRECISION */
/* The infinity-norm of X, when X is regarded as an NA x NW */
/* real matrix. */
/* INFO (output) INTEGER */
/* An error flag. It will be set to zero if no error occurs, */
/* a negative number if an argument is in error, or a positive */
/* number if ca A - w D had to be perturbed. */
/* The possible values are: */
/* = 0: No error occurred, and (ca A - w D) did not have to be */
/* perturbed. */
/* = 1: (ca A - w D) had to be perturbed to make its smallest */
/* (or only) singular value greater than SMIN. */
/* NOTE: In the interests of speed, this routine does not */
/* check the inputs for errors. */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Equivalences .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = b_dim1 + 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = x_dim1 + 1;
x -= x_offset;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Compute BIGNUM */
smlnum = dlamch_("Safe minimum", 12L) * 2.;
bignum = 1. / smlnum;
smini = max(*smin,smlnum);
/* Don't check for input errors */
*info = 0;
/* Standard Initializations */
*scale = 1.;
if (*na == 1) {
/* 1 x 1 (i.e., scalar) system C X = B */
if (*nw == 1) {
/* Real 1x1 system. */
/* C = ca A - w D */
csr = *ca * a[a_dim1 + 1] - *wr * *d1;
cnorm = abs(csr);
/* If | C | < SMINI, use C = SMINI */
if (cnorm < smini) {
csr = smini;
cnorm = smini;
*info = 1;
}
/* Check scaling for X = B / C */
bnorm = (d__1 = b[b_dim1 + 1], abs(d__1));
if (cnorm < 1. && bnorm > 1.) {
if (bnorm > bignum * cnorm) {
*scale = 1. / bnorm;
}
}
/* Compute X */
x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr;
*xnorm = (d__1 = x[x_dim1 + 1], abs(d__1));
} else {
/* Complex 1x1 system (w is complex) */
/* C = ca A - w D */
csr = *ca * a[a_dim1 + 1] - *wr * *d1;
csi = -(*wi) * *d1;
cnorm = abs(csr) + abs(csi);
/* If | C | < SMINI, use C = SMINI */
if (cnorm < smini) {
csr = smini;
csi = 0.;
cnorm = smini;
*info = 1;
}
/* Check scaling for X = B / C */
bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 <<
1) + 1], abs(d__2));
if (cnorm < 1. && bnorm > 1.) {
if (bnorm > bignum * cnorm) {
*scale = 1. / bnorm;
}
}
/* Compute X */
d__1 = *scale * b[b_dim1 + 1];
d__2 = *scale * b[(b_dim1 << 1) + 1];
dladiv_(&d__1, &d__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1)
+ 1]);
*xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 <<
1) + 1], abs(d__2));
}
} else {
/* 2x2 System */
/* Compute the real part of C = ca A - w D (or ca A' - w D )
*/
cr[0] = *ca * a[a_dim1 + 1] - *wr * *d1;
cr[3] = *ca * a[(a_dim1 << 1) + 2] - *wr * *d2;
if (*ltrans) {
cr[2] = *ca * a[a_dim1 + 2];
cr[1] = *ca * a[(a_dim1 << 1) + 1];
} else {
cr[1] = *ca * a[a_dim1 + 2];
cr[2] = *ca * a[(a_dim1 << 1) + 1];
}
if (*nw == 1) {
/* Real 2x2 system (w is real) */
/* Find the largest element in C */
cmax = 0.;
icmax = 0;
for (j = 1; j <= 4; ++j) {
if ((d__1 = crv[j - 1], abs(d__1)) > cmax) {
cmax = (d__1 = crv[j - 1], abs(d__1));
icmax = j;
}
/* L10: */
}
/* If norm(C) < SMINI, use SMINI*identity. */
if (cmax < smini) {
/* Computing MAX */
d__3 = (d__1 = b[b_dim1 + 1], abs(d__1)), d__4 = (d__2 = b[
b_dim1 + 2], abs(d__2));
bnorm = max(d__3,d__4);
if (smini < 1. && bnorm > 1.) {
if (bnorm > bignum * smini) {
*scale = 1. / bnorm;
}
}
temp = *scale / smini;
x[x_dim1 + 1] = temp * b[b_dim1 + 1];
x[x_dim1 + 2] = temp * b[b_dim1 + 2];
*xnorm = temp * bnorm;
*info = 1;
return 0;
}
/* Gaussian elimination with complete pivoting. */
ur11 = crv[icmax - 1];
cr21 = crv[ipivot[(icmax << 2) - 3] - 1];
ur12 = crv[ipivot[(icmax << 2) - 2] - 1];
cr22 = crv[ipivot[(icmax << 2) - 1] - 1];
ur11r = 1. / ur11;
lr21 = ur11r * cr21;
ur22 = cr22 - ur12 * lr21;
/* If smaller pivot < SMINI, use SMINI */
if (abs(ur22) < smini) {
ur22 = smini;
*info = 1;
}
if (rswap[icmax - 1]) {
br1 = b[b_dim1 + 2];
br2 = b[b_dim1 + 1];
} else {
br1 = b[b_dim1 + 1];
br2 = b[b_dim1 + 2];
}
br2 -= lr21 * br1;
/* Computing MAX */
d__2 = (d__1 = br1 * (ur22 * ur11r), abs(d__1)), d__3 = abs(br2);
bbnd = max(d__2,d__3);
if (bbnd > 1. && abs(ur22) < 1.) {
if (bbnd >= bignum * abs(ur22)) {
*scale = 1. / bbnd;
}
}
xr2 = br2 * *scale / ur22;
xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12);
if (zswap[icmax - 1]) {
x[x_dim1 + 1] = xr2;
x[x_dim1 + 2] = xr1;
} else {
x[x_dim1 + 1] = xr1;
x[x_dim1 + 2] = xr2;
}
/* Computing MAX */
d__1 = abs(xr1), d__2 = abs(xr2);
*xnorm = max(d__1,d__2);
/* Further scaling if norm(A) norm(X) > overflow */
if (*xnorm > 1. && cmax > 1.) {
if (*xnorm > bignum / cmax) {
temp = cmax / bignum;
x[x_dim1 + 1] = temp * x[x_dim1 + 1];
x[x_dim1 + 2] = temp * x[x_dim1 + 2];
*xnorm = temp * *xnorm;
*scale = temp * *scale;
}
}
} else {
/* Complex 2x2 system (w is complex) */
/* Find the largest element in C */
ci[0] = -(*wi) * *d1;
ci[1] = 0.;
ci[2] = 0.;
ci[3] = -(*wi) * *d2;
cmax = 0.;
icmax = 0;
for (j = 1; j <= 4; ++j) {
if ((d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1], abs(
d__2)) > cmax) {
cmax = (d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1]
, abs(d__2));
icmax = j;
}
/* L20: */
}
/* If norm(C) < SMINI, use SMINI*identity. */
if (cmax < smini) {
/* Computing MAX */
d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1
<< 1) + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2],
abs(d__3)) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4));
bnorm = max(d__5,d__6);
if (smini < 1. && bnorm > 1.) {
if (bnorm > bignum * smini) {
*scale = 1. / bnorm;
}
}
temp = *scale / smini;
x[x_dim1 + 1] = temp * b[b_dim1 + 1];
x[x_dim1 + 2] = temp * b[b_dim1 + 2];
x[(x_dim1 << 1) + 1] = temp * b[(b_dim1 << 1) + 1];
x[(x_dim1 << 1) + 2] = temp * b[(b_dim1 << 1) + 2];
*xnorm = temp * bnorm;
*info = 1;
return 0;
}
/* Gaussian elimination with complete pivoting. */
ur11 = crv[icmax - 1];
ui11 = civ[icmax - 1];
cr21 = crv[ipivot[(icmax << 2) - 3] - 1];
ci21 = civ[ipivot[(icmax << 2) - 3] - 1];
ur12 = crv[ipivot[(icmax << 2) - 2] - 1];
ui12 = civ[ipivot[(icmax << 2) - 2] - 1];
cr22 = crv[ipivot[(icmax << 2) - 1] - 1];
ci22 = civ[ipivot[(icmax << 2) - 1] - 1];
if (icmax == 1 || icmax == 4) {
/* Code when off-diagonals of pivoted C are real
*/
if (abs(ur11) > abs(ui11)) {
temp = ui11 / ur11;
/* Computing 2nd power */
d__1 = temp;
ur11r = 1. / (ur11 * (d__1 * d__1 + 1.));
ui11r = -temp * ur11r;
} else {
temp = ur11 / ui11;
/* Computing 2nd power */
d__1 = temp;
ui11r = -1. / (ui11 * (d__1 * d__1 + 1.));
ur11r = -temp * ui11r;
}
lr21 = cr21 * ur11r;
li21 = cr21 * ui11r;
ur12s = ur12 * ur11r;
ui12s = ur12 * ui11r;
ur22 = cr22 - ur12 * lr21;
ui22 = ci22 - ur12 * li21;
} else {
/* Code when diagonals of pivoted C are real */
ur11r = 1. / ur11;
ui11r = 0.;
lr21 = cr21 * ur11r;
li21 = ci21 * ur11r;
ur12s = ur12 * ur11r;
ui12s = ui12 * ur11r;
ur22 = cr22 - ur12 * lr21 + ui12 * li21;
ui22 = -ur12 * li21 - ui12 * lr21;
}
u22abs = abs(ur22) + abs(ui22);
/* If smaller pivot < SMINI, use SMINI */
if (u22abs < smini) {
ur22 = smini;
ui22 = 0.;
*info = 1;
}
if (rswap[icmax - 1]) {
br2 = b[b_dim1 + 1];
br1 = b[b_dim1 + 2];
bi2 = b[(b_dim1 << 1) + 1];
bi1 = b[(b_dim1 << 1) + 2];
} else {
br1 = b[b_dim1 + 1];
br2 = b[b_dim1 + 2];
bi1 = b[(b_dim1 << 1) + 1];
bi2 = b[(b_dim1 << 1) + 2];
}
br2 = br2 - lr21 * br1 + li21 * bi1;
bi2 = bi2 - li21 * br1 - lr21 * bi1;
/* Computing MAX */
d__1 = (abs(br1) + abs(bi1)) * (u22abs * (abs(ur11r) + abs(ui11r))
), d__2 = abs(br2) + abs(bi2);
bbnd = max(d__1,d__2);
if (bbnd > 1. && u22abs < 1.) {
if (bbnd >= bignum * u22abs) {
*scale = 1. / bbnd;
br1 = *scale * br1;
bi1 = *scale * bi1;
br2 = *scale * br2;
bi2 = *scale * bi2;
}
}
dladiv_(&br2, &bi2, &ur22, &ui22, &xr2, &xi2);
xr1 = ur11r * br1 - ui11r * bi1 - ur12s * xr2 + ui12s * xi2;
xi1 = ui11r * br1 + ur11r * bi1 - ui12s * xr2 - ur12s * xi2;
if (zswap[icmax - 1]) {
x[x_dim1 + 1] = xr2;
x[x_dim1 + 2] = xr1;
x[(x_dim1 << 1) + 1] = xi2;
x[(x_dim1 << 1) + 2] = xi1;
} else {
x[x_dim1 + 1] = xr1;
x[x_dim1 + 2] = xr2;
x[(x_dim1 << 1) + 1] = xi1;
x[(x_dim1 << 1) + 2] = xi2;
}
/* Computing MAX */
d__1 = abs(xr1) + abs(xi1), d__2 = abs(xr2) + abs(xi2);
*xnorm = max(d__1,d__2);
/* Further scaling if norm(A) norm(X) > overflow */
if (*xnorm > 1. && cmax > 1.) {
if (*xnorm > bignum / cmax) {
temp = cmax / bignum;
x[x_dim1 + 1] = temp * x[x_dim1 + 1];
x[x_dim1 + 2] = temp * x[x_dim1 + 2];
x[(x_dim1 << 1) + 1] = temp * x[(x_dim1 << 1) + 1];
x[(x_dim1 << 1) + 2] = temp * x[(x_dim1 << 1) + 2];
*xnorm = temp * *xnorm;
*scale = temp * *scale;
}
}
}
}
return 0;
/* End of DLALN2 */
} /* dlaln2_ */
#undef crv
#undef civ
#undef cr
#undef ci
/* dlarfb.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b14
#undef c_b14
#endif
#define c_b14 c_b14
#ifdef c_b25
#undef c_b25
#endif
#define c_b25 c_b25
/* Subroutine */ int dlarfb_(side, trans, direct, storev, m, n, k, v, ldv, t,
ldt, c__, ldc, work, ldwork, side_len, trans_len, direct_len,
storev_len)
char *side, *trans, *direct, *storev;
integer *m, *n, *k;
doublereal *v;
integer *ldv;
doublereal *t;
integer *ldt;
doublereal *c__;
integer *ldc;
doublereal *work;
integer *ldwork;
ftnlen side_len;
ftnlen trans_len;
ftnlen direct_len;
ftnlen storev_len;
{
/* System generated locals */
integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
work_offset, i__1, i__2;
/* Local variables */
static integer i__, j;
extern /* Subroutine */ int dgemm_();
extern logical lsame_();
extern /* Subroutine */ int dcopy_(), dtrmm_();
static char transt[1];
/* -- LAPACK auxiliary routine (version 2.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 */
/* ======= */
/* DLARFB applies a real block reflector H or its transpose H' to a */
/* real m by n matrix C, from either the left or the right. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': apply H or H' from the Left */
/* = 'R': apply H or H' from the Right */
/* TRANS (input) CHARACTER*1 */
/* = 'N': apply H (No transpose) */
/* = 'T': apply H' (Transpose) */
/* DIRECT (input) CHARACTER*1 */
/* Indicates how H is formed from a product of elementary */
/* reflectors */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Indicates how the vectors which define the elementary */
/* reflectors are stored: */
/* = 'C': Columnwise */
/* = 'R': Rowwise */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* K (input) INTEGER */
/* The order of the matrix T (= the number of elementary */
/* reflectors whose product defines the block reflector). */
/* V (input) DOUBLE PRECISION array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,M) if STOREV = 'R' and SIDE = 'L'
*/
/* (LDV,N) if STOREV = 'R' and SIDE = 'R'
*/
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
/* if STOREV = 'R', LDV >= K. */
/* T (input) DOUBLE PRECISION array, dimension (LDT,K) */
/* The triangular k by k matrix T in the representation of the */
/* block reflector. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
/* On entry, the m by n matrix C. */
/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDA >= max(1,M). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. */
/* If SIDE = 'L', LDWORK >= max(1,N); */
/* if SIDE = 'R', LDWORK >= max(1,M). */
/* =====================================================================
*/
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = v_dim1 + 1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = t_dim1 + 1;
t -= t_offset;
c_dim1 = *ldc;
c_offset = c_dim1 + 1;
c__ -= c_offset;
work_dim1 = *ldwork;
work_offset = work_dim1 + 1;
work -= work_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (lsame_(trans, "N", 1L, 1L)) {
*(unsigned char *)transt = 'T';
} else {
*(unsigned char *)transt = 'N';
}
if (lsame_(storev, "C", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
/* Let V = ( V1 ) (first K rows) */
/* ( V2 ) */
/* where V1 is unit lower triangular. */
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C' * V = (C1'*V1 + C2'*V2) (stored in
WORK) */
/* W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
&c__1);
/* L10: */
}
/* W := W * V1 */
dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14,
&v[v_offset], ldv, &work[work_offset], ldwork, 5L,
5L, 12L, 4L);
if (*m > *k) {
/* W := W + C2'*V2 */
i__1 = *m - *k;
dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, &
c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1],
ldv, &c_b14, &work[work_offset], ldwork, 9L, 12L);
}
/* W := W * T' or W * T */
dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - V * W' */
if (*m > *k) {
/* C2 := C2 - V2 * W' */
i__1 = *m - *k;
dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, &
v[*k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, 12L,
9L);
}
/* W := W * V1' */
dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, &
v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L,
9L, 4L);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
/* L20: */
}
/* L30: */
}
} else if (lsame_(side, "R", 1L, 1L)) {
/* Form C * H or C * H' where C = ( C1 C2 )
*/
/* W := C * V = (C1*V1 + C2*V2) (stored in WOR
K) */
/* W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1);
/* L40: */
}
/* W := W * V1 */
dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14,
&v[v_offset], ldv, &work[work_offset], ldwork, 5L,
5L, 12L, 4L);
if (*n > *k) {
/* W := W + C2 * V2 */
i__1 = *n - *k;
dgemm_("No transpose", "No transpose", m, k, &i__1, &
c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k +
1 + v_dim1], ldv, &c_b14, &work[work_offset],
ldwork, 12L, 12L);
}
/* W := W * T or W * T' */
dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - W * V' */
if (*n > *k) {
/* C2 := C2 - W * V2' */
i__1 = *n - *k;
dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, &
work[work_offset], ldwork, &v[*k + 1 + v_dim1],
ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc,
12L, 9L);
}
/* W := W * V1' */
dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, &
v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L,
9L, 4L);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
/* L50: */
}
/* L60: */
}
}
} else {
/* Let V = ( V1 ) */
/* ( V2 ) (last K rows) */
/* where V2 is unit upper triangular. */
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C' * V = (C1'*V1 + C2'*V2) (stored in
WORK) */
/* W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j *
work_dim1 + 1], &c__1);
/* L70: */
}
/* W := W * V2 */
dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14,
&v[*m - *k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, 5L, 5L, 12L, 4L);
if (*m > *k) {
/* W := W + C1'*V1 */
i__1 = *m - *k;
dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, &
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
work[work_offset], ldwork, 9L, 12L);
}
/* W := W * T' or W * T */
dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - V * W' */
if (*m > *k) {
/* C1 := C1 - V1 * W' */
i__1 = *m - *k;
dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, &
v[v_offset], ldv, &work[work_offset], ldwork, &
c_b14, &c__[c_offset], ldc, 12L, 9L);
}
/* W := W * V2' */
dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, &
v[*m - *k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, 5L, 5L, 9L, 4L);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j *
work_dim1];
/* L80: */
}
/* L90: */
}
} else if (lsame_(side, "R", 1L, 1L)) {
/* Form C * H or C * H' where C = ( C1 C2 )
*/
/* W := C * V = (C1*V1 + C2*V2) (stored in WOR
K) */
/* W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
j * work_dim1 + 1], &c__1);
/* L100: */
}
/* W := W * V2 */
dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14,
&v[*n - *k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, 5L, 5L, 12L, 4L);
if (*n > *k) {
/* W := W + C1 * V1 */
i__1 = *n - *k;
dgemm_("No transpose", "No transpose", m, k, &i__1, &
c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b14, &work[work_offset], ldwork, 12L, 12L);
}
/* W := W * T or W * T' */
dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - W * V' */
if (*n > *k) {
/* C1 := C1 - W * V1' */
i__1 = *n - *k;
dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, &
work[work_offset], ldwork, &v[v_offset], ldv, &
c_b14, &c__[c_offset], ldc, 12L, 9L);
}
/* W := W * V2' */
dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, &
v[*n - *k + 1 + v_dim1], ldv, &work[work_offset],
ldwork, 5L, 5L, 9L, 4L);
/* C2 := C2 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j *
work_dim1];
/* L110: */
}
/* L120: */
}
}
}
} else if (lsame_(storev, "R", 1L, 1L)) {
if (lsame_(direct, "F", 1L, 1L)) {
/* Let V = ( V1 V2 ) (V1: first K columns) */
/* where V1 is unit upper triangular. */
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C' * V' = (C1'*V1' + C2'*V2') (stored i
n WORK) */
/* W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1],
&c__1);
/* L130: */
}
/* W := W * V1' */
dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, &
v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L,
9L, 4L);
if (*m > *k) {
/* W := W + C2'*V2' */
i__1 = *m - *k;
dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, &
c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 +
1], ldv, &c_b14, &work[work_offset], ldwork, 9L,
9L);
}
/* W := W * T' or W * T */
dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - V' * W' */
if (*m > *k) {
/* C2 := C2 - V2' * W' */
i__1 = *m - *k;
dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[(
*k + 1) * v_dim1 + 1], ldv, &work[work_offset],
ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc, 9L,
9L);
}
/* W := W * V1 */
dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14,
&v[v_offset], ldv, &work[work_offset], ldwork, 5L,
5L, 12L, 4L);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
/* L140: */
}
/* L150: */
}
} else if (lsame_(side, "R", 1L, 1L)) {
/* Form C * H or C * H' where C = ( C1 C2 )
*/
/* W := C * V' = (C1*V1' + C2*V2') (stored in
WORK) */
/* W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j *
work_dim1 + 1], &c__1);
/* L160: */
}
/* W := W * V1' */
dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, &
v[v_offset], ldv, &work[work_offset], ldwork, 5L, 5L,
9L, 4L);
if (*n > *k) {
/* W := W + C2 * V2' */
i__1 = *n - *k;
dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, &
c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) *
v_dim1 + 1], ldv, &c_b14, &work[work_offset],
ldwork, 12L, 9L);
}
/* W := W * T or W * T' */
dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - W * V */
if (*n > *k) {
/* C2 := C2 - W * V2 */
i__1 = *n - *k;
dgemm_("No transpose", "No transpose", m, &i__1, k, &
c_b25, &work[work_offset], ldwork, &v[(*k + 1) *
v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1
+ 1], ldc, 12L, 12L);
}
/* W := W * V1 */
dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14,
&v[v_offset], ldv, &work[work_offset], ldwork, 5L,
5L, 12L, 4L);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
/* L170: */
}
/* L180: */
}
}
} else {
/* Let V = ( V1 V2 ) (V2: last K columns) */
/* where V2 is unit lower triangular. */
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C or H' * C where C = ( C1 ) */
/* ( C2 ) */
/* W := C' * V' = (C1'*V1' + C2'*V2') (stored i
n WORK) */
/* W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j *
work_dim1 + 1], &c__1);
/* L190: */
}
/* W := W * V2' */
dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, &
v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset]
, ldwork, 5L, 5L, 9L, 4L);
if (*m > *k) {
/* W := W + C1'*V1' */
i__1 = *m - *k;
dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, &
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
work[work_offset], ldwork, 9L, 9L);
}
/* W := W * T' or W * T */
dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - V' * W' */
if (*m > *k) {
/* C1 := C1 - V1' * W' */
i__1 = *m - *k;
dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[
v_offset], ldv, &work[work_offset], ldwork, &
c_b14, &c__[c_offset], ldc, 9L, 9L);
}
/* W := W * V2 */
dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14,
&v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork, 5L, 5L, 12L, 4L);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j *
work_dim1];
/* L200: */
}
/* L210: */
}
} else if (lsame_(side, "R", 1L, 1L)) {
/* Form C * H or C * H' where C = ( C1 C2 )
*/
/* W := C * V' = (C1*V1' + C2*V2') (stored in
WORK) */
/* W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[
j * work_dim1 + 1], &c__1);
/* L220: */
}
/* W := W * V2' */
dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, &
v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset]
, ldwork, 5L, 5L, 9L, 4L);
if (*n > *k) {
/* W := W + C1 * V1' */
i__1 = *n - *k;
dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, &
c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
work[work_offset], ldwork, 12L, 9L);
}
/* W := W * T or W * T' */
dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[
t_offset], ldt, &work[work_offset], ldwork, 5L, 5L,
1L, 8L);
/* C := C - W * V */
if (*n > *k) {
/* C1 := C1 - W * V1 */
i__1 = *n - *k;
dgemm_("No transpose", "No transpose", m, &i__1, k, &
c_b25, &work[work_offset], ldwork, &v[v_offset],
ldv, &c_b14, &c__[c_offset], ldc, 12L, 12L);
}
/* W := W * V2 */
dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14,
&v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[
work_offset], ldwork, 5L, 5L, 12L, 4L);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j *
work_dim1];
/* L230: */
}
/* L240: */
}
}
}
}
return 0;
/* End of DLARFB */
} /* dlarfb_ */
/* dlarfx.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
#ifdef c_b14
#undef c_b14
#endif
#define c_b14 c_b14
#ifdef c_b16
#undef c_b16
#endif
#define c_b16 c_b16
/* Subroutine */ int dlarfx_(side, m, n, v, tau, c__, ldc, work, side_len)
char *side;
integer *m, *n;
doublereal *v, *tau, *c__;
integer *ldc;
doublereal *work;
ftnlen side_len;
{
/* System generated locals */
integer c_dim1, c_offset, i__1;
doublereal d__1;
/* Local variables */
extern /* Subroutine */ int dger_();
static integer j;
extern logical lsame_();
extern /* Subroutine */ int dgemv_();
static doublereal t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5,
v6, v7, v8, v9, t10, v10, sum;
/* -- LAPACK auxiliary routine (version 2.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 */
/* ======= */
/* DLARFX 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) DOUBLE PRECISION array, dimension (M) if SIDE = 'L' */
/* or (N) if SIDE = 'R' */
/* The vector v in the representation of H. */
/* TAU (input) DOUBLE PRECISION */
/* The value tau in the representation of H. */
/* C (input/output) DOUBLE PRECISION 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) DOUBLE PRECISION 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 = c_dim1 + 1;
c__ -= c_offset;
--work;
/* Function Body */
if (*tau == 0.) {
return 0;
}
if (lsame_(side, "L", 1L, 1L)) {
/* Form H * C, where H has order m. */
switch ((int)*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 */
/* w := C'*v */
dgemv_("Transpose", m, n, &c_b14, &c__[c_offset], ldc, &v[1], &c__1, &
c_b16, &work[1], &c__1, 9L);
/* C := C - tau * v * w' */
d__1 = -(*tau);
dger_(m, n, &d__1, &v[1], &c__1, &work[1], &c__1, &c__[c_offset], ldc)
;
goto L410;
L10:
/* Special code for 1 x 1 Householder */
t1 = 1. - *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 ((int)*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 */
/* w := C * v */
dgemv_("No transpose", m, n, &c_b14, &c__[c_offset], ldc, &v[1], &
c__1, &c_b16, &work[1], &c__1, 12L);
/* C := C - tau * w * v' */
d__1 = -(*tau);
dger_(m, n, &d__1, &work[1], &c__1, &v[1], &c__1, &c__[c_offset], ldc)
;
goto L410;
L210:
/* Special code for 1 x 1 Householder */
t1 = 1. - *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 DLARFX */
} /* dlarfx_ */
/* dgeqrf.f -- translated by f2c (version 19950808).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
/* Table of constant values */
/* Subroutine */ int dgeqrf_(m, n, a, lda, tau, work, lwork, info)
integer *m, *n;
doublereal *a;
integer *lda;
doublereal *tau, *work;
integer *lwork, *info;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
static integer i__, k, nbmin, iinfo;
extern /* Subroutine */ int dgeqr2_();
static integer ib, nb;
extern /* Subroutine */ int dlarfb_();
static integer nx;
extern /* Subroutine */ int dlarft_(), xerbla_();
extern integer ilaenv_();
static integer ldwork, iws;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGEQRF 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) DOUBLE PRECISION 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 min(m,n) elementary reflectors (see Further */
/* Details). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors (see Further
*/
/* Details). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
*/
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,N). */
/* For optimum performance LWORK >= N*NB, where NB is */
/* the optimal blocksize. */
/* 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). */
/* =====================================================================
*/
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
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;
} else if (*lwork < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEQRF", &i__1, 6L);
return 0;
}
/* Quick return if possible */
k = min(*m,*n);
if (k == 0) {
work[1] = 1.;
return 0;
}
/* Determine the block size. */
nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, 6L, 1L);
nbmin = 2;
nx = 0;
iws = *n;
if (nb > 1 && nb < k) {
/* Determine when to cross over from blocked to unblocked code.
*/
/* Computing MAX */
i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1, 6L,
1L);
nx = max(i__1,i__2);
if (nx < k) {
/* Determine if workspace is large enough for blocked co
de. */
ldwork = *n;
iws = ldwork * nb;
if (*lwork < iws) {
/* Not enough workspace to use optimal NB: reduc
e NB and */
/* determine the minimum value of NB. */
nb = *lwork / ldwork;
/* Computing MAX */
i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, &
c_n1, 6L, 1L);
nbmin = max(i__1,i__2);
}
}
}
if (nb >= nbmin && nb < k && nx < k) {
/* Use blocked code initially */
i__1 = k - nx;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = k - i__ + 1;
ib = min(i__3,nb);
/* Compute the QR factorization of the current block */
/* A(i:m,i:i+ib-1) */
i__3 = *m - i__ + 1;
dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
1], &iinfo);
if (i__ + ib <= *n) {
/* Form the triangular factor of the block reflec
tor */
/* H = H(i) H(i+1) . . . H(i+ib-1) */
i__3 = *m - i__ + 1;
dlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ *
a_dim1], lda, &tau[i__], &work[1], &ldwork, 7L, 10L);
/* Apply H' to A(i:m,i+ib:n) from the left */
i__3 = *m - i__ + 1;
i__4 = *n - i__ - ib + 1;
dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib
+ 1], &ldwork, 4L, 9L, 7L, 10L);
}
/* L10: */
}
} else {
i__ = 1;
}
/* Use unblocked code to factor the last or only block. */
if (i__ <= k) {
i__2 = *m - i__ + 1;
i__1 = *n - i__ + 1;
dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
, &iinfo);
}
work[1] = (doublereal) iws;
return 0;
/* End of DGEQRF */
} /* dgeqrf_ */
syntax highlighted by Code2HTML, v. 0.9.1