 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, 00002 $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, 00003 $ NV, WV, LDWV, WORK, LWORK ) 00004 * 00005 * -- LAPACK auxiliary routine (version 3.2.1) -- 00006 * Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. 00007 * -- April 2009 -- 00008 * 00009 * .. Scalar Arguments .. 00010 INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, 00011 $ LDZ, LWORK, N, ND, NH, NS, NV, NW 00012 LOGICAL WANTT, WANTZ 00013 * .. 00014 * .. Array Arguments .. 00015 COMPLEX H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), 00016 $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) 00017 * .. 00018 * 00019 * ****************************************************************** 00020 * Aggressive early deflation: 00021 * 00022 * This subroutine accepts as input an upper Hessenberg matrix 00023 * H and performs an unitary similarity transformation 00024 * designed to detect and deflate fully converged eigenvalues from 00025 * a trailing principal submatrix. On output H has been over- 00026 * written by a new Hessenberg matrix that is a perturbation of 00027 * an unitary similarity transformation of H. It is to be 00028 * hoped that the final version of H has many zero subdiagonal 00029 * entries. 00030 * 00031 * ****************************************************************** 00032 * WANTT (input) LOGICAL 00033 * If .TRUE., then the Hessenberg matrix H is fully updated 00034 * so that the triangular Schur factor may be 00035 * computed (in cooperation with the calling subroutine). 00036 * If .FALSE., then only enough of H is updated to preserve 00037 * the eigenvalues. 00038 * 00039 * WANTZ (input) LOGICAL 00040 * If .TRUE., then the unitary matrix Z is updated so 00041 * so that the unitary Schur factor may be computed 00042 * (in cooperation with the calling subroutine). 00043 * If .FALSE., then Z is not referenced. 00044 * 00045 * N (input) INTEGER 00046 * The order of the matrix H and (if WANTZ is .TRUE.) the 00047 * order of the unitary matrix Z. 00048 * 00049 * KTOP (input) INTEGER 00050 * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. 00051 * KBOT and KTOP together determine an isolated block 00052 * along the diagonal of the Hessenberg matrix. 00053 * 00054 * KBOT (input) INTEGER 00055 * It is assumed without a check that either 00056 * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together 00057 * determine an isolated block along the diagonal of the 00058 * Hessenberg matrix. 00059 * 00060 * NW (input) INTEGER 00061 * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). 00062 * 00063 * H (input/output) COMPLEX array, dimension (LDH,N) 00064 * On input the initial N-by-N section of H stores the 00065 * Hessenberg matrix undergoing aggressive early deflation. 00066 * On output H has been transformed by a unitary 00067 * similarity transformation, perturbed, and the returned 00068 * to Hessenberg form that (it is to be hoped) has some 00069 * zero subdiagonal entries. 00070 * 00071 * LDH (input) integer 00072 * Leading dimension of H just as declared in the calling 00073 * subroutine. N .LE. LDH 00074 * 00075 * ILOZ (input) INTEGER 00076 * IHIZ (input) INTEGER 00077 * Specify the rows of Z to which transformations must be 00078 * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. 00079 * 00080 * Z (input/output) COMPLEX array, dimension (LDZ,N) 00081 * IF WANTZ is .TRUE., then on output, the unitary 00082 * similarity transformation mentioned above has been 00083 * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. 00084 * If WANTZ is .FALSE., then Z is unreferenced. 00085 * 00086 * LDZ (input) integer 00087 * The leading dimension of Z just as declared in the 00088 * calling subroutine. 1 .LE. LDZ. 00089 * 00090 * NS (output) integer 00091 * The number of unconverged (ie approximate) eigenvalues 00092 * returned in SR and SI that may be used as shifts by the 00093 * calling subroutine. 00094 * 00095 * ND (output) integer 00096 * The number of converged eigenvalues uncovered by this 00097 * subroutine. 00098 * 00099 * SH (output) COMPLEX array, dimension KBOT 00100 * On output, approximate eigenvalues that may 00101 * be used for shifts are stored in SH(KBOT-ND-NS+1) 00102 * through SR(KBOT-ND). Converged eigenvalues are 00103 * stored in SH(KBOT-ND+1) through SH(KBOT). 00104 * 00105 * V (workspace) COMPLEX array, dimension (LDV,NW) 00106 * An NW-by-NW work array. 00107 * 00108 * LDV (input) integer scalar 00109 * The leading dimension of V just as declared in the 00110 * calling subroutine. NW .LE. LDV 00111 * 00112 * NH (input) integer scalar 00113 * The number of columns of T. NH.GE.NW. 00114 * 00115 * T (workspace) COMPLEX array, dimension (LDT,NW) 00116 * 00117 * LDT (input) integer 00118 * The leading dimension of T just as declared in the 00119 * calling subroutine. NW .LE. LDT 00120 * 00121 * NV (input) integer 00122 * The number of rows of work array WV available for 00123 * workspace. NV.GE.NW. 00124 * 00125 * WV (workspace) COMPLEX array, dimension (LDWV,NW) 00126 * 00127 * LDWV (input) integer 00128 * The leading dimension of W just as declared in the 00129 * calling subroutine. NW .LE. LDV 00130 * 00131 * WORK (workspace) COMPLEX array, dimension LWORK. 00132 * On exit, WORK(1) is set to an estimate of the optimal value 00133 * of LWORK for the given values of N, NW, KTOP and KBOT. 00134 * 00135 * LWORK (input) integer 00136 * The dimension of the work array WORK. LWORK = 2*NW 00137 * suffices, but greater efficiency may result from larger 00138 * values of LWORK. 00139 * 00140 * If LWORK = -1, then a workspace query is assumed; CLAQR3 00141 * only estimates the optimal workspace size for the given 00142 * values of N, NW, KTOP and KBOT. The estimate is returned 00143 * in WORK(1). No error message related to LWORK is issued 00144 * by XERBLA. Neither H nor Z are accessed. 00145 * 00146 * ================================================================ 00147 * Based on contributions by 00148 * Karen Braman and Ralph Byers, Department of Mathematics, 00149 * University of Kansas, USA 00150 * 00151 * ================================================================ 00152 * .. Parameters .. 00153 COMPLEX ZERO, ONE 00154 PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), 00155 $ ONE = ( 1.0e0, 0.0e0 ) ) 00156 REAL RZERO, RONE 00157 PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0 ) 00158 * .. 00159 * .. Local Scalars .. 00160 COMPLEX BETA, CDUM, S, TAU 00161 REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP 00162 INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, 00163 $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, 00164 $ LWKOPT, NMIN 00165 * .. 00166 * .. External Functions .. 00167 REAL SLAMCH 00168 INTEGER ILAENV 00169 EXTERNAL SLAMCH, ILAENV 00170 * .. 00171 * .. External Subroutines .. 00172 EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLAQR4, 00173 $ CLARF, CLARFG, CLASET, CTREXC, CUNMHR, SLABAD 00174 * .. 00175 * .. Intrinsic Functions .. 00176 INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL 00177 * .. 00178 * .. Statement Functions .. 00179 REAL CABS1 00180 * .. 00181 * .. Statement Function definitions .. 00182 CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) 00183 * .. 00184 * .. Executable Statements .. 00185 * 00186 * ==== Estimate optimal workspace. ==== 00187 * 00188 JW = MIN( NW, KBOT-KTOP+1 ) 00189 IF( JW.LE.2 ) THEN 00190 LWKOPT = 1 00191 ELSE 00192 * 00193 * ==== Workspace query call to CGEHRD ==== 00194 * 00195 CALL CGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) 00196 LWK1 = INT( WORK( 1 ) ) 00197 * 00198 * ==== Workspace query call to CUNMHR ==== 00199 * 00200 CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, 00201 $ WORK, -1, INFO ) 00202 LWK2 = INT( WORK( 1 ) ) 00203 * 00204 * ==== Workspace query call to CLAQR4 ==== 00205 * 00206 CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, 00207 $ LDV, WORK, -1, INFQR ) 00208 LWK3 = INT( WORK( 1 ) ) 00209 * 00210 * ==== Optimal workspace ==== 00211 * 00212 LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) 00213 END IF 00214 * 00215 * ==== Quick return in case of workspace query. ==== 00216 * 00217 IF( LWORK.EQ.-1 ) THEN 00218 WORK( 1 ) = CMPLX( LWKOPT, 0 ) 00219 RETURN 00220 END IF 00221 * 00222 * ==== Nothing to do ... 00223 * ... for an empty active block ... ==== 00224 NS = 0 00225 ND = 0 00226 WORK( 1 ) = ONE 00227 IF( KTOP.GT.KBOT ) 00228 $ RETURN 00229 * ... nor for an empty deflation window. ==== 00230 IF( NW.LT.1 ) 00231 $ RETURN 00232 * 00233 * ==== Machine constants ==== 00234 * 00235 SAFMIN = SLAMCH( 'SAFE MINIMUM' ) 00236 SAFMAX = RONE / SAFMIN 00237 CALL SLABAD( SAFMIN, SAFMAX ) 00238 ULP = SLAMCH( 'PRECISION' ) 00239 SMLNUM = SAFMIN*( REAL( N ) / ULP ) 00240 * 00241 * ==== Setup deflation window ==== 00242 * 00243 JW = MIN( NW, KBOT-KTOP+1 ) 00244 KWTOP = KBOT - JW + 1 00245 IF( KWTOP.EQ.KTOP ) THEN 00246 S = ZERO 00247 ELSE 00248 S = H( KWTOP, KWTOP-1 ) 00249 END IF 00250 * 00251 IF( KBOT.EQ.KWTOP ) THEN 00252 * 00253 * ==== 1-by-1 deflation window: not much to do ==== 00254 * 00255 SH( KWTOP ) = H( KWTOP, KWTOP ) 00256 NS = 1 00257 ND = 0 00258 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, 00259 $ KWTOP ) ) ) ) THEN 00260 NS = 0 00261 ND = 1 00262 IF( KWTOP.GT.KTOP ) 00263 $ H( KWTOP, KWTOP-1 ) = ZERO 00264 END IF 00265 WORK( 1 ) = ONE 00266 RETURN 00267 END IF 00268 * 00269 * ==== Convert to spike-triangular form. (In case of a 00270 * . rare QR failure, this routine continues to do 00271 * . aggressive early deflation using that part of 00272 * . the deflation window that converged using INFQR 00273 * . here and there to keep track.) ==== 00274 * 00275 CALL CLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) 00276 CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) 00277 * 00278 CALL CLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) 00279 NMIN = ILAENV( 12, 'CLAQR3', 'SV', JW, 1, JW, LWORK ) 00280 IF( JW.GT.NMIN ) THEN 00281 CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, 00282 $ JW, V, LDV, WORK, LWORK, INFQR ) 00283 ELSE 00284 CALL CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, 00285 $ JW, V, LDV, INFQR ) 00286 END IF 00287 * 00288 * ==== Deflation detection loop ==== 00289 * 00290 NS = JW 00291 ILST = INFQR + 1 00292 DO 10 KNT = INFQR + 1, JW 00293 * 00294 * ==== Small spike tip deflation test ==== 00295 * 00296 FOO = CABS1( T( NS, NS ) ) 00297 IF( FOO.EQ.RZERO ) 00298 $ FOO = CABS1( S ) 00299 IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) 00300 $ THEN 00301 * 00302 * ==== One more converged eigenvalue ==== 00303 * 00304 NS = NS - 1 00305 ELSE 00306 * 00307 * ==== One undeflatable eigenvalue. Move it up out of the 00308 * . way. (CTREXC can not fail in this case.) ==== 00309 * 00310 IFST = NS 00311 CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 00312 ILST = ILST + 1 00313 END IF 00314 10 CONTINUE 00315 * 00316 * ==== Return to Hessenberg form ==== 00317 * 00318 IF( NS.EQ.0 ) 00319 $ S = ZERO 00320 * 00321 IF( NS.LT.JW ) THEN 00322 * 00323 * ==== sorting the diagonal of T improves accuracy for 00324 * . graded matrices. ==== 00325 * 00326 DO 30 I = INFQR + 1, NS 00327 IFST = I 00328 DO 20 J = I + 1, NS 00329 IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) 00330 $ IFST = J 00331 20 CONTINUE 00332 ILST = I 00333 IF( IFST.NE.ILST ) 00334 $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) 00335 30 CONTINUE 00336 END IF 00337 * 00338 * ==== Restore shift/eigenvalue array from T ==== 00339 * 00340 DO 40 I = INFQR + 1, JW 00341 SH( KWTOP+I-1 ) = T( I, I ) 00342 40 CONTINUE 00343 * 00344 * 00345 IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN 00346 IF( NS.GT.1 .AND. S.NE.ZERO ) THEN 00347 * 00348 * ==== Reflect spike back into lower triangle ==== 00349 * 00350 CALL CCOPY( NS, V, LDV, WORK, 1 ) 00351 DO 50 I = 1, NS 00352 WORK( I ) = CONJG( WORK( I ) ) 00353 50 CONTINUE 00354 BETA = WORK( 1 ) 00355 CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU ) 00356 WORK( 1 ) = ONE 00357 * 00358 CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) 00359 * 00360 CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, 00361 $ WORK( JW+1 ) ) 00362 CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, 00363 $ WORK( JW+1 ) ) 00364 CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, 00365 $ WORK( JW+1 ) ) 00366 * 00367 CALL CGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), 00368 $ LWORK-JW, INFO ) 00369 END IF 00370 * 00371 * ==== Copy updated reduced window into place ==== 00372 * 00373 IF( KWTOP.GT.1 ) 00374 $ H( KWTOP, KWTOP-1 ) = S*CONJG( V( 1, 1 ) ) 00375 CALL CLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) 00376 CALL CCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), 00377 $ LDH+1 ) 00378 * 00379 * ==== Accumulate orthogonal matrix in order update 00380 * . H and Z, if requested. ==== 00381 * 00382 IF( NS.GT.1 .AND. S.NE.ZERO ) 00383 $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, 00384 $ WORK( JW+1 ), LWORK-JW, INFO ) 00385 * 00386 * ==== Update vertical slab in H ==== 00387 * 00388 IF( WANTT ) THEN 00389 LTOP = 1 00390 ELSE 00391 LTOP = KTOP 00392 END IF 00393 DO 60 KROW = LTOP, KWTOP - 1, NV 00394 KLN = MIN( NV, KWTOP-KROW ) 00395 CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), 00396 $ LDH, V, LDV, ZERO, WV, LDWV ) 00397 CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) 00398 60 CONTINUE 00399 * 00400 * ==== Update horizontal slab in H ==== 00401 * 00402 IF( WANTT ) THEN 00403 DO 70 KCOL = KBOT + 1, N, NH 00404 KLN = MIN( NH, N-KCOL+1 ) 00405 CALL CGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, 00406 $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) 00407 CALL CLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), 00408 $ LDH ) 00409 70 CONTINUE 00410 END IF 00411 * 00412 * ==== Update vertical slab in Z ==== 00413 * 00414 IF( WANTZ ) THEN 00415 DO 80 KROW = ILOZ, IHIZ, NV 00416 KLN = MIN( NV, IHIZ-KROW+1 ) 00417 CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), 00418 $ LDZ, V, LDV, ZERO, WV, LDWV ) 00419 CALL CLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), 00420 $ LDZ ) 00421 80 CONTINUE 00422 END IF 00423 END IF 00424 * 00425 * ==== Return the number of deflations ... ==== 00426 * 00427 ND = JW - NS 00428 * 00429 * ==== ... and the number of shifts. (Subtracting 00430 * . INFQR from the spike length takes care 00431 * . of the case of a rare QR failure while 00432 * . calculating eigenvalues of the deflation 00433 * . window.) ==== 00434 * 00435 NS = NS - INFQR 00436 * 00437 * ==== Return optimal workspace. ==== 00438 * 00439 WORK( 1 ) = CMPLX( LWKOPT, 0 ) 00440 * 00441 * ==== End of CLAQR3 ==== 00442 * 00443 END
1.7.3 
