/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal *wr, doublereal *wi, doublereal *z__, integer *ldz, doublereal *work, integer *lwork, integer *info) { /* System generated locals */ address a__1[2]; integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3; doublereal d__1; char ch__1[2]; /* Builtin functions */ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); /* Local variables */ integer i__; #ifdef LAPACK_DISABLE_MEMORY_HOGS doublereal hl[1] /* was [49][49] */; /** This function uses too much memory, so we stopped allocating the memory * above and assert false here. */ assert(0 && "dhseqr_ was called. This function allocates too much" " memory and has been disabled."); #else doublereal hl[2401] /* was [49][49] */; #endif integer kbot, nmin; extern logical lsame_(char *, char *); logical initz; doublereal workl[49]; logical wantt, wantz; extern /* Subroutine */ int dlaqr0_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *), dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); extern /* Subroutine */ int xerbla_(char *, integer *); logical lquery; /* -- LAPACK driver routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DHSEQR computes the eigenvalues of a 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 .GE. 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 DGEHRD */ /* when the matrix output by DGEBAL is reduced to Hessenberg */ /* form. Otherwise ILO and IHI should be set to 1 and N */ /* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */ /* If N = 0, then ILO = 1 and IHI = 0. */ /* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ /* On entry, the upper Hessenberg matrix H. */ /* On exit, if INFO = 0 and JOB = 'S', then 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).LT.0. If INFO = 0 and JOB = 'E', the */ /* contents of H are unspecified on exit. (The output value of */ /* H when INFO.GT.0 is given under the description of INFO */ /* below.) */ /* Unlike earlier versions of DHSEQR, this subroutine may */ /* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */ /* or j = IHI+1, IHI+2, ... N. */ /* LDH (input) INTEGER */ /* The leading dimension of the array H. LDH .GE. 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) .GT. 0 and */ /* WI(i+1) .LT. 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, */ /* if INFO = 0, 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, */ /* if INFO = 0, Z contains Q*Z. */ /* Normally Q is the orthogonal matrix generated by DORGHR */ /* after the call to DGEHRD which formed the Hessenberg matrix */ /* H. (The output value of Z when INFO.GT.0 is given under */ /* the description of INFO below.) */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. if COMPZ = 'I' or */ /* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */ /* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */ /* On exit, if INFO = 0, WORK(1) returns an estimate of */ /* the optimal value for LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK .GE. max(1,N) */ /* is sufficient and delivers very good and sometimes */ /* optimal performance. However, LWORK as large as 11*N */ /* may be required for optimal performance. A workspace */ /* query is recommended to determine the optimal workspace */ /* size. */ /* If LWORK = -1, then DHSEQR does a workspace query. */ /* In this case, DHSEQR checks the input parameters and */ /* estimates the optimal workspace size for the given */ /* values of N, ILO and IHI. The estimate is returned */ /* in WORK(1). No error message related to LWORK is */ /* issued by XERBLA. Neither H nor Z are accessed. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* .LT. 0: if INFO = -i, the i-th argument had an illegal */ /* value */ /* .GT. 0: if INFO = i, DHSEQR failed to compute all of */ /* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ /* and WI contain those eigenvalues which have been */ /* successfully computed. (Failures are rare.) */ /* If INFO .GT. 0 and JOB = 'E', then on exit, the */ /* remaining unconverged eigenvalues are the eigen- */ /* values of the upper Hessenberg matrix rows and */ /* columns ILO through INFO of the final, output */ /* value of H. */ /* If INFO .GT. 0 and JOB = 'S', then on exit */ /* (*) (initial value of H)*U = U*(final value of H) */ /* where U is an orthogonal matrix. The final */ /* value of H is upper Hessenberg and quasi-triangular */ /* in rows and columns INFO+1 through IHI. */ /* If INFO .GT. 0 and COMPZ = 'V', then on exit */ /* (final value of Z) = (initial value of Z)*U */ /* where U is the orthogonal matrix in (*) (regard- */ /* less of the value of JOB.) */ /* If INFO .GT. 0 and COMPZ = 'I', then on exit */ /* (final value of Z) = U */ /* where U is the orthogonal matrix in (*) (regard- */ /* less of the value of JOB.) */ /* If INFO .GT. 0 and COMPZ = 'N', then Z is not */ /* accessed. */ /* ================================================================ */ /* Default values supplied by */ /* ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */ /* It is suggested that these defaults be adjusted in order */ /* to attain best performance in each particular */ /* computational environment. */ /* ISPEC=12: The DLAHQR vs DLAQR0 crossover point. */ /* Default: 75. (Must be at least 11.) */ /* ISPEC=13: Recommended deflation window size. */ /* This depends on ILO, IHI and NS. NS is the */ /* number of simultaneous shifts returned */ /* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */ /* The default for (IHI-ILO+1).LE.500 is NS. */ /* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */ /* ISPEC=14: Nibble crossover point. (See IPARMQ for */ /* details.) Default: 14% of deflation window */ /* size. */ /* ISPEC=15: Number of simultaneous shifts in a multishift */ /* QR iteration. */ /* If IHI-ILO+1 is ... */ /* greater than ...but less ... the */ /* or equal to ... than default is */ /* 1 30 NS = 2(+) */ /* 30 60 NS = 4(+) */ /* 60 150 NS = 10(+) */ /* 150 590 NS = ** */ /* 590 3000 NS = 64 */ /* 3000 6000 NS = 128 */ /* 6000 infinity NS = 256 */ /* (+) By default some or all matrices of this order */ /* are passed to the implicit double shift routine */ /* DLAHQR and this parameter is ignored. See */ /* ISPEC=12 above and comments in IPARMQ for */ /* details. */ /* (**) The asterisks (**) indicate an ad-hoc */ /* function of N increasing from 10 to 64. */ /* ISPEC=16: Select structured matrix multiply. */ /* If the number of simultaneous shifts (specified */ /* by ISPEC=15) is less than 14, then the default */ /* for ISPEC=16 is 0. Otherwise the default for */ /* ISPEC=16 is 2. */ /* ================================================================ */ /* Based on contributions by */ /* Karen Braman and Ralph Byers, Department of Mathematics, */ /* University of Kansas, USA */ /* ================================================================ */ /* References: */ /* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ /* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ /* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ /* 929--947, 2002. */ /* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ /* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ /* of Matrix Analysis, volume 23, pages 948--973, 2002. */ /* ================================================================ */ /* .. Parameters .. */ /* ==== Matrices of order NTINY or smaller must be processed by */ /* . DLAHQR because of insufficient subdiagonal scratch space. */ /* . (This is a hard limit.) ==== */ /* ==== NL allocates some local workspace to help small matrices */ /* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is */ /* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */ /* . mended. (The default value of NMIN is 75.) Using NL = 49 */ /* . allows up to six simultaneous shifts and a 16-by-16 */ /* . deflation window. ==== */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* ==== Decode and check the input parameters. ==== */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --wr; --wi; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; /* Function Body */ wantt = lsame_(job, "S"); initz = lsame_(compz, "I"); wantz = initz || lsame_(compz, "V"); work[1] = (doublereal) max(1,*n); lquery = *lwork == -1; *info = 0; if (! lsame_(job, "E") && ! wantt) { *info = -1; } else if (! lsame_(compz, "N") && ! 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; } else if (*lwork < max(1,*n) && ! lquery) { *info = -13; } if (*info != 0) { /* ==== Quick return in case of invalid argument. ==== */ i__1 = -(*info); xerbla_("DHSEQR", &i__1); return 0; } else if (*n == 0) { /* ==== Quick return in case N = 0; nothing to do. ==== */ return 0; } else if (lquery) { /* ==== Quick return in case of a workspace query ==== */ dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[ 1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); /* ==== Ensure reported workspace size is backward-compatible with */ /* . previous LAPACK versions. ==== */ /* Computing MAX */ d__1 = (doublereal) max(1,*n); work[1] = max(d__1,work[1]); return 0; } else { /* ==== copy 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: */ } /* ==== Initialize Z, if requested ==== */ if (initz) { dlaset_("A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz) ; } /* ==== Quick return if possible ==== */ if (*ilo == *ihi) { wr[*ilo] = h__[*ilo + *ilo * h_dim1]; wi[*ilo] = 0.; return 0; } /* ==== DLAHQR/DLAQR0 crossover point ==== */ /* Writing concatenation */ i__2[0] = 1, a__1[0] = job; i__2[1] = 1, a__1[1] = compz; s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); nmin = ilaenv_(&c__12, "DHSEQR", ch__1, n, ilo, ihi, lwork); nmin = max(11,nmin); /* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== */ if (*n > nmin) { dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); } else { /* ==== Small matrix ==== */ dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, info); if (*info > 0) { /* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds */ /* . when DLAHQR fails. ==== */ kbot = *info; if (*n >= 49) { /* ==== Larger matrices have enough subdiagonal scratch */ /* . space to call DLAQR0 directly. ==== */ dlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); } else { /* ==== Tiny matrices don't have enough subdiagonal */ /* . scratch space to benefit from DLAQR0. Hence, */ /* . tiny matrices must be copied into a larger */ /* . array before calling DLAQR0. ==== */ dlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49); hl[*n + 1 + *n * 49 - 50] = 0.; i__1 = 49 - *n; dlaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) * 49 - 49], &c__49); dlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, & wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, workl, &c__49, info); if (wantt || *info != 0) { dlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh); } } } } /* ==== Clear out the trash, if necessary. ==== */ if ((wantt || *info != 0) && *n > 2) { i__1 = *n - 2; i__3 = *n - 2; dlaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh); } /* ==== Ensure reported workspace size is backward-compatible with */ /* . previous LAPACK versions. ==== */ /* Computing MAX */ d__1 = (doublereal) max(1,*n); work[1] = max(d__1,work[1]); } /* ==== End of DHSEQR ==== */ return 0; } /* dhseqr_ */
int dlaqr0_(int *wantt, int *wantz, int *n, int *ilo, int *ihi, double *h__, int *ldh, double *wr, double *wi, int *iloz, int *ihiz, double *z__, int *ldz, double *work, int *lwork, int *info) { /* System generated locals */ int h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; double d__1, d__2, d__3, d__4; /* Local variables */ int i__, k; double aa, bb, cc, dd; int ld; double cs; int nh, it, ks, kt; double sn; int ku, kv, ls, ns; double ss; int nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin; double swap; int ktop; double zdum[1] /* was [1][1] */; int kacc22, itmax, nsmax, nwmax, kwtop; extern int dlanv2_(double *, double *, double *, double *, double *, double *, double *, double *, double *, double *), dlaqr3_( int *, int *, int *, int *, int *, int *, double *, int *, int *, int *, double *, int *, int *, int *, double *, double *, double *, int *, int *, double *, int *, int *, double *, int *, double *, int *), dlaqr4_(int *, int *, int *, int *, int *, double *, int *, double *, double *, int *, int *, double *, int *, double *, int *, int *), dlaqr5_(int *, int *, int *, int *, int *, int *, int *, double *, double *, double *, int *, int *, int *, double *, int *, double *, int *, double *, int *, int *, double *, int *, int *, double *, int *); int nibble; extern int dlahqr_(int *, int *, int *, int *, int *, double *, int *, double *, double *, int *, int *, double *, int *, int *), dlacpy_(char *, int *, int *, double *, int *, double *, int *); extern int ilaenv_(int *, char *, char *, int *, int *, int *, int *); char jbcmpz[1]; int nwupbd; int sorted; int lwkopt; /* -- LAPACK auxiliary routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* DLAQR0 computes the eigenvalues of a 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 */ /* ========= */ /* 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 .GE. 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 and, if ILO.GT.1, */ /* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */ /* previous call to DGEBAL, and then passed to DGEHRD when the */ /* matrix output by DGEBAL is reduced to Hessenberg form. */ /* Otherwise, ILO and IHI should be set to 1 and N, */ /* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */ /* If N = 0, then ILO = 1 and IHI = 0. */ /* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ /* On entry, the upper Hessenberg matrix H. */ /* On exit, if INFO = 0 and WANTT is .TRUE., then 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).LT.0. If INFO = 0 and WANTT is */ /* .FALSE., then the contents of H are unspecified on exit. */ /* (The output value of H when INFO.GT.0 is given under the */ /* description of INFO below.) */ /* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */ /* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */ /* LDH (input) INTEGER */ /* The leading dimension of the array H. LDH .GE. MAX(1,N). */ /* WR (output) DOUBLE PRECISION array, dimension (IHI) */ /* WI (output) DOUBLE PRECISION array, dimension (IHI) */ /* The float and imaginary parts, respectively, of the computed */ /* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */ /* and WI(ILO:IHI). 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) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */ /* 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 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */ /* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) */ /* If WANTZ is .FALSE., then Z is not referenced. */ /* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */ /* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */ /* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */ /* (The output value of Z when INFO.GT.0 is given under */ /* the description of INFO below.) */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. if WANTZ is .TRUE. */ /* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */ /* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK */ /* On exit, if LWORK = -1, WORK(1) returns an estimate of */ /* the optimal value for LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. LWORK .GE. MAX(1,N) */ /* is sufficient, but LWORK typically as large as 6*N may */ /* be required for optimal performance. A workspace query */ /* to determine the optimal workspace size is recommended. */ /* If LWORK = -1, then DLAQR0 does a workspace query. */ /* In this case, DLAQR0 checks the input parameters and */ /* estimates the optimal workspace size for the given */ /* values of N, ILO and IHI. The estimate is returned */ /* in WORK(1). No error message related to LWORK is */ /* issued by XERBLA. Neither H nor Z are accessed. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* .GT. 0: if INFO = i, DLAQR0 failed to compute all of */ /* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ /* and WI contain those eigenvalues which have been */ /* successfully computed. (Failures are rare.) */ /* If INFO .GT. 0 and WANT is .FALSE., then on exit, */ /* the remaining unconverged eigenvalues are the eigen- */ /* values of the upper Hessenberg matrix rows and */ /* columns ILO through INFO of the final, output */ /* value of H. */ /* If INFO .GT. 0 and WANTT is .TRUE., then on exit */ /* (*) (initial value of H)*U = U*(final value of H) */ /* where U is an orthogonal matrix. The final */ /* value of H is upper Hessenberg and quasi-triangular */ /* in rows and columns INFO+1 through IHI. */ /* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */ /* (final value of Z(ILO:IHI,ILOZ:IHIZ) */ /* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */ /* where U is the orthogonal matrix in (*) (regard- */ /* less of the value of WANTT.) */ /* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */ /* accessed. */ /* ================================================================ */ /* Based on contributions by */ /* Karen Braman and Ralph Byers, Department of Mathematics, */ /* University of Kansas, USA */ /* ================================================================ */ /* References: */ /* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ /* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ /* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ /* 929--947, 2002. */ /* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ /* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ /* of Matrix Analysis, volume 23, pages 948--973, 2002. */ /* ================================================================ */ /* .. Parameters .. */ /* ==== Matrices of order NTINY or smaller must be processed by */ /* . DLAHQR because of insufficient subdiagonal scratch space. */ /* . (This is a hard limit.) ==== */ /* ==== Exceptional deflation windows: try to cure rare */ /* . slow convergence by varying the size of the */ /* . deflation window after KEXNW iterations. ==== */ /* ==== Exceptional shifts: try to cure rare slow convergence */ /* . with ad-hoc exceptional shifts every KEXSH iterations. */ /* . ==== */ /* ==== The constants WILK1 and WILK2 are used to form the */ /* . exceptional shifts. ==== */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --wr; --wi; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; /* Function Body */ *info = 0; /* ==== Quick return for N = 0: nothing to do. ==== */ if (*n == 0) { work[1] = 1.; return 0; } if (*n <= 11) { /* ==== Tiny matrices must use DLAHQR. ==== */ lwkopt = 1; if (*lwork != -1) { dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & wi[1], iloz, ihiz, &z__[z_offset], ldz, info); } } else { /* ==== Use small bulge multi-shift QR with aggressive early */ /* . deflation on larger-than-tiny matrices. ==== */ /* ==== Hope for the best. ==== */ *info = 0; /* ==== Set up job flags for ILAENV. ==== */ if (*wantt) { *(unsigned char *)jbcmpz = 'S'; } else { *(unsigned char *)jbcmpz = 'E'; } if (*wantz) { *(unsigned char *)&jbcmpz[1] = 'V'; } else { *(unsigned char *)&jbcmpz[1] = 'N'; } /* ==== NWR = recommended deflation window size. At this */ /* . point, N .GT. NTINY = 11, so there is enough */ /* . subdiagonal workspace for NWR.GE.2 as required. */ /* . (In fact, there is enough subdiagonal space for */ /* . NWR.GE.3.) ==== */ nwr = ilaenv_(&c__13, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); nwr = MAX(2,nwr); /* Computing MIN */ i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = MIN(i__1,i__2); nwr = MIN(i__1,nwr); /* ==== NSR = recommended number of simultaneous shifts. */ /* . At this point N .GT. NTINY = 11, so there is at */ /* . enough subdiagonal workspace for NSR to be even */ /* . and greater than or equal to two as required. ==== */ nsr = ilaenv_(&c__15, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); /* Computing MIN */ i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = MIN(i__1,i__2), i__2 = *ihi - *ilo; nsr = MIN(i__1,i__2); /* Computing MAX */ i__1 = 2, i__2 = nsr - nsr % 2; nsr = MAX(i__1,i__2); /* ==== Estimate optimal workspace ==== */ /* ==== Workspace query call to DLAQR3 ==== */ i__1 = nwr + 1; dlaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1], &c_n1); /* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== */ /* Computing MAX */ i__1 = nsr * 3 / 2, i__2 = (int) work[1]; lwkopt = MAX(i__1,i__2); /* ==== Quick return in case of workspace query. ==== */ if (*lwork == -1) { work[1] = (double) lwkopt; return 0; } /* ==== DLAHQR/DLAQR0 crossover point ==== */ nmin = ilaenv_(&c__12, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); nmin = MAX(11,nmin); /* ==== Nibble crossover point ==== */ nibble = ilaenv_(&c__14, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); nibble = MAX(0,nibble); /* ==== Accumulate reflections during ttswp? Use block */ /* . 2-by-2 structure during matrix-matrix multiply? ==== */ kacc22 = ilaenv_(&c__16, "DLAQR0", jbcmpz, n, ilo, ihi, lwork); kacc22 = MAX(0,kacc22); kacc22 = MIN(2,kacc22); /* ==== NWMAX = the largest possible deflation window for */ /* . which there is sufficient workspace. ==== */ /* Computing MIN */ i__1 = (*n - 1) / 3, i__2 = *lwork / 2; nwmax = MIN(i__1,i__2); nw = nwmax; /* ==== NSMAX = the Largest number of simultaneous shifts */ /* . for which there is sufficient workspace. ==== */ /* Computing MIN */ i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3; nsmax = MIN(i__1,i__2); nsmax -= nsmax % 2; /* ==== NDFL: an iteration count restarted at deflation. ==== */ ndfl = 1; /* ==== ITMAX = iteration limit ==== */ /* Computing MAX */ i__1 = 10, i__2 = *ihi - *ilo + 1; itmax = MAX(i__1,i__2) * 30; /* ==== Last row and column in the active block ==== */ kbot = *ihi; /* ==== Main Loop ==== */ i__1 = itmax; for (it = 1; it <= i__1; ++it) { /* ==== Done when KBOT falls below ILO ==== */ if (kbot < *ilo) { goto L90; } /* ==== Locate active block ==== */ i__2 = *ilo + 1; for (k = kbot; k >= i__2; --k) { if (h__[k + (k - 1) * h_dim1] == 0.) { goto L20; } /* L10: */ } k = *ilo; L20: ktop = k; /* ==== Select deflation window size: */ /* . Typical Case: */ /* . If possible and advisable, nibble the entire */ /* . active block. If not, use size MIN(NWR,NWMAX) */ /* . or MIN(NWR+1,NWMAX) depending upon which has */ /* . the smaller corresponding subdiagonal entry */ /* . (a heuristic). */ /* . */ /* . Exceptional Case: */ /* . If there have been no deflations in KEXNW or */ /* . more iterations, then vary the deflation window */ /* . size. At first, because, larger windows are, */ /* . in general, more powerful than smaller ones, */ /* . rapidly increase the window to the maximum possible. */ /* . Then, gradually reduce the window size. ==== */ nh = kbot - ktop + 1; nwupbd = MIN(nh,nwmax); if (ndfl < 5) { nw = MIN(nwupbd,nwr); } else { /* Computing MIN */ i__2 = nwupbd, i__3 = nw << 1; nw = MIN(i__2,i__3); } if (nw < nwmax) { if (nw >= nh - 1) { nw = nh; } else { kwtop = kbot - nw + 1; if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], ABS(d__1)) > (d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], ABS(d__2))) { ++nw; } } } if (ndfl < 5) { ndec = -1; } else if (ndec >= 0 || nw >= nwupbd) { ++ndec; if (nw - ndec < 2) { ndec = 0; } nw -= ndec; } /* ==== Aggressive early deflation: */ /* . split workspace under the subdiagonal into */ /* . - an nw-by-nw work array V in the lower */ /* . left-hand-corner, */ /* . - an NW-by-at-least-NW-but-more-is-better */ /* . (NW-by-NHO) horizontal work array along */ /* . the bottom edge, */ /* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ /* . vertical work array along the left-hand-edge. */ /* . ==== */ kv = *n - nw + 1; kt = nw + 1; nho = *n - nw - 1 - kt + 1; kwv = nw + 2; nve = *n - nw - kwv + 1; /* ==== Aggressive early deflation ==== */ dlaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); /* ==== Adjust KBOT accounting for new deflations. ==== */ kbot -= ld; /* ==== KS points to the shifts. ==== */ ks = kbot - ls + 1; /* ==== Skip an expensive QR sweep if there is a (partly */ /* . heuristic) reason to expect that many eigenvalues */ /* . will deflate without it. Here, the QR sweep is */ /* . skipped if many eigenvalues have just been deflated */ /* . or if the remaining active block is small. */ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > MIN( nmin,nwmax)) { /* ==== NS = nominal number of simultaneous shifts. */ /* . This may be lowered (slightly) if DLAQR3 */ /* . did not provide that many shifts. ==== */ /* Computing MIN */ /* Computing MAX */ i__4 = 2, i__5 = kbot - ktop; i__2 = MIN(nsmax,nsr), i__3 = MAX(i__4,i__5); ns = MIN(i__2,i__3); ns -= ns % 2; /* ==== If there have been no deflations */ /* . in a multiple of KEXSH iterations, */ /* . then try exceptional shifts. */ /* . Otherwise use shifts provided by */ /* . DLAQR3 above or from the eigenvalues */ /* . of a trailing principal submatrix. ==== */ if (ndfl % 6 == 0) { ks = kbot - ns + 1; /* Computing MAX */ i__3 = ks + 1, i__4 = ktop + 2; i__2 = MAX(i__3,i__4); for (i__ = kbot; i__ >= i__2; i__ += -2) { ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], ABS(d__1)) + (d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], ABS(d__2)); aa = ss * .75 + h__[i__ + i__ * h_dim1]; bb = ss; cc = ss * -.4375; dd = aa; dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] , &wr[i__], &wi[i__], &cs, &sn); /* L30: */ } if (ks == ktop) { wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; wi[ks + 1] = 0.; wr[ks] = wr[ks + 1]; wi[ks] = wi[ks + 1]; } } else { /* ==== Got NS/2 or fewer shifts? Use DLAQR4 or */ /* . DLAHQR on a trailing principal submatrix to */ /* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */ /* . there is enough space below the subdiagonal */ /* . to fit an NS-by-NS scratch array.) ==== */ if (kbot - ks + 1 <= ns / 2) { ks = kbot - ns + 1; kt = *n - ns + 1; dlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & h__[kt + h_dim1], ldh); if (ns > nmin) { dlaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ kt + h_dim1], ldh, &wr[ks], &wi[ks], & c__1, &c__1, zdum, &c__1, &work[1], lwork, &inf); } else { dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ kt + h_dim1], ldh, &wr[ks], &wi[ks], & c__1, &c__1, zdum, &c__1, &inf); } ks += inf; /* ==== In case of a rare QR failure use */ /* . eigenvalues of the trailing 2-by-2 */ /* . principal submatrix. ==== */ if (ks >= kbot) { aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; cc = h__[kbot + (kbot - 1) * h_dim1]; bb = h__[kbot - 1 + kbot * h_dim1]; dd = h__[kbot + kbot * h_dim1]; dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) ; ks = kbot - 1; } } if (kbot - ks + 1 > ns) { /* ==== Sort the shifts (Helps a little) */ /* . Bubble sort keeps complex conjugate */ /* . pairs together. ==== */ sorted = FALSE; i__2 = ks + 1; for (k = kbot; k >= i__2; --k) { if (sorted) { goto L60; } sorted = TRUE; i__3 = k - 1; for (i__ = ks; i__ <= i__3; ++i__) { if ((d__1 = wr[i__], ABS(d__1)) + (d__2 = wi[ i__], ABS(d__2)) < (d__3 = wr[i__ + 1] , ABS(d__3)) + (d__4 = wi[i__ + 1], ABS(d__4))) { sorted = FALSE; swap = wr[i__]; wr[i__] = wr[i__ + 1]; wr[i__ + 1] = swap; swap = wi[i__]; wi[i__] = wi[i__ + 1]; wi[i__ + 1] = swap; } /* L40: */ } /* L50: */ } L60: ; } /* ==== Shuffle shifts into pairs of float shifts */ /* . and pairs of complex conjugate shifts */ /* . assuming complex conjugate shifts are */ /* . already adjacent to one another. (Yes, */ /* . they are.) ==== */ i__2 = ks + 2; for (i__ = kbot; i__ >= i__2; i__ += -2) { if (wi[i__] != -wi[i__ - 1]) { swap = wr[i__]; wr[i__] = wr[i__ - 1]; wr[i__ - 1] = wr[i__ - 2]; wr[i__ - 2] = swap; swap = wi[i__]; wi[i__] = wi[i__ - 1]; wi[i__ - 1] = wi[i__ - 2]; wi[i__ - 2] = swap; } /* L70: */ } } /* ==== If there are only two shifts and both are */ /* . float, then use only one. ==== */ if (kbot - ks + 1 == 2) { if (wi[kbot] == 0.) { if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], ABS( d__1)) < (d__2 = wr[kbot - 1] - h__[kbot + kbot * h_dim1], ABS(d__2))) { wr[kbot - 1] = wr[kbot]; } else { wr[kbot] = wr[kbot - 1]; } } } /* ==== Use up to NS of the the smallest magnatiude */ /* . shifts. If there aren't NS shifts available, */ /* . then use them all, possibly dropping one to */ /* . make the number of shifts even. ==== */ /* Computing MIN */ i__2 = ns, i__3 = kbot - ks + 1; ns = MIN(i__2,i__3); ns -= ns % 2; ks = kbot - ns + 1; /* ==== Small-bulge multi-shift QR sweep: */ /* . split workspace under the subdiagonal into */ /* . - a KDU-by-KDU work array U in the lower */ /* . left-hand-corner, */ /* . - a KDU-by-at-least-KDU-but-more-is-better */ /* . (KDU-by-NHo) horizontal work array WH along */ /* . the bottom edge, */ /* . - and an at-least-KDU-but-more-is-better-by-KDU */ /* . (NVE-by-KDU) vertical work WV arrow along */ /* . the left-hand-edge. ==== */ kdu = ns * 3 - 3; ku = *n - kdu + 1; kwh = kdu + 1; nho = *n - kdu - 3 - (kdu + 1) + 1; kwv = kdu + 4; nve = *n - kdu - kwv + 1; /* ==== Small-bulge multi-shift QR sweep ==== */ dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1], ldh); } /* ==== Note progress (or the lack of it). ==== */ if (ld > 0) { ndfl = 1; } else { ++ndfl; } /* ==== End of main loop ==== */ /* L80: */ } /* ==== Iteration limit exceeded. Set INFO to show where */ /* . the problem occurred and exit. ==== */ *info = kbot; L90: ; } /* ==== Return the optimal value of LWORK. ==== */ work[1] = (double) lwkopt; /* ==== End of DLAQR0 ==== */ return 0; } /* dlaqr0_ */
/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal *wr, doublereal *wi, doublereal *z__, integer *ldz, doublereal *work, integer *lwork, integer *info) { /* System generated locals */ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__3; doublereal d__1; char ch__1[2]; /* Builtin functions */ /* Subroutine */ /* Local variables */ integer i__; doublereal hl[2401] /* was [49][49] */ ; integer kbot, nmin; extern logical lsame_(char *, char *); logical initz; doublereal workl[49]; logical wantt, wantz; extern /* Subroutine */ int dlaqr0_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *), dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); extern /* Subroutine */ int xerbla_(char *, integer *); logical lquery; /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* ==== Matrices of order NTINY or smaller must be processed by */ /* . DLAHQR because of insufficient subdiagonal scratch space. */ /* . (This is a hard limit.) ==== */ /* ==== NL allocates some local workspace to help small matrices */ /* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is */ /* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */ /* . mended. (The default value of NMIN is 75.) Using NL = 49 */ /* . allows up to six simultaneous shifts and a 16-by-16 */ /* . deflation window. ==== */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* ==== Decode and check the input parameters. ==== */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; --wr; --wi; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; /* Function Body */ wantt = lsame_(job, "S"); initz = lsame_(compz, "I"); wantz = initz || lsame_(compz, "V"); work[1] = (doublereal) max(1,*n); lquery = *lwork == -1; *info = 0; if (! lsame_(job, "E") && ! wantt) { *info = -1; } else if (! lsame_(compz, "N") && ! 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; } else if (*lwork < max(1,*n) && ! lquery) { *info = -13; } if (*info != 0) { /* ==== Quick return in case of invalid argument. ==== */ i__1 = -(*info); xerbla_("DHSEQR", &i__1); return 0; } else if (*n == 0) { /* ==== Quick return in case N = 0; nothing to do. ==== */ return 0; } else if (lquery) { /* ==== Quick return in case of a workspace query ==== */ dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[ 1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); /* ==== Ensure reported workspace size is backward-compatible with */ /* . previous LAPACK versions. ==== */ /* Computing MAX */ d__1 = (doublereal) max(1,*n); work[1] = max(d__1,work[1]); return 0; } else { /* ==== copy 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: */ } /* ==== Initialize Z, if requested ==== */ if (initz) { dlaset_("A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz) ; } /* ==== Quick return if possible ==== */ if (*ilo == *ihi) { wr[*ilo] = h__[*ilo + *ilo * h_dim1]; wi[*ilo] = 0.; return 0; } /* ==== DLAHQR/DLAQR0 crossover point ==== */ nmin = ilaenv_(&c__12, "DHSEQR", ch__1, n, ilo, ihi, lwork); nmin = max(11,nmin); /* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== */ if (*n > nmin) { dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); } else { /* ==== Small matrix ==== */ dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, info); if (*info > 0) { /* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds */ /* . when DLAHQR fails. ==== */ kbot = *info; if (*n >= 49) { /* ==== Larger matrices have enough subdiagonal scratch */ /* . space to call DLAQR0 directly. ==== */ dlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset], ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); } else { /* ==== Tiny matrices don't have enough subdiagonal */ /* . scratch space to benefit from DLAQR0. Hence, */ /* . tiny matrices must be copied into a larger */ /* . array before calling DLAQR0. ==== */ dlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49); hl[*n + 1 + *n * 49 - 50] = 0.; i__1 = 49 - *n; dlaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) * 49 - 49], &c__49); dlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, & wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz, workl, &c__49, info); if (wantt || *info != 0) { dlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh); } } } } /* ==== Clear out the trash, if necessary. ==== */ if ((wantt || *info != 0) && *n > 2) { i__1 = *n - 2; i__3 = *n - 2; dlaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh); } /* ==== Ensure reported workspace size is backward-compatible with */ /* . previous LAPACK versions. ==== */ /* Computing MAX */ d__1 = (doublereal) max(1,*n); work[1] = max(d__1,work[1]); } /* ==== End of DHSEQR ==== */ return 0; }
/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, doublereal *h, integer *ldh, doublereal *wr, doublereal *wi, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= 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. ===================================================================== Decode and test the input parameters Parameter adjustments Function Body */ /* Table of constant values */ static doublereal c_b9 = 0.; static doublereal c_b10 = 1.; static integer c__4 = 4; static integer c_n1 = -1; static integer c__2 = 2; static integer c__8 = 8; static integer c__15 = 15; static logical c_false = FALSE_; static integer c__1 = 1; /* 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(char *, char **, integer *, integer *, ftnlen); /* 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_(integer *, doublereal *, doublereal *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int dgemv_(char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); static integer itemp; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); static integer i1, i2; static logical initz, wantt, wantz; extern doublereal dlapy2_(doublereal *, doublereal *); extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); static integer ii, nh; extern doublereal dlamch_(char *); extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *); static integer nr, ns; extern integer idamax_(integer *, doublereal *, integer *); static integer nv; extern doublereal dlanhs_(char *, integer *, doublereal *, integer *, doublereal *); extern /* Subroutine */ int dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *); static doublereal vv[16]; extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern /* Subroutine */ int dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *), dlarfx_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *); static doublereal smlnum; static integer itn; static doublereal tau; static integer its; static doublereal ulp, tst1; #define S(I) s[(I)] #define WAS(I) was[(I)] #define V(I) v[(I)] #define VV(I) vv[(I)] #define WR(I) wr[(I)-1] #define WI(I) wi[(I)-1] #define WORK(I) work[(I)-1] #define H(I,J) h[(I)-1 + ((J)-1)* ( *ldh)] #define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)] wantt = lsame_(job, "S"); initz = lsame_(compz, "I"); wantz = initz || lsame_(compz, "V"); *info = 0; if (! lsame_(job, "E") && ! wantt) { *info = -1; } else if (! lsame_(compz, "N") && ! 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); return 0; } /* Initialize Z, if necessary */ if (initz) { dlaset_("Full", n, n, &c_b9, &c_b10, &Z(1,1), ldz); } /* Store the eigenvalues isolated by DGEBAL. */ i__1 = *ilo - 1; for (i = 1; i <= *ilo-1; ++i) { WR(i) = H(i,i); WI(i) = 0.; /* L10: */ } i__1 = *n; for (i = *ihi + 1; i <= *n; ++i) { WR(i) = H(i,i); WI(i) = 0.; /* L20: */ } /* Quick return if possible. */ if (*n == 0) { return 0; } if (*ilo == *ihi) { WR(*ilo) = H(*ilo,*ilo); 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 <= *ihi-2; ++j) { i__2 = *n; for (i = j + 2; i <= *n; ++i) { H(i,j) = 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(1,1), ldh, &WR(1), &WI(1) , ilo, ihi, &Z(1,1), 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"); ovfl = 1. / unfl; dlabad_(&unfl, &ovfl); ulp = dlamch_("Precision"); 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 <= itn; ++its) { /* Look for a single small subdiagonal element. */ i__2 = l + 1; for (k = i; k >= l+1; --k) { tst1 = (d__1 = H(k-1,k-1), abs(d__1)) + (d__2 = H(k,k), abs(d__2)); if (tst1 == 0.) { i__4 = i - l + 1; tst1 = dlanhs_("1", &i__4, &H(l,l), ldh, &WORK(1)); } /* Computing MAX */ d__2 = ulp * tst1; if ((d__1 = H(k,k-1), 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) = 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; ++ii) { WR(ii) = ((d__1 = H(ii,ii-1), abs(d__1)) + ( d__2 = H(ii,ii), 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), ldh, s, &c__15); dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, s, &c__15, &WR(i - ns + 1), &WI(i - ns + 1), &c__1, &ns, &Z(1,1), 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 <= ierr; ++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 <= ns+1; ++ii) { V(ii - 1) = 0.; /* L100: */ } nv = 1; i__2 = i; for (j = i - ns + 1; j <= i; ++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), ldh, vv, &c__1, &d__1, v, &c__1); ++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), ldh, v, &c__1, &d__1, vv, &c__1); 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), ldh, vv, &c__1, &temp, v, &c__1); 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 <= nv; ++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-1; ++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), &c__1, v, &c__1); } dlarfg_(&nr, v, &V(1), &c__1, &tau); if (k > l) { H(k,k-1) = V(0); i__4 = i; for (ii = k + 1; ii <= i; ++ii) { H(ii,k-1) = 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), ldh, & WORK(1)); /* 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), ldh, & WORK(1)); if (wantz) { /* Accumulate transformations in the matrix Z */ dlarfx_("Right", &nh, &nr, v, &tau, &Z(*ilo,k), ldz, &WORK(1)); } /* 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(1,1), ldh, &WR(1), &WI(1), ilo, ihi, &Z(1,1), 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_ */
/* Subroutine */ int dlaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, doublereal *h__, integer * ldh, integer *iloz, integer *ihiz, doublereal *z__, integer *ldz, integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal * v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer * nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork) { /* System generated locals */ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2, d__3, d__4, d__5, d__6; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__, j, k; doublereal s, aa, bb, cc, dd, cs, sn; integer jw; doublereal evi, evk, foo; integer kln; doublereal tau, ulp; integer lwk1, lwk2; doublereal beta; integer kend, kcol, info, ifst, ilst, ltop, krow; extern /* Subroutine */ int dlarf_(char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *), dgemm_(char *, char *, integer *, integer * , integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); logical bulge; extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); integer infqr, kwtop; extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlabad_( doublereal *, doublereal *); extern doublereal dlamch_(char *); extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *), dlarfg_(integer *, doublereal *, doublereal *, integer *, doublereal *), dlahqr_(logical *, logical *, integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); doublereal safmin; extern /* Subroutine */ int dlaset_(char *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *); doublereal safmax; extern /* Subroutine */ int dorghr_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *), dtrexc_(char *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, integer *, doublereal *, integer *); logical sorted; doublereal smlnum; integer lwkopt; /* -- LAPACK auxiliary routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* This subroutine is identical to DLAQR3 except that it avoids */ /* recursion by calling DLAHQR instead of DLAQR4. */ /* ****************************************************************** */ /* Aggressive early deflation: */ /* This subroutine accepts as input an upper Hessenberg matrix */ /* H and performs an orthogonal similarity transformation */ /* designed to detect and deflate fully converged eigenvalues from */ /* a trailing principal submatrix. On output H has been over- */ /* written by a new Hessenberg matrix that is a perturbation of */ /* an orthogonal similarity transformation of H. It is to be */ /* hoped that the final version of H has many zero subdiagonal */ /* entries. */ /* ****************************************************************** */ /* WANTT (input) LOGICAL */ /* If .TRUE., then the Hessenberg matrix H is fully updated */ /* so that the quasi-triangular Schur factor may be */ /* computed (in cooperation with the calling subroutine). */ /* If .FALSE., then only enough of H is updated to preserve */ /* the eigenvalues. */ /* WANTZ (input) LOGICAL */ /* If .TRUE., then the orthogonal matrix Z is updated so */ /* so that the orthogonal Schur factor may be computed */ /* (in cooperation with the calling subroutine). */ /* If .FALSE., then Z is not referenced. */ /* N (input) INTEGER */ /* The order of the matrix H and (if WANTZ is .TRUE.) the */ /* order of the orthogonal matrix Z. */ /* KTOP (input) INTEGER */ /* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ /* KBOT and KTOP together determine an isolated block */ /* along the diagonal of the Hessenberg matrix. */ /* KBOT (input) INTEGER */ /* It is assumed without a check that either */ /* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ /* determine an isolated block along the diagonal of the */ /* Hessenberg matrix. */ /* NW (input) INTEGER */ /* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */ /* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */ /* On input the initial N-by-N section of H stores the */ /* Hessenberg matrix undergoing aggressive early deflation. */ /* On output H has been transformed by an orthogonal */ /* similarity transformation, perturbed, and the returned */ /* to Hessenberg form that (it is to be hoped) has some */ /* zero subdiagonal entries. */ /* LDH (input) integer */ /* Leading dimension of H just as declared in the calling */ /* subroutine. N .LE. LDH */ /* ILOZ (input) INTEGER */ /* IHIZ (input) INTEGER */ /* Specify the rows of Z to which transformations must be */ /* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */ /* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) */ /* IF WANTZ is .TRUE., then on output, the orthogonal */ /* similarity transformation mentioned above has been */ /* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */ /* If WANTZ is .FALSE., then Z is unreferenced. */ /* LDZ (input) integer */ /* The leading dimension of Z just as declared in the */ /* calling subroutine. 1 .LE. LDZ. */ /* NS (output) integer */ /* The number of unconverged (ie approximate) eigenvalues */ /* returned in SR and SI that may be used as shifts by the */ /* calling subroutine. */ /* ND (output) integer */ /* The number of converged eigenvalues uncovered by this */ /* subroutine. */ /* SR (output) DOUBLE PRECISION array, dimension KBOT */ /* SI (output) DOUBLE PRECISION array, dimension KBOT */ /* On output, the real and imaginary parts of approximate */ /* eigenvalues that may be used for shifts are stored in */ /* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */ /* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */ /* The real and imaginary parts of converged eigenvalues */ /* are stored in SR(KBOT-ND+1) through SR(KBOT) and */ /* SI(KBOT-ND+1) through SI(KBOT), respectively. */ /* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) */ /* An NW-by-NW work array. */ /* LDV (input) integer scalar */ /* The leading dimension of V just as declared in the */ /* calling subroutine. NW .LE. LDV */ /* NH (input) integer scalar */ /* The number of columns of T. NH.GE.NW. */ /* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) */ /* LDT (input) integer */ /* The leading dimension of T just as declared in the */ /* calling subroutine. NW .LE. LDT */ /* NV (input) integer */ /* The number of rows of work array WV available for */ /* workspace. NV.GE.NW. */ /* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) */ /* LDWV (input) integer */ /* The leading dimension of W just as declared in the */ /* calling subroutine. NW .LE. LDV */ /* WORK (workspace) DOUBLE PRECISION array, dimension LWORK. */ /* On exit, WORK(1) is set to an estimate of the optimal value */ /* of LWORK for the given values of N, NW, KTOP and KBOT. */ /* LWORK (input) integer */ /* The dimension of the work array WORK. LWORK = 2*NW */ /* suffices, but greater efficiency may result from larger */ /* values of LWORK. */ /* If LWORK = -1, then a workspace query is assumed; DLAQR2 */ /* only estimates the optimal workspace size for the given */ /* values of N, NW, KTOP and KBOT. The estimate is returned */ /* in WORK(1). No error message related to LWORK is issued */ /* by XERBLA. Neither H nor Z are accessed. */ /* ================================================================ */ /* Based on contributions by */ /* Karen Braman and Ralph Byers, Department of Mathematics, */ /* University of Kansas, USA */ /* ================================================================ */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* ==== Estimate optimal workspace. ==== */ /* Parameter adjustments */ h_dim1 = *ldh; h_offset = 1 + h_dim1; h__ -= h_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --sr; --si; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; t_dim1 = *ldt; t_offset = 1 + t_dim1; t -= t_offset; wv_dim1 = *ldwv; wv_offset = 1 + wv_dim1; wv -= wv_offset; --work; /* Function Body */ /* Computing MIN */ i__1 = *nw, i__2 = *kbot - *ktop + 1; jw = min(i__1,i__2); if (jw <= 2) { lwkopt = 1; } else { /* ==== Workspace query call to DGEHRD ==== */ i__1 = jw - 1; dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info); lwk1 = (integer) work[1]; /* ==== Workspace query call to DORGHR ==== */ i__1 = jw - 1; dorghr_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & c_n1, &info); lwk2 = (integer) work[1]; /* ==== Optimal workspace ==== */ lwkopt = jw + max(lwk1,lwk2); } /* ==== Quick return in case of workspace query. ==== */ if (*lwork == -1) { work[1] = (doublereal) lwkopt; return 0; } /* ==== Nothing to do ... */ /* ... for an empty active block ... ==== */ *ns = 0; *nd = 0; if (*ktop > *kbot) { return 0; } /* ... nor for an empty deflation window. ==== */ if (*nw < 1) { return 0; } /* ==== Machine constants ==== */ safmin = dlamch_("SAFE MINIMUM"); safmax = 1. / safmin; dlabad_(&safmin, &safmax); ulp = dlamch_("PRECISION"); smlnum = safmin * ((doublereal) (*n) / ulp); /* ==== Setup deflation window ==== */ /* Computing MIN */ i__1 = *nw, i__2 = *kbot - *ktop + 1; jw = min(i__1,i__2); kwtop = *kbot - jw + 1; if (kwtop == *ktop) { s = 0.; } else { s = h__[kwtop + (kwtop - 1) * h_dim1]; } if (*kbot == kwtop) { /* ==== 1-by-1 deflation window: not much to do ==== */ sr[kwtop] = h__[kwtop + kwtop * h_dim1]; si[kwtop] = 0.; *ns = 1; *nd = 0; /* Computing MAX */ d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs( d__1)); if (abs(s) <= max(d__2,d__3)) { *ns = 0; *nd = 1; if (kwtop > *ktop) { h__[kwtop + (kwtop - 1) * h_dim1] = 0.; } } return 0; } /* ==== Convert to spike-triangular form. (In case of a */ /* . rare QR failure, this routine continues to do */ /* . aggressive early deflation using that part of */ /* . the deflation window that converged using INFQR */ /* . here and there to keep track.) ==== */ dlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], ldt); i__1 = jw - 1; i__2 = *ldh + 1; i__3 = *ldt + 1; dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & i__3); dlaset_("A", &jw, &jw, &c_b10, &c_b11, &v[v_offset], ldv); dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); /* ==== DTREXC needs a clean margin near the diagonal ==== */ i__1 = jw - 3; for (j = 1; j <= i__1; ++j) { t[j + 2 + j * t_dim1] = 0.; t[j + 3 + j * t_dim1] = 0.; /* L10: */ } if (jw > 2) { t[jw + (jw - 2) * t_dim1] = 0.; } /* ==== Deflation detection loop ==== */ *ns = jw; ilst = infqr + 1; L20: if (ilst <= *ns) { if (*ns == 1) { bulge = FALSE_; } else { bulge = t[*ns + (*ns - 1) * t_dim1] != 0.; } /* ==== Small spike tip test for deflation ==== */ if (! bulge) { /* ==== Real eigenvalue ==== */ foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1)); if (foo == 0.) { foo = abs(s); } /* Computing MAX */ d__2 = smlnum, d__3 = ulp * foo; if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= max(d__2,d__3)) { /* ==== Deflatable ==== */ --(*ns); } else { /* ==== Undeflatable. Move it up out of the way. */ /* . (DTREXC can not fail in this case.) ==== */ ifst = *ns; dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); ++ilst; } } else { /* ==== Complex conjugate pair ==== */ foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[* ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[* ns - 1 + *ns * t_dim1], abs(d__2))); if (foo == 0.) { foo = abs(s); } /* Computing MAX */ d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 = s * v[(*ns - 1) * v_dim1 + 1], abs(d__2)); /* Computing MAX */ d__5 = smlnum, d__6 = ulp * foo; if (max(d__3,d__4) <= max(d__5,d__6)) { /* ==== Deflatable ==== */ *ns += -2; } else { /* ==== Undflatable. Move them up out of the way. */ /* . Fortunately, DTREXC does the right thing with */ /* . ILST in case of a rare exchange failure. ==== */ ifst = *ns; dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); ilst += 2; } } /* ==== End deflation detection loop ==== */ goto L20; } /* ==== Return to Hessenberg form ==== */ if (*ns == 0) { s = 0.; } if (*ns < jw) { /* ==== sorting diagonal blocks of T improves accuracy for */ /* . graded matrices. Bubble sort deals well with */ /* . exchange failures. ==== */ sorted = FALSE_; i__ = *ns + 1; L30: if (sorted) { goto L50; } sorted = TRUE_; kend = i__ - 1; i__ = infqr + 1; if (i__ == *ns) { k = i__ + 1; } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { k = i__ + 1; } else { k = i__ + 2; } L40: if (k <= kend) { if (k == i__ + 1) { evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1)); } else { evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 = t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 = t[i__ + (i__ + 1) * t_dim1], abs(d__2))); } if (k == kend) { evk = (d__1 = t[k + k * t_dim1], abs(d__1)); } else if (t[k + 1 + k * t_dim1] == 0.) { evk = (d__1 = t[k + k * t_dim1], abs(d__1)); } else { evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[ k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k + (k + 1) * t_dim1], abs(d__2))); } if (evi >= evk) { i__ = k; } else { sorted = FALSE_; ifst = i__; ilst = k; dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &ilst, &work[1], &info); if (info == 0) { i__ = ilst; } else { i__ = k; } } if (i__ == kend) { k = i__ + 1; } else if (t[i__ + 1 + i__ * t_dim1] == 0.) { k = i__ + 1; } else { k = i__ + 2; } goto L40; } goto L30; L50: ; } /* ==== Restore shift/eigenvalue array from T ==== */ i__ = jw; L60: if (i__ >= infqr + 1) { if (i__ == infqr + 1) { sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; si[kwtop + i__ - 1] = 0.; --i__; } else if (t[i__ + (i__ - 1) * t_dim1] == 0.) { sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; si[kwtop + i__ - 1] = 0.; --i__; } else { aa = t[i__ - 1 + (i__ - 1) * t_dim1]; cc = t[i__ + (i__ - 1) * t_dim1]; bb = t[i__ - 1 + i__ * t_dim1]; dd = t[i__ + i__ * t_dim1]; dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & sn); i__ += -2; } goto L60; } if (*ns < jw || s == 0.) { if (*ns > 1 && s != 0.) { /* ==== Reflect spike back into lower triangle ==== */ dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); beta = work[1]; dlarfg_(ns, &beta, &work[2], &c__1, &tau); work[1] = 1.; i__1 = jw - 2; i__2 = jw - 2; dlaset_("L", &i__1, &i__2, &c_b10, &c_b10, &t[t_dim1 + 3], ldt); dlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]); dlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & work[jw + 1]); dlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & work[jw + 1]); i__1 = *lwork - jw; dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] , &i__1, &info); } /* ==== Copy updated reduced window into place ==== */ if (kwtop > 1) { h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; } dlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] , ldh); i__1 = jw - 1; i__2 = *ldt + 1; i__3 = *ldh + 1; dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], &i__3); /* ==== Accumulate orthogonal matrix in order update */ /* . H and Z, if requested. (A modified version */ /* . of DORGHR that accumulates block Householder */ /* . transformations into V directly might be */ /* . marginally more efficient than the following.) ==== */ if (*ns > 1 && s != 0.) { i__1 = *lwork - jw; dorghr_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] , &i__1, &info); dgemm_("N", "N", &jw, ns, ns, &c_b11, &v[v_offset], ldv, &t[ t_offset], ldt, &c_b10, &wv[wv_offset], ldwv); dlacpy_("A", &jw, ns, &wv[wv_offset], ldwv, &v[v_offset], ldv); } /* ==== Update vertical slab in H ==== */ if (*wantt) { ltop = 1; } else { ltop = *ktop; } i__1 = kwtop - 1; i__2 = *nv; for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) { /* Computing MIN */ i__3 = *nv, i__4 = kwtop - krow; kln = min(i__3,i__4); dgemm_("N", "N", &kln, &jw, &jw, &c_b11, &h__[krow + kwtop * h_dim1], ldh, &v[v_offset], ldv, &c_b10, &wv[wv_offset], ldwv); dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * h_dim1], ldh); /* L70: */ } /* ==== Update horizontal slab in H ==== */ if (*wantt) { i__2 = *n; i__1 = *nh; for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; kcol += i__1) { /* Computing MIN */ i__3 = *nh, i__4 = *n - kcol + 1; kln = min(i__3,i__4); dgemm_("C", "N", &jw, &kln, &jw, &c_b11, &v[v_offset], ldv, & h__[kwtop + kcol * h_dim1], ldh, &c_b10, &t[t_offset], ldt); dlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * h_dim1], ldh); /* L80: */ } } /* ==== Update vertical slab in Z ==== */ if (*wantz) { i__1 = *ihiz; i__2 = *nv; for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += i__2) { /* Computing MIN */ i__3 = *nv, i__4 = *ihiz - krow + 1; kln = min(i__3,i__4); dgemm_("N", "N", &kln, &jw, &jw, &c_b11, &z__[krow + kwtop * z_dim1], ldz, &v[v_offset], ldv, &c_b10, &wv[ wv_offset], ldwv); dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + kwtop * z_dim1], ldz); /* L90: */ } } } /* ==== Return the number of deflations ... ==== */ *nd = jw - *ns; /* ==== ... and the number of shifts. (Subtracting */ /* . INFQR from the spike length takes care */ /* . of the case of a rare QR failure while */ /* . calculating eigenvalues of the deflation */ /* . window.) ==== */ *ns -= infqr; /* ==== Return optimal workspace. ==== */ work[1] = (doublereal) lwkopt; /* ==== End of DLAQR2 ==== */ return 0; } /* dlaqr2_ */