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