![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CLAHQR 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download CLAHQR + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clahqr.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clahqr.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clahqr.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, 00022 * IHIZ, Z, LDZ, INFO ) 00023 * 00024 * .. Scalar Arguments .. 00025 * INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N 00026 * LOGICAL WANTT, WANTZ 00027 * .. 00028 * .. Array Arguments .. 00029 * COMPLEX H( LDH, * ), W( * ), Z( LDZ, * ) 00030 * .. 00031 * 00032 * 00033 *> \par Purpose: 00034 * ============= 00035 *> 00036 *> \verbatim 00037 *> 00038 *> CLAHQR is an auxiliary routine called by CHSEQR to update the 00039 *> eigenvalues and Schur decomposition already computed by CHSEQR, by 00040 *> dealing with the Hessenberg submatrix in rows and columns ILO to 00041 *> IHI. 00042 *> \endverbatim 00043 * 00044 * Arguments: 00045 * ========== 00046 * 00047 *> \param[in] WANTT 00048 *> \verbatim 00049 *> WANTT is LOGICAL 00050 *> = .TRUE. : the full Schur form T is required; 00051 *> = .FALSE.: only eigenvalues are required. 00052 *> \endverbatim 00053 *> 00054 *> \param[in] WANTZ 00055 *> \verbatim 00056 *> WANTZ is LOGICAL 00057 *> = .TRUE. : the matrix of Schur vectors Z is required; 00058 *> = .FALSE.: Schur vectors are not required. 00059 *> \endverbatim 00060 *> 00061 *> \param[in] N 00062 *> \verbatim 00063 *> N is INTEGER 00064 *> The order of the matrix H. N >= 0. 00065 *> \endverbatim 00066 *> 00067 *> \param[in] ILO 00068 *> \verbatim 00069 *> ILO is INTEGER 00070 *> \endverbatim 00071 *> 00072 *> \param[in] IHI 00073 *> \verbatim 00074 *> IHI is INTEGER 00075 *> It is assumed that H is already upper triangular in rows and 00076 *> columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). 00077 *> CLAHQR works primarily with the Hessenberg submatrix in rows 00078 *> and columns ILO to IHI, but applies transformations to all of 00079 *> H if WANTT is .TRUE.. 00080 *> 1 <= ILO <= max(1,IHI); IHI <= N. 00081 *> \endverbatim 00082 *> 00083 *> \param[in,out] H 00084 *> \verbatim 00085 *> H is COMPLEX array, dimension (LDH,N) 00086 *> On entry, the upper Hessenberg matrix H. 00087 *> On exit, if INFO is zero and if WANTT is .TRUE., then H 00088 *> is upper triangular in rows and columns ILO:IHI. If INFO 00089 *> is zero and if WANTT is .FALSE., then the contents of H 00090 *> are unspecified on exit. The output state of H in case 00091 *> INF is positive is below under the description of INFO. 00092 *> \endverbatim 00093 *> 00094 *> \param[in] LDH 00095 *> \verbatim 00096 *> LDH is INTEGER 00097 *> The leading dimension of the array H. LDH >= max(1,N). 00098 *> \endverbatim 00099 *> 00100 *> \param[out] W 00101 *> \verbatim 00102 *> W is COMPLEX array, dimension (N) 00103 *> The computed eigenvalues ILO to IHI are stored in the 00104 *> corresponding elements of W. If WANTT is .TRUE., the 00105 *> eigenvalues are stored in the same order as on the diagonal 00106 *> of the Schur form returned in H, with W(i) = H(i,i). 00107 *> \endverbatim 00108 *> 00109 *> \param[in] ILOZ 00110 *> \verbatim 00111 *> ILOZ is INTEGER 00112 *> \endverbatim 00113 *> 00114 *> \param[in] IHIZ 00115 *> \verbatim 00116 *> IHIZ is INTEGER 00117 *> Specify the rows of Z to which transformations must be 00118 *> applied if WANTZ is .TRUE.. 00119 *> 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. 00120 *> \endverbatim 00121 *> 00122 *> \param[in,out] Z 00123 *> \verbatim 00124 *> Z is COMPLEX array, dimension (LDZ,N) 00125 *> If WANTZ is .TRUE., on entry Z must contain the current 00126 *> matrix Z of transformations accumulated by CHSEQR, and on 00127 *> exit Z has been updated; transformations are applied only to 00128 *> the submatrix Z(ILOZ:IHIZ,ILO:IHI). 00129 *> If WANTZ is .FALSE., Z is not referenced. 00130 *> \endverbatim 00131 *> 00132 *> \param[in] LDZ 00133 *> \verbatim 00134 *> LDZ is INTEGER 00135 *> The leading dimension of the array Z. LDZ >= max(1,N). 00136 *> \endverbatim 00137 *> 00138 *> \param[out] INFO 00139 *> \verbatim 00140 *> INFO is INTEGER 00141 *> = 0: successful exit 00142 *> .GT. 0: if INFO = i, CLAHQR failed to compute all the 00143 *> eigenvalues ILO to IHI in a total of 30 iterations 00144 *> per eigenvalue; elements i+1:ihi of W contain 00145 *> those eigenvalues which have been successfully 00146 *> computed. 00147 *> 00148 *> If INFO .GT. 0 and WANTT is .FALSE., then on exit, 00149 *> the remaining unconverged eigenvalues are the 00150 *> eigenvalues of the upper Hessenberg matrix 00151 *> rows and columns ILO thorugh INFO of the final, 00152 *> output value of H. 00153 *> 00154 *> If INFO .GT. 0 and WANTT is .TRUE., then on exit 00155 *> (*) (initial value of H)*U = U*(final value of H) 00156 *> where U is an orthognal matrix. The final 00157 *> value of H is upper Hessenberg and triangular in 00158 *> rows and columns INFO+1 through IHI. 00159 *> 00160 *> If INFO .GT. 0 and WANTZ is .TRUE., then on exit 00161 *> (final value of Z) = (initial value of Z)*U 00162 *> where U is the orthogonal matrix in (*) 00163 *> (regardless of the value of WANTT.) 00164 *> \endverbatim 00165 * 00166 * Authors: 00167 * ======== 00168 * 00169 *> \author Univ. of Tennessee 00170 *> \author Univ. of California Berkeley 00171 *> \author Univ. of Colorado Denver 00172 *> \author NAG Ltd. 00173 * 00174 *> \date November 2011 00175 * 00176 *> \ingroup complexOTHERauxiliary 00177 * 00178 *> \par Contributors: 00179 * ================== 00180 *> 00181 *> \verbatim 00182 *> 00183 *> 02-96 Based on modifications by 00184 *> David Day, Sandia National Laboratory, USA 00185 *> 00186 *> 12-04 Further modifications by 00187 *> Ralph Byers, University of Kansas, USA 00188 *> This is a modified version of CLAHQR from LAPACK version 3.0. 00189 *> It is (1) more robust against overflow and underflow and 00190 *> (2) adopts the more conservative Ahues & Tisseur stopping 00191 *> criterion (LAWN 122, 1997). 00192 *> \endverbatim 00193 *> 00194 * ===================================================================== 00195 SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, 00196 $ IHIZ, Z, LDZ, INFO ) 00197 * 00198 * -- LAPACK auxiliary routine (version 3.4.0) -- 00199 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00200 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00201 * November 2011 00202 * 00203 * .. Scalar Arguments .. 00204 INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N 00205 LOGICAL WANTT, WANTZ 00206 * .. 00207 * .. Array Arguments .. 00208 COMPLEX H( LDH, * ), W( * ), Z( LDZ, * ) 00209 * .. 00210 * 00211 * ========================================================= 00212 * 00213 * .. Parameters .. 00214 INTEGER ITMAX 00215 PARAMETER ( ITMAX = 30 ) 00216 COMPLEX ZERO, ONE 00217 PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), 00218 $ ONE = ( 1.0e0, 0.0e0 ) ) 00219 REAL RZERO, RONE, HALF 00220 PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0, HALF = 0.5e0 ) 00221 REAL DAT1 00222 PARAMETER ( DAT1 = 3.0e0 / 4.0e0 ) 00223 * .. 00224 * .. Local Scalars .. 00225 COMPLEX CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U, 00226 $ V2, X, Y 00227 REAL AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX, 00228 $ SAFMIN, SMLNUM, SX, T2, TST, ULP 00229 INTEGER I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ 00230 * .. 00231 * .. Local Arrays .. 00232 COMPLEX V( 2 ) 00233 * .. 00234 * .. External Functions .. 00235 COMPLEX CLADIV 00236 REAL SLAMCH 00237 EXTERNAL CLADIV, SLAMCH 00238 * .. 00239 * .. External Subroutines .. 00240 EXTERNAL CCOPY, CLARFG, CSCAL, SLABAD 00241 * .. 00242 * .. Statement Functions .. 00243 REAL CABS1 00244 * .. 00245 * .. Intrinsic Functions .. 00246 INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, REAL, SQRT 00247 * .. 00248 * .. Statement Function definitions .. 00249 CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) 00250 * .. 00251 * .. Executable Statements .. 00252 * 00253 INFO = 0 00254 * 00255 * Quick return if possible 00256 * 00257 IF( N.EQ.0 ) 00258 $ RETURN 00259 IF( ILO.EQ.IHI ) THEN 00260 W( ILO ) = H( ILO, ILO ) 00261 RETURN 00262 END IF 00263 * 00264 * ==== clear out the trash ==== 00265 DO 10 J = ILO, IHI - 3 00266 H( J+2, J ) = ZERO 00267 H( J+3, J ) = ZERO 00268 10 CONTINUE 00269 IF( ILO.LE.IHI-2 ) 00270 $ H( IHI, IHI-2 ) = ZERO 00271 * ==== ensure that subdiagonal entries are real ==== 00272 IF( WANTT ) THEN 00273 JLO = 1 00274 JHI = N 00275 ELSE 00276 JLO = ILO 00277 JHI = IHI 00278 END IF 00279 DO 20 I = ILO + 1, IHI 00280 IF( AIMAG( H( I, I-1 ) ).NE.RZERO ) THEN 00281 * ==== The following redundant normalization 00282 * . avoids problems with both gradual and 00283 * . sudden underflow in ABS(H(I,I-1)) ==== 00284 SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) 00285 SC = CONJG( SC ) / ABS( SC ) 00286 H( I, I-1 ) = ABS( H( I, I-1 ) ) 00287 CALL CSCAL( JHI-I+1, SC, H( I, I ), LDH ) 00288 CALL CSCAL( MIN( JHI, I+1 )-JLO+1, CONJG( SC ), H( JLO, I ), 00289 $ 1 ) 00290 IF( WANTZ ) 00291 $ CALL CSCAL( IHIZ-ILOZ+1, CONJG( SC ), Z( ILOZ, I ), 1 ) 00292 END IF 00293 20 CONTINUE 00294 * 00295 NH = IHI - ILO + 1 00296 NZ = IHIZ - ILOZ + 1 00297 * 00298 * Set machine-dependent constants for the stopping criterion. 00299 * 00300 SAFMIN = SLAMCH( 'SAFE MINIMUM' ) 00301 SAFMAX = RONE / SAFMIN 00302 CALL SLABAD( SAFMIN, SAFMAX ) 00303 ULP = SLAMCH( 'PRECISION' ) 00304 SMLNUM = SAFMIN*( REAL( NH ) / ULP ) 00305 * 00306 * I1 and I2 are the indices of the first row and last column of H 00307 * to which transformations must be applied. If eigenvalues only are 00308 * being computed, I1 and I2 are set inside the main loop. 00309 * 00310 IF( WANTT ) THEN 00311 I1 = 1 00312 I2 = N 00313 END IF 00314 * 00315 * The main loop begins here. I is the loop index and decreases from 00316 * IHI to ILO in steps of 1. Each iteration of the loop works 00317 * with the active submatrix in rows and columns L to I. 00318 * Eigenvalues I+1 to IHI have already converged. Either L = ILO, or 00319 * H(L,L-1) is negligible so that the matrix splits. 00320 * 00321 I = IHI 00322 30 CONTINUE 00323 IF( I.LT.ILO ) 00324 $ GO TO 150 00325 * 00326 * Perform QR iterations on rows and columns ILO to I until a 00327 * submatrix of order 1 splits off at the bottom because a 00328 * subdiagonal element has become negligible. 00329 * 00330 L = ILO 00331 DO 130 ITS = 0, ITMAX 00332 * 00333 * Look for a single small subdiagonal element. 00334 * 00335 DO 40 K = I, L + 1, -1 00336 IF( CABS1( H( K, K-1 ) ).LE.SMLNUM ) 00337 $ GO TO 50 00338 TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) 00339 IF( TST.EQ.ZERO ) THEN 00340 IF( K-2.GE.ILO ) 00341 $ TST = TST + ABS( REAL( H( K-1, K-2 ) ) ) 00342 IF( K+1.LE.IHI ) 00343 $ TST = TST + ABS( REAL( H( K+1, K ) ) ) 00344 END IF 00345 * ==== The following is a conservative small subdiagonal 00346 * . deflation criterion due to Ahues & Tisseur (LAWN 122, 00347 * . 1997). It has better mathematical foundation and 00348 * . improves accuracy in some examples. ==== 00349 IF( ABS( REAL( H( K, K-1 ) ) ).LE.ULP*TST ) THEN 00350 AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) 00351 BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) ) 00352 AA = MAX( CABS1( H( K, K ) ), 00353 $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) 00354 BB = MIN( CABS1( H( K, K ) ), 00355 $ CABS1( H( K-1, K-1 )-H( K, K ) ) ) 00356 S = AA + AB 00357 IF( BA*( AB / S ).LE.MAX( SMLNUM, 00358 $ ULP*( BB*( AA / S ) ) ) )GO TO 50 00359 END IF 00360 40 CONTINUE 00361 50 CONTINUE 00362 L = K 00363 IF( L.GT.ILO ) THEN 00364 * 00365 * H(L,L-1) is negligible 00366 * 00367 H( L, L-1 ) = ZERO 00368 END IF 00369 * 00370 * Exit from loop if a submatrix of order 1 has split off. 00371 * 00372 IF( L.GE.I ) 00373 $ GO TO 140 00374 * 00375 * Now the active submatrix is in rows and columns L to I. If 00376 * eigenvalues only are being computed, only the active submatrix 00377 * need be transformed. 00378 * 00379 IF( .NOT.WANTT ) THEN 00380 I1 = L 00381 I2 = I 00382 END IF 00383 * 00384 IF( ITS.EQ.10 ) THEN 00385 * 00386 * Exceptional shift. 00387 * 00388 S = DAT1*ABS( REAL( H( L+1, L ) ) ) 00389 T = S + H( L, L ) 00390 ELSE IF( ITS.EQ.20 ) THEN 00391 * 00392 * Exceptional shift. 00393 * 00394 S = DAT1*ABS( REAL( H( I, I-1 ) ) ) 00395 T = S + H( I, I ) 00396 ELSE 00397 * 00398 * Wilkinson's shift. 00399 * 00400 T = H( I, I ) 00401 U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) ) 00402 S = CABS1( U ) 00403 IF( S.NE.RZERO ) THEN 00404 X = HALF*( H( I-1, I-1 )-T ) 00405 SX = CABS1( X ) 00406 S = MAX( S, CABS1( X ) ) 00407 Y = S*SQRT( ( X / S )**2+( U / S )**2 ) 00408 IF( SX.GT.RZERO ) THEN 00409 IF( REAL( X / SX )*REAL( Y )+AIMAG( X / SX )* 00410 $ AIMAG( Y ).LT.RZERO )Y = -Y 00411 END IF 00412 T = T - U*CLADIV( U, ( X+Y ) ) 00413 END IF 00414 END IF 00415 * 00416 * Look for two consecutive small subdiagonal elements. 00417 * 00418 DO 60 M = I - 1, L + 1, -1 00419 * 00420 * Determine the effect of starting the single-shift QR 00421 * iteration at row M, and see if this would make H(M,M-1) 00422 * negligible. 00423 * 00424 H11 = H( M, M ) 00425 H22 = H( M+1, M+1 ) 00426 H11S = H11 - T 00427 H21 = REAL( H( M+1, M ) ) 00428 S = CABS1( H11S ) + ABS( H21 ) 00429 H11S = H11S / S 00430 H21 = H21 / S 00431 V( 1 ) = H11S 00432 V( 2 ) = H21 00433 H10 = REAL( H( M, M-1 ) ) 00434 IF( ABS( H10 )*ABS( H21 ).LE.ULP* 00435 $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) 00436 $ GO TO 70 00437 60 CONTINUE 00438 H11 = H( L, L ) 00439 H22 = H( L+1, L+1 ) 00440 H11S = H11 - T 00441 H21 = REAL( H( L+1, L ) ) 00442 S = CABS1( H11S ) + ABS( H21 ) 00443 H11S = H11S / S 00444 H21 = H21 / S 00445 V( 1 ) = H11S 00446 V( 2 ) = H21 00447 70 CONTINUE 00448 * 00449 * Single-shift QR step 00450 * 00451 DO 120 K = M, I - 1 00452 * 00453 * The first iteration of this loop determines a reflection G 00454 * from the vector V and applies it from left and right to H, 00455 * thus creating a nonzero bulge below the subdiagonal. 00456 * 00457 * Each subsequent iteration determines a reflection G to 00458 * restore the Hessenberg form in the (K-1)th column, and thus 00459 * chases the bulge one step toward the bottom of the active 00460 * submatrix. 00461 * 00462 * V(2) is always real before the call to CLARFG, and hence 00463 * after the call T2 ( = T1*V(2) ) is also real. 00464 * 00465 IF( K.GT.M ) 00466 $ CALL CCOPY( 2, H( K, K-1 ), 1, V, 1 ) 00467 CALL CLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) 00468 IF( K.GT.M ) THEN 00469 H( K, K-1 ) = V( 1 ) 00470 H( K+1, K-1 ) = ZERO 00471 END IF 00472 V2 = V( 2 ) 00473 T2 = REAL( T1*V2 ) 00474 * 00475 * Apply G from the left to transform the rows of the matrix 00476 * in columns K to I2. 00477 * 00478 DO 80 J = K, I2 00479 SUM = CONJG( T1 )*H( K, J ) + T2*H( K+1, J ) 00480 H( K, J ) = H( K, J ) - SUM 00481 H( K+1, J ) = H( K+1, J ) - SUM*V2 00482 80 CONTINUE 00483 * 00484 * Apply G from the right to transform the columns of the 00485 * matrix in rows I1 to min(K+2,I). 00486 * 00487 DO 90 J = I1, MIN( K+2, I ) 00488 SUM = T1*H( J, K ) + T2*H( J, K+1 ) 00489 H( J, K ) = H( J, K ) - SUM 00490 H( J, K+1 ) = H( J, K+1 ) - SUM*CONJG( V2 ) 00491 90 CONTINUE 00492 * 00493 IF( WANTZ ) THEN 00494 * 00495 * Accumulate transformations in the matrix Z 00496 * 00497 DO 100 J = ILOZ, IHIZ 00498 SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) 00499 Z( J, K ) = Z( J, K ) - SUM 00500 Z( J, K+1 ) = Z( J, K+1 ) - SUM*CONJG( V2 ) 00501 100 CONTINUE 00502 END IF 00503 * 00504 IF( K.EQ.M .AND. M.GT.L ) THEN 00505 * 00506 * If the QR step was started at row M > L because two 00507 * consecutive small subdiagonals were found, then extra 00508 * scaling must be performed to ensure that H(M,M-1) remains 00509 * real. 00510 * 00511 TEMP = ONE - T1 00512 TEMP = TEMP / ABS( TEMP ) 00513 H( M+1, M ) = H( M+1, M )*CONJG( TEMP ) 00514 IF( M+2.LE.I ) 00515 $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP 00516 DO 110 J = M, I 00517 IF( J.NE.M+1 ) THEN 00518 IF( I2.GT.J ) 00519 $ CALL CSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) 00520 CALL CSCAL( J-I1, CONJG( TEMP ), H( I1, J ), 1 ) 00521 IF( WANTZ ) THEN 00522 CALL CSCAL( NZ, CONJG( TEMP ), Z( ILOZ, J ), 1 ) 00523 END IF 00524 END IF 00525 110 CONTINUE 00526 END IF 00527 120 CONTINUE 00528 * 00529 * Ensure that H(I,I-1) is real. 00530 * 00531 TEMP = H( I, I-1 ) 00532 IF( AIMAG( TEMP ).NE.RZERO ) THEN 00533 RTEMP = ABS( TEMP ) 00534 H( I, I-1 ) = RTEMP 00535 TEMP = TEMP / RTEMP 00536 IF( I2.GT.I ) 00537 $ CALL CSCAL( I2-I, CONJG( TEMP ), H( I, I+1 ), LDH ) 00538 CALL CSCAL( I-I1, TEMP, H( I1, I ), 1 ) 00539 IF( WANTZ ) THEN 00540 CALL CSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) 00541 END IF 00542 END IF 00543 * 00544 130 CONTINUE 00545 * 00546 * Failure to converge in remaining number of iterations 00547 * 00548 INFO = I 00549 RETURN 00550 * 00551 140 CONTINUE 00552 * 00553 * H(I,I-1) is negligible: one eigenvalue has converged. 00554 * 00555 W( I ) = H( I, I ) 00556 * 00557 * return to start of the main loop with new value of I. 00558 * 00559 I = L - 1 00560 GO TO 30 00561 * 00562 150 CONTINUE 00563 RETURN 00564 * 00565 * End of CLAHQR 00566 * 00567 END