 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, 00002 $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, 00003 $ LWORK, INFO ) 00004 * 00005 * -- LAPACK routine (version 3.3.1) -- 00006 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00007 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00008 * -- April 2009 -- 00009 * 00010 * .. Scalar Arguments .. 00011 CHARACTER COMPQ, COMPZ, JOB 00012 INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N 00013 * .. 00014 * .. Array Arguments .. 00015 REAL ALPHAI( * ), ALPHAR( * ), BETA( * ), 00016 $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), 00017 $ WORK( * ), Z( LDZ, * ) 00018 * .. 00019 * 00020 * Purpose 00021 * ======= 00022 * 00023 * SHGEQZ computes the eigenvalues of a real matrix pair (H,T), 00024 * where H is an upper Hessenberg matrix and T is upper triangular, 00025 * using the double-shift QZ method. 00026 * Matrix pairs of this type are produced by the reduction to 00027 * generalized upper Hessenberg form of a real matrix pair (A,B): 00028 * 00029 * A = Q1*H*Z1**T, B = Q1*T*Z1**T, 00030 * 00031 * as computed by SGGHRD. 00032 * 00033 * If JOB='S', then the Hessenberg-triangular pair (H,T) is 00034 * also reduced to generalized Schur form, 00035 * 00036 * H = Q*S*Z**T, T = Q*P*Z**T, 00037 * 00038 * where Q and Z are orthogonal matrices, P is an upper triangular 00039 * matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 00040 * diagonal blocks. 00041 * 00042 * The 1-by-1 blocks correspond to real eigenvalues of the matrix pair 00043 * (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of 00044 * eigenvalues. 00045 * 00046 * Additionally, the 2-by-2 upper triangular diagonal blocks of P 00047 * corresponding to 2-by-2 blocks of S are reduced to positive diagonal 00048 * form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, 00049 * P(j,j) > 0, and P(j+1,j+1) > 0. 00050 * 00051 * Optionally, the orthogonal matrix Q from the generalized Schur 00052 * factorization may be postmultiplied into an input matrix Q1, and the 00053 * orthogonal matrix Z may be postmultiplied into an input matrix Z1. 00054 * If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced 00055 * the matrix pair (A,B) to generalized upper Hessenberg form, then the 00056 * output matrices Q1*Q and Z1*Z are the orthogonal factors from the 00057 * generalized Schur factorization of (A,B): 00058 * 00059 * A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. 00060 * 00061 * To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, 00062 * of (A,B)) are computed as a pair of values (alpha,beta), where alpha is 00063 * complex and beta real. 00064 * If beta is nonzero, lambda = alpha / beta is an eigenvalue of the 00065 * generalized nonsymmetric eigenvalue problem (GNEP) 00066 * A*x = lambda*B*x 00067 * and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the 00068 * alternate form of the GNEP 00069 * mu*A*y = B*y. 00070 * Real eigenvalues can be read directly from the generalized Schur 00071 * form: 00072 * alpha = S(i,i), beta = P(i,i). 00073 * 00074 * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix 00075 * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), 00076 * pp. 241--256. 00077 * 00078 * Arguments 00079 * ========= 00080 * 00081 * JOB (input) CHARACTER*1 00082 * = 'E': Compute eigenvalues only; 00083 * = 'S': Compute eigenvalues and the Schur form. 00084 * 00085 * COMPQ (input) CHARACTER*1 00086 * = 'N': Left Schur vectors (Q) are not computed; 00087 * = 'I': Q is initialized to the unit matrix and the matrix Q 00088 * of left Schur vectors of (H,T) is returned; 00089 * = 'V': Q must contain an orthogonal matrix Q1 on entry and 00090 * the product Q1*Q is returned. 00091 * 00092 * COMPZ (input) CHARACTER*1 00093 * = 'N': Right Schur vectors (Z) are not computed; 00094 * = 'I': Z is initialized to the unit matrix and the matrix Z 00095 * of right Schur vectors of (H,T) is returned; 00096 * = 'V': Z must contain an orthogonal matrix Z1 on entry and 00097 * the product Z1*Z is returned. 00098 * 00099 * N (input) INTEGER 00100 * The order of the matrices H, T, Q, and Z. N >= 0. 00101 * 00102 * ILO (input) INTEGER 00103 * IHI (input) INTEGER 00104 * ILO and IHI mark the rows and columns of H which are in 00105 * Hessenberg form. It is assumed that A is already upper 00106 * triangular in rows and columns 1:ILO-1 and IHI+1:N. 00107 * If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. 00108 * 00109 * H (input/output) REAL array, dimension (LDH, N) 00110 * On entry, the N-by-N upper Hessenberg matrix H. 00111 * On exit, if JOB = 'S', H contains the upper quasi-triangular 00112 * matrix S from the generalized Schur factorization. 00113 * If JOB = 'E', the diagonal blocks of H match those of S, but 00114 * the rest of H is unspecified. 00115 * 00116 * LDH (input) INTEGER 00117 * The leading dimension of the array H. LDH >= max( 1, N ). 00118 * 00119 * T (input/output) REAL array, dimension (LDT, N) 00120 * On entry, the N-by-N upper triangular matrix T. 00121 * On exit, if JOB = 'S', T contains the upper triangular 00122 * matrix P from the generalized Schur factorization; 00123 * 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S 00124 * are reduced to positive diagonal form, i.e., if H(j+1,j) is 00125 * non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and 00126 * T(j+1,j+1) > 0. 00127 * If JOB = 'E', the diagonal blocks of T match those of P, but 00128 * the rest of T is unspecified. 00129 * 00130 * LDT (input) INTEGER 00131 * The leading dimension of the array T. LDT >= max( 1, N ). 00132 * 00133 * ALPHAR (output) REAL array, dimension (N) 00134 * The real parts of each scalar alpha defining an eigenvalue 00135 * of GNEP. 00136 * 00137 * ALPHAI (output) REAL array, dimension (N) 00138 * The imaginary parts of each scalar alpha defining an 00139 * eigenvalue of GNEP. 00140 * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if 00141 * positive, then the j-th and (j+1)-st eigenvalues are a 00142 * complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). 00143 * 00144 * BETA (output) REAL array, dimension (N) 00145 * The scalars beta that define the eigenvalues of GNEP. 00146 * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and 00147 * beta = BETA(j) represent the j-th eigenvalue of the matrix 00148 * pair (A,B), in one of the forms lambda = alpha/beta or 00149 * mu = beta/alpha. Since either lambda or mu may overflow, 00150 * they should not, in general, be computed. 00151 * 00152 * Q (input/output) REAL array, dimension (LDQ, N) 00153 * On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in 00154 * the reduction of (A,B) to generalized Hessenberg form. 00155 * On exit, if COMPZ = 'I', the orthogonal matrix of left Schur 00156 * vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix 00157 * of left Schur vectors of (A,B). 00158 * Not referenced if COMPZ = 'N'. 00159 * 00160 * LDQ (input) INTEGER 00161 * The leading dimension of the array Q. LDQ >= 1. 00162 * If COMPQ='V' or 'I', then LDQ >= N. 00163 * 00164 * Z (input/output) REAL array, dimension (LDZ, N) 00165 * On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in 00166 * the reduction of (A,B) to generalized Hessenberg form. 00167 * On exit, if COMPZ = 'I', the orthogonal matrix of 00168 * right Schur vectors of (H,T), and if COMPZ = 'V', the 00169 * orthogonal matrix of right Schur vectors of (A,B). 00170 * Not referenced if COMPZ = 'N'. 00171 * 00172 * LDZ (input) INTEGER 00173 * The leading dimension of the array Z. LDZ >= 1. 00174 * If COMPZ='V' or 'I', then LDZ >= N. 00175 * 00176 * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) 00177 * On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. 00178 * 00179 * LWORK (input) INTEGER 00180 * The dimension of the array WORK. LWORK >= max(1,N). 00181 * 00182 * If LWORK = -1, then a workspace query is assumed; the routine 00183 * only calculates the optimal size of the WORK array, returns 00184 * this value as the first entry of the WORK array, and no error 00185 * message related to LWORK is issued by XERBLA. 00186 * 00187 * INFO (output) INTEGER 00188 * = 0: successful exit 00189 * < 0: if INFO = -i, the i-th argument had an illegal value 00190 * = 1,...,N: the QZ iteration did not converge. (H,T) is not 00191 * in Schur form, but ALPHAR(i), ALPHAI(i), and 00192 * BETA(i), i=INFO+1,...,N should be correct. 00193 * = N+1,...,2*N: the shift calculation failed. (H,T) is not 00194 * in Schur form, but ALPHAR(i), ALPHAI(i), and 00195 * BETA(i), i=INFO-N+1,...,N should be correct. 00196 * 00197 * Further Details 00198 * =============== 00199 * 00200 * Iteration counters: 00201 * 00202 * JITER -- counts iterations. 00203 * IITER -- counts iterations run since ILAST was last 00204 * changed. This is therefore reset only when a 1-by-1 or 00205 * 2-by-2 block deflates off the bottom. 00206 * 00207 * ===================================================================== 00208 * 00209 * .. Parameters .. 00210 * $ SAFETY = 1.0E+0 ) 00211 REAL HALF, ZERO, ONE, SAFETY 00212 PARAMETER ( HALF = 0.5E+0, ZERO = 0.0E+0, ONE = 1.0E+0, 00213 $ SAFETY = 1.0E+2 ) 00214 * .. 00215 * .. Local Scalars .. 00216 LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ, 00217 $ LQUERY 00218 INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, 00219 $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, 00220 $ JR, MAXIT 00221 REAL A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11, 00222 $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L, 00223 $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I, 00224 $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, 00225 $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, 00226 $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, 00227 $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, 00228 $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, 00229 $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, 00230 $ WR2 00231 * .. 00232 * .. Local Arrays .. 00233 REAL V( 3 ) 00234 * .. 00235 * .. External Functions .. 00236 LOGICAL LSAME 00237 REAL SLAMCH, SLANHS, SLAPY2, SLAPY3 00238 EXTERNAL LSAME, SLAMCH, SLANHS, SLAPY2, SLAPY3 00239 * .. 00240 * .. External Subroutines .. 00241 EXTERNAL SLAG2, SLARFG, SLARTG, SLASET, SLASV2, SROT, 00242 $ XERBLA 00243 * .. 00244 * .. Intrinsic Functions .. 00245 INTRINSIC ABS, MAX, MIN, REAL, SQRT 00246 * .. 00247 * .. Executable Statements .. 00248 * 00249 * Decode JOB, COMPQ, COMPZ 00250 * 00251 IF( LSAME( JOB, 'E' ) ) THEN 00252 ILSCHR = .FALSE. 00253 ISCHUR = 1 00254 ELSE IF( LSAME( JOB, 'S' ) ) THEN 00255 ILSCHR = .TRUE. 00256 ISCHUR = 2 00257 ELSE 00258 ISCHUR = 0 00259 END IF 00260 * 00261 IF( LSAME( COMPQ, 'N' ) ) THEN 00262 ILQ = .FALSE. 00263 ICOMPQ = 1 00264 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN 00265 ILQ = .TRUE. 00266 ICOMPQ = 2 00267 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN 00268 ILQ = .TRUE. 00269 ICOMPQ = 3 00270 ELSE 00271 ICOMPQ = 0 00272 END IF 00273 * 00274 IF( LSAME( COMPZ, 'N' ) ) THEN 00275 ILZ = .FALSE. 00276 ICOMPZ = 1 00277 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN 00278 ILZ = .TRUE. 00279 ICOMPZ = 2 00280 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN 00281 ILZ = .TRUE. 00282 ICOMPZ = 3 00283 ELSE 00284 ICOMPZ = 0 00285 END IF 00286 * 00287 * Check Argument Values 00288 * 00289 INFO = 0 00290 WORK( 1 ) = MAX( 1, N ) 00291 LQUERY = ( LWORK.EQ.-1 ) 00292 IF( ISCHUR.EQ.0 ) THEN 00293 INFO = -1 00294 ELSE IF( ICOMPQ.EQ.0 ) THEN 00295 INFO = -2 00296 ELSE IF( ICOMPZ.EQ.0 ) THEN 00297 INFO = -3 00298 ELSE IF( N.LT.0 ) THEN 00299 INFO = -4 00300 ELSE IF( ILO.LT.1 ) THEN 00301 INFO = -5 00302 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN 00303 INFO = -6 00304 ELSE IF( LDH.LT.N ) THEN 00305 INFO = -8 00306 ELSE IF( LDT.LT.N ) THEN 00307 INFO = -10 00308 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN 00309 INFO = -15 00310 ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN 00311 INFO = -17 00312 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN 00313 INFO = -19 00314 END IF 00315 IF( INFO.NE.0 ) THEN 00316 CALL XERBLA( 'SHGEQZ', -INFO ) 00317 RETURN 00318 ELSE IF( LQUERY ) THEN 00319 RETURN 00320 END IF 00321 * 00322 * Quick return if possible 00323 * 00324 IF( N.LE.0 ) THEN 00325 WORK( 1 ) = REAL( 1 ) 00326 RETURN 00327 END IF 00328 * 00329 * Initialize Q and Z 00330 * 00331 IF( ICOMPQ.EQ.3 ) 00332 $ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) 00333 IF( ICOMPZ.EQ.3 ) 00334 $ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) 00335 * 00336 * Machine Constants 00337 * 00338 IN = IHI + 1 - ILO 00339 SAFMIN = SLAMCH( 'S' ) 00340 SAFMAX = ONE / SAFMIN 00341 ULP = SLAMCH( 'E' )*SLAMCH( 'B' ) 00342 ANORM = SLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) 00343 BNORM = SLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) 00344 ATOL = MAX( SAFMIN, ULP*ANORM ) 00345 BTOL = MAX( SAFMIN, ULP*BNORM ) 00346 ASCALE = ONE / MAX( SAFMIN, ANORM ) 00347 BSCALE = ONE / MAX( SAFMIN, BNORM ) 00348 * 00349 * Set Eigenvalues IHI+1:N 00350 * 00351 DO 30 J = IHI + 1, N 00352 IF( T( J, J ).LT.ZERO ) THEN 00353 IF( ILSCHR ) THEN 00354 DO 10 JR = 1, J 00355 H( JR, J ) = -H( JR, J ) 00356 T( JR, J ) = -T( JR, J ) 00357 10 CONTINUE 00358 ELSE 00359 H( J, J ) = -H( J, J ) 00360 T( J, J ) = -T( J, J ) 00361 END IF 00362 IF( ILZ ) THEN 00363 DO 20 JR = 1, N 00364 Z( JR, J ) = -Z( JR, J ) 00365 20 CONTINUE 00366 END IF 00367 END IF 00368 ALPHAR( J ) = H( J, J ) 00369 ALPHAI( J ) = ZERO 00370 BETA( J ) = T( J, J ) 00371 30 CONTINUE 00372 * 00373 * If IHI < ILO, skip QZ steps 00374 * 00375 IF( IHI.LT.ILO ) 00376 $ GO TO 380 00377 * 00378 * MAIN QZ ITERATION LOOP 00379 * 00380 * Initialize dynamic indices 00381 * 00382 * Eigenvalues ILAST+1:N have been found. 00383 * Column operations modify rows IFRSTM:whatever. 00384 * Row operations modify columns whatever:ILASTM. 00385 * 00386 * If only eigenvalues are being computed, then 00387 * IFRSTM is the row of the last splitting row above row ILAST; 00388 * this is always at least ILO. 00389 * IITER counts iterations since the last eigenvalue was found, 00390 * to tell when to use an extraordinary shift. 00391 * MAXIT is the maximum number of QZ sweeps allowed. 00392 * 00393 ILAST = IHI 00394 IF( ILSCHR ) THEN 00395 IFRSTM = 1 00396 ILASTM = N 00397 ELSE 00398 IFRSTM = ILO 00399 ILASTM = IHI 00400 END IF 00401 IITER = 0 00402 ESHIFT = ZERO 00403 MAXIT = 30*( IHI-ILO+1 ) 00404 * 00405 DO 360 JITER = 1, MAXIT 00406 * 00407 * Split the matrix if possible. 00408 * 00409 * Two tests: 00410 * 1: H(j,j-1)=0 or j=ILO 00411 * 2: T(j,j)=0 00412 * 00413 IF( ILAST.EQ.ILO ) THEN 00414 * 00415 * Special case: j=ILAST 00416 * 00417 GO TO 80 00418 ELSE 00419 IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN 00420 H( ILAST, ILAST-1 ) = ZERO 00421 GO TO 80 00422 END IF 00423 END IF 00424 * 00425 IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN 00426 T( ILAST, ILAST ) = ZERO 00427 GO TO 70 00428 END IF 00429 * 00430 * General case: j<ILAST 00431 * 00432 DO 60 J = ILAST - 1, ILO, -1 00433 * 00434 * Test 1: for H(j,j-1)=0 or j=ILO 00435 * 00436 IF( J.EQ.ILO ) THEN 00437 ILAZRO = .TRUE. 00438 ELSE 00439 IF( ABS( H( J, J-1 ) ).LE.ATOL ) THEN 00440 H( J, J-1 ) = ZERO 00441 ILAZRO = .TRUE. 00442 ELSE 00443 ILAZRO = .FALSE. 00444 END IF 00445 END IF 00446 * 00447 * Test 2: for T(j,j)=0 00448 * 00449 IF( ABS( T( J, J ) ).LT.BTOL ) THEN 00450 T( J, J ) = ZERO 00451 * 00452 * Test 1a: Check for 2 consecutive small subdiagonals in A 00453 * 00454 ILAZR2 = .FALSE. 00455 IF( .NOT.ILAZRO ) THEN 00456 TEMP = ABS( H( J, J-1 ) ) 00457 TEMP2 = ABS( H( J, J ) ) 00458 TEMPR = MAX( TEMP, TEMP2 ) 00459 IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN 00460 TEMP = TEMP / TEMPR 00461 TEMP2 = TEMP2 / TEMPR 00462 END IF 00463 IF( TEMP*( ASCALE*ABS( H( J+1, J ) ) ).LE.TEMP2* 00464 $ ( ASCALE*ATOL ) )ILAZR2 = .TRUE. 00465 END IF 00466 * 00467 * If both tests pass (1 & 2), i.e., the leading diagonal 00468 * element of B in the block is zero, split a 1x1 block off 00469 * at the top. (I.e., at the J-th row/column) The leading 00470 * diagonal element of the remainder can also be zero, so 00471 * this may have to be done repeatedly. 00472 * 00473 IF( ILAZRO .OR. ILAZR2 ) THEN 00474 DO 40 JCH = J, ILAST - 1 00475 TEMP = H( JCH, JCH ) 00476 CALL SLARTG( TEMP, H( JCH+1, JCH ), C, S, 00477 $ H( JCH, JCH ) ) 00478 H( JCH+1, JCH ) = ZERO 00479 CALL SROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH, 00480 $ H( JCH+1, JCH+1 ), LDH, C, S ) 00481 CALL SROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT, 00482 $ T( JCH+1, JCH+1 ), LDT, C, S ) 00483 IF( ILQ ) 00484 $ CALL SROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, 00485 $ C, S ) 00486 IF( ILAZR2 ) 00487 $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C 00488 ILAZR2 = .FALSE. 00489 IF( ABS( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN 00490 IF( JCH+1.GE.ILAST ) THEN 00491 GO TO 80 00492 ELSE 00493 IFIRST = JCH + 1 00494 GO TO 110 00495 END IF 00496 END IF 00497 T( JCH+1, JCH+1 ) = ZERO 00498 40 CONTINUE 00499 GO TO 70 00500 ELSE 00501 * 00502 * Only test 2 passed -- chase the zero to T(ILAST,ILAST) 00503 * Then process as in the case T(ILAST,ILAST)=0 00504 * 00505 DO 50 JCH = J, ILAST - 1 00506 TEMP = T( JCH, JCH+1 ) 00507 CALL SLARTG( TEMP, T( JCH+1, JCH+1 ), C, S, 00508 $ T( JCH, JCH+1 ) ) 00509 T( JCH+1, JCH+1 ) = ZERO 00510 IF( JCH.LT.ILASTM-1 ) 00511 $ CALL SROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT, 00512 $ T( JCH+1, JCH+2 ), LDT, C, S ) 00513 CALL SROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH, 00514 $ H( JCH+1, JCH-1 ), LDH, C, S ) 00515 IF( ILQ ) 00516 $ CALL SROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1, 00517 $ C, S ) 00518 TEMP = H( JCH+1, JCH ) 00519 CALL SLARTG( TEMP, H( JCH+1, JCH-1 ), C, S, 00520 $ H( JCH+1, JCH ) ) 00521 H( JCH+1, JCH-1 ) = ZERO 00522 CALL SROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1, 00523 $ H( IFRSTM, JCH-1 ), 1, C, S ) 00524 CALL SROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1, 00525 $ T( IFRSTM, JCH-1 ), 1, C, S ) 00526 IF( ILZ ) 00527 $ CALL SROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1, 00528 $ C, S ) 00529 50 CONTINUE 00530 GO TO 70 00531 END IF 00532 ELSE IF( ILAZRO ) THEN 00533 * 00534 * Only test 1 passed -- work on J:ILAST 00535 * 00536 IFIRST = J 00537 GO TO 110 00538 END IF 00539 * 00540 * Neither test passed -- try next J 00541 * 00542 60 CONTINUE 00543 * 00544 * (Drop-through is "impossible") 00545 * 00546 INFO = N + 1 00547 GO TO 420 00548 * 00549 * T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a 00550 * 1x1 block. 00551 * 00552 70 CONTINUE 00553 TEMP = H( ILAST, ILAST ) 00554 CALL SLARTG( TEMP, H( ILAST, ILAST-1 ), C, S, 00555 $ H( ILAST, ILAST ) ) 00556 H( ILAST, ILAST-1 ) = ZERO 00557 CALL SROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1, 00558 $ H( IFRSTM, ILAST-1 ), 1, C, S ) 00559 CALL SROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1, 00560 $ T( IFRSTM, ILAST-1 ), 1, C, S ) 00561 IF( ILZ ) 00562 $ CALL SROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S ) 00563 * 00564 * H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, 00565 * and BETA 00566 * 00567 80 CONTINUE 00568 IF( T( ILAST, ILAST ).LT.ZERO ) THEN 00569 IF( ILSCHR ) THEN 00570 DO 90 J = IFRSTM, ILAST 00571 H( J, ILAST ) = -H( J, ILAST ) 00572 T( J, ILAST ) = -T( J, ILAST ) 00573 90 CONTINUE 00574 ELSE 00575 H( ILAST, ILAST ) = -H( ILAST, ILAST ) 00576 T( ILAST, ILAST ) = -T( ILAST, ILAST ) 00577 END IF 00578 IF( ILZ ) THEN 00579 DO 100 J = 1, N 00580 Z( J, ILAST ) = -Z( J, ILAST ) 00581 100 CONTINUE 00582 END IF 00583 END IF 00584 ALPHAR( ILAST ) = H( ILAST, ILAST ) 00585 ALPHAI( ILAST ) = ZERO 00586 BETA( ILAST ) = T( ILAST, ILAST ) 00587 * 00588 * Go to next block -- exit if finished. 00589 * 00590 ILAST = ILAST - 1 00591 IF( ILAST.LT.ILO ) 00592 $ GO TO 380 00593 * 00594 * Reset counters 00595 * 00596 IITER = 0 00597 ESHIFT = ZERO 00598 IF( .NOT.ILSCHR ) THEN 00599 ILASTM = ILAST 00600 IF( IFRSTM.GT.ILAST ) 00601 $ IFRSTM = ILO 00602 END IF 00603 GO TO 350 00604 * 00605 * QZ step 00606 * 00607 * This iteration only involves rows/columns IFIRST:ILAST. We 00608 * assume IFIRST < ILAST, and that the diagonal of B is non-zero. 00609 * 00610 110 CONTINUE 00611 IITER = IITER + 1 00612 IF( .NOT.ILSCHR ) THEN 00613 IFRSTM = IFIRST 00614 END IF 00615 * 00616 * Compute single shifts. 00617 * 00618 * At this point, IFIRST < ILAST, and the diagonal elements of 00619 * T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in 00620 * magnitude) 00621 * 00622 IF( ( IITER / 10 )*10.EQ.IITER ) THEN 00623 * 00624 * Exceptional shift. Chosen for no particularly good reason. 00625 * (Single shift only.) 00626 * 00627 IF( ( REAL( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT. 00628 $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN 00629 ESHIFT = ESHIFT + H( ILAST-1, ILAST ) / 00630 $ T( ILAST-1, ILAST-1 ) 00631 ELSE 00632 ESHIFT = ESHIFT + ONE / ( SAFMIN*REAL( MAXIT ) ) 00633 END IF 00634 S1 = ONE 00635 WR = ESHIFT 00636 * 00637 ELSE 00638 * 00639 * Shifts based on the generalized eigenvalues of the 00640 * bottom-right 2x2 block of A and B. The first eigenvalue 00641 * returned by SLAG2 is the Wilkinson shift (AEP p.512), 00642 * 00643 CALL SLAG2( H( ILAST-1, ILAST-1 ), LDH, 00644 $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, 00645 $ S2, WR, WR2, WI ) 00646 * 00647 TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) ) 00648 IF( WI.NE.ZERO ) 00649 $ GO TO 200 00650 END IF 00651 * 00652 * Fiddle with shift to avoid overflow 00653 * 00654 TEMP = MIN( ASCALE, ONE )*( HALF*SAFMAX ) 00655 IF( S1.GT.TEMP ) THEN 00656 SCALE = TEMP / S1 00657 ELSE 00658 SCALE = ONE 00659 END IF 00660 * 00661 TEMP = MIN( BSCALE, ONE )*( HALF*SAFMAX ) 00662 IF( ABS( WR ).GT.TEMP ) 00663 $ SCALE = MIN( SCALE, TEMP / ABS( WR ) ) 00664 S1 = SCALE*S1 00665 WR = SCALE*WR 00666 * 00667 * Now check for two consecutive small subdiagonals. 00668 * 00669 DO 120 J = ILAST - 1, IFIRST + 1, -1 00670 ISTART = J 00671 TEMP = ABS( S1*H( J, J-1 ) ) 00672 TEMP2 = ABS( S1*H( J, J )-WR*T( J, J ) ) 00673 TEMPR = MAX( TEMP, TEMP2 ) 00674 IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN 00675 TEMP = TEMP / TEMPR 00676 TEMP2 = TEMP2 / TEMPR 00677 END IF 00678 IF( ABS( ( ASCALE*H( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )* 00679 $ TEMP2 )GO TO 130 00680 120 CONTINUE 00681 * 00682 ISTART = IFIRST 00683 130 CONTINUE 00684 * 00685 * Do an implicit single-shift QZ sweep. 00686 * 00687 * Initial Q 00688 * 00689 TEMP = S1*H( ISTART, ISTART ) - WR*T( ISTART, ISTART ) 00690 TEMP2 = S1*H( ISTART+1, ISTART ) 00691 CALL SLARTG( TEMP, TEMP2, C, S, TEMPR ) 00692 * 00693 * Sweep 00694 * 00695 DO 190 J = ISTART, ILAST - 1 00696 IF( J.GT.ISTART ) THEN 00697 TEMP = H( J, J-1 ) 00698 CALL SLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) 00699 H( J+1, J-1 ) = ZERO 00700 END IF 00701 * 00702 DO 140 JC = J, ILASTM 00703 TEMP = C*H( J, JC ) + S*H( J+1, JC ) 00704 H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) 00705 H( J, JC ) = TEMP 00706 TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) 00707 T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) 00708 T( J, JC ) = TEMP2 00709 140 CONTINUE 00710 IF( ILQ ) THEN 00711 DO 150 JR = 1, N 00712 TEMP = C*Q( JR, J ) + S*Q( JR, J+1 ) 00713 Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 ) 00714 Q( JR, J ) = TEMP 00715 150 CONTINUE 00716 END IF 00717 * 00718 TEMP = T( J+1, J+1 ) 00719 CALL SLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) 00720 T( J+1, J ) = ZERO 00721 * 00722 DO 160 JR = IFRSTM, MIN( J+2, ILAST ) 00723 TEMP = C*H( JR, J+1 ) + S*H( JR, J ) 00724 H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) 00725 H( JR, J+1 ) = TEMP 00726 160 CONTINUE 00727 DO 170 JR = IFRSTM, J 00728 TEMP = C*T( JR, J+1 ) + S*T( JR, J ) 00729 T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) 00730 T( JR, J+1 ) = TEMP 00731 170 CONTINUE 00732 IF( ILZ ) THEN 00733 DO 180 JR = 1, N 00734 TEMP = C*Z( JR, J+1 ) + S*Z( JR, J ) 00735 Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J ) 00736 Z( JR, J+1 ) = TEMP 00737 180 CONTINUE 00738 END IF 00739 190 CONTINUE 00740 * 00741 GO TO 350 00742 * 00743 * Use Francis double-shift 00744 * 00745 * Note: the Francis double-shift should work with real shifts, 00746 * but only if the block is at least 3x3. 00747 * This code may break if this point is reached with 00748 * a 2x2 block with real eigenvalues. 00749 * 00750 200 CONTINUE 00751 IF( IFIRST+1.EQ.ILAST ) THEN 00752 * 00753 * Special case -- 2x2 block with complex eigenvectors 00754 * 00755 * Step 1: Standardize, that is, rotate so that 00756 * 00757 * ( B11 0 ) 00758 * B = ( ) with B11 non-negative. 00759 * ( 0 B22 ) 00760 * 00761 CALL SLASV2( T( ILAST-1, ILAST-1 ), T( ILAST-1, ILAST ), 00762 $ T( ILAST, ILAST ), B22, B11, SR, CR, SL, CL ) 00763 * 00764 IF( B11.LT.ZERO ) THEN 00765 CR = -CR 00766 SR = -SR 00767 B11 = -B11 00768 B22 = -B22 00769 END IF 00770 * 00771 CALL SROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH, 00772 $ H( ILAST, ILAST-1 ), LDH, CL, SL ) 00773 CALL SROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1, 00774 $ H( IFRSTM, ILAST ), 1, CR, SR ) 00775 * 00776 IF( ILAST.LT.ILASTM ) 00777 $ CALL SROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT, 00778 $ T( ILAST, ILAST+1 ), LDT, CL, SL ) 00779 IF( IFRSTM.LT.ILAST-1 ) 00780 $ CALL SROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1, 00781 $ T( IFRSTM, ILAST ), 1, CR, SR ) 00782 * 00783 IF( ILQ ) 00784 $ CALL SROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL, 00785 $ SL ) 00786 IF( ILZ ) 00787 $ CALL SROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR, 00788 $ SR ) 00789 * 00790 T( ILAST-1, ILAST-1 ) = B11 00791 T( ILAST-1, ILAST ) = ZERO 00792 T( ILAST, ILAST-1 ) = ZERO 00793 T( ILAST, ILAST ) = B22 00794 * 00795 * If B22 is negative, negate column ILAST 00796 * 00797 IF( B22.LT.ZERO ) THEN 00798 DO 210 J = IFRSTM, ILAST 00799 H( J, ILAST ) = -H( J, ILAST ) 00800 T( J, ILAST ) = -T( J, ILAST ) 00801 210 CONTINUE 00802 * 00803 IF( ILZ ) THEN 00804 DO 220 J = 1, N 00805 Z( J, ILAST ) = -Z( J, ILAST ) 00806 220 CONTINUE 00807 END IF 00808 END IF 00809 * 00810 * Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.) 00811 * 00812 * Recompute shift 00813 * 00814 CALL SLAG2( H( ILAST-1, ILAST-1 ), LDH, 00815 $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1, 00816 $ TEMP, WR, TEMP2, WI ) 00817 * 00818 * If standardization has perturbed the shift onto real line, 00819 * do another (real single-shift) QR step. 00820 * 00821 IF( WI.EQ.ZERO ) 00822 $ GO TO 350 00823 S1INV = ONE / S1 00824 * 00825 * Do EISPACK (QZVAL) computation of alpha and beta 00826 * 00827 A11 = H( ILAST-1, ILAST-1 ) 00828 A21 = H( ILAST, ILAST-1 ) 00829 A12 = H( ILAST-1, ILAST ) 00830 A22 = H( ILAST, ILAST ) 00831 * 00832 * Compute complex Givens rotation on right 00833 * (Assume some element of C = (sA - wB) > unfl ) 00834 * __ 00835 * (sA - wB) ( CZ -SZ ) 00836 * ( SZ CZ ) 00837 * 00838 C11R = S1*A11 - WR*B11 00839 C11I = -WI*B11 00840 C12 = S1*A12 00841 C21 = S1*A21 00842 C22R = S1*A22 - WR*B22 00843 C22I = -WI*B22 00844 * 00845 IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ 00846 $ ABS( C22R )+ABS( C22I ) ) THEN 00847 T1 = SLAPY3( C12, C11R, C11I ) 00848 CZ = C12 / T1 00849 SZR = -C11R / T1 00850 SZI = -C11I / T1 00851 ELSE 00852 CZ = SLAPY2( C22R, C22I ) 00853 IF( CZ.LE.SAFMIN ) THEN 00854 CZ = ZERO 00855 SZR = ONE 00856 SZI = ZERO 00857 ELSE 00858 TEMPR = C22R / CZ 00859 TEMPI = C22I / CZ 00860 T1 = SLAPY2( CZ, C21 ) 00861 CZ = CZ / T1 00862 SZR = -C21*TEMPR / T1 00863 SZI = C21*TEMPI / T1 00864 END IF 00865 END IF 00866 * 00867 * Compute Givens rotation on left 00868 * 00869 * ( CQ SQ ) 00870 * ( __ ) A or B 00871 * ( -SQ CQ ) 00872 * 00873 AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 ) 00874 BN = ABS( B11 ) + ABS( B22 ) 00875 WABS = ABS( WR ) + ABS( WI ) 00876 IF( S1*AN.GT.WABS*BN ) THEN 00877 CQ = CZ*B11 00878 SQR = SZR*B22 00879 SQI = -SZI*B22 00880 ELSE 00881 A1R = CZ*A11 + SZR*A12 00882 A1I = SZI*A12 00883 A2R = CZ*A21 + SZR*A22 00884 A2I = SZI*A22 00885 CQ = SLAPY2( A1R, A1I ) 00886 IF( CQ.LE.SAFMIN ) THEN 00887 CQ = ZERO 00888 SQR = ONE 00889 SQI = ZERO 00890 ELSE 00891 TEMPR = A1R / CQ 00892 TEMPI = A1I / CQ 00893 SQR = TEMPR*A2R + TEMPI*A2I 00894 SQI = TEMPI*A2R - TEMPR*A2I 00895 END IF 00896 END IF 00897 T1 = SLAPY3( CQ, SQR, SQI ) 00898 CQ = CQ / T1 00899 SQR = SQR / T1 00900 SQI = SQI / T1 00901 * 00902 * Compute diagonal elements of QBZ 00903 * 00904 TEMPR = SQR*SZR - SQI*SZI 00905 TEMPI = SQR*SZI + SQI*SZR 00906 B1R = CQ*CZ*B11 + TEMPR*B22 00907 B1I = TEMPI*B22 00908 B1A = SLAPY2( B1R, B1I ) 00909 B2R = CQ*CZ*B22 + TEMPR*B11 00910 B2I = -TEMPI*B11 00911 B2A = SLAPY2( B2R, B2I ) 00912 * 00913 * Normalize so beta > 0, and Im( alpha1 ) > 0 00914 * 00915 BETA( ILAST-1 ) = B1A 00916 BETA( ILAST ) = B2A 00917 ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV 00918 ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV 00919 ALPHAR( ILAST ) = ( WR*B2A )*S1INV 00920 ALPHAI( ILAST ) = -( WI*B2A )*S1INV 00921 * 00922 * Step 3: Go to next block -- exit if finished. 00923 * 00924 ILAST = IFIRST - 1 00925 IF( ILAST.LT.ILO ) 00926 $ GO TO 380 00927 * 00928 * Reset counters 00929 * 00930 IITER = 0 00931 ESHIFT = ZERO 00932 IF( .NOT.ILSCHR ) THEN 00933 ILASTM = ILAST 00934 IF( IFRSTM.GT.ILAST ) 00935 $ IFRSTM = ILO 00936 END IF 00937 GO TO 350 00938 ELSE 00939 * 00940 * Usual case: 3x3 or larger block, using Francis implicit 00941 * double-shift 00942 * 00943 * 2 00944 * Eigenvalue equation is w - c w + d = 0, 00945 * 00946 * -1 2 -1 00947 * so compute 1st column of (A B ) - c A B + d 00948 * using the formula in QZIT (from EISPACK) 00949 * 00950 * We assume that the block is at least 3x3 00951 * 00952 AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / 00953 $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) 00954 AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / 00955 $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) 00956 AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / 00957 $ ( BSCALE*T( ILAST, ILAST ) ) 00958 AD22 = ( ASCALE*H( ILAST, ILAST ) ) / 00959 $ ( BSCALE*T( ILAST, ILAST ) ) 00960 U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) 00961 AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / 00962 $ ( BSCALE*T( IFIRST, IFIRST ) ) 00963 AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / 00964 $ ( BSCALE*T( IFIRST, IFIRST ) ) 00965 AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / 00966 $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) 00967 AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / 00968 $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) 00969 AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / 00970 $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) 00971 U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) 00972 * 00973 V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + 00974 $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L 00975 V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )- 00976 $ ( AD22-AD11L )+AD21*U12 )*AD21L 00977 V( 3 ) = AD32L*AD21L 00978 * 00979 ISTART = IFIRST 00980 * 00981 CALL SLARFG( 3, V( 1 ), V( 2 ), 1, TAU ) 00982 V( 1 ) = ONE 00983 * 00984 * Sweep 00985 * 00986 DO 290 J = ISTART, ILAST - 2 00987 * 00988 * All but last elements: use 3x3 Householder transforms. 00989 * 00990 * Zero (j-1)st column of A 00991 * 00992 IF( J.GT.ISTART ) THEN 00993 V( 1 ) = H( J, J-1 ) 00994 V( 2 ) = H( J+1, J-1 ) 00995 V( 3 ) = H( J+2, J-1 ) 00996 * 00997 CALL SLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) 00998 V( 1 ) = ONE 00999 H( J+1, J-1 ) = ZERO 01000 H( J+2, J-1 ) = ZERO 01001 END IF 01002 * 01003 DO 230 JC = J, ILASTM 01004 TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* 01005 $ H( J+2, JC ) ) 01006 H( J, JC ) = H( J, JC ) - TEMP 01007 H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) 01008 H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) 01009 TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* 01010 $ T( J+2, JC ) ) 01011 T( J, JC ) = T( J, JC ) - TEMP2 01012 T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) 01013 T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) 01014 230 CONTINUE 01015 IF( ILQ ) THEN 01016 DO 240 JR = 1, N 01017 TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* 01018 $ Q( JR, J+2 ) ) 01019 Q( JR, J ) = Q( JR, J ) - TEMP 01020 Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) 01021 Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) 01022 240 CONTINUE 01023 END IF 01024 * 01025 * Zero j-th column of B (see SLAGBC for details) 01026 * 01027 * Swap rows to pivot 01028 * 01029 ILPIVT = .FALSE. 01030 TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) 01031 TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) 01032 IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN 01033 SCALE = ZERO 01034 U1 = ONE 01035 U2 = ZERO 01036 GO TO 250 01037 ELSE IF( TEMP.GE.TEMP2 ) THEN 01038 W11 = T( J+1, J+1 ) 01039 W21 = T( J+2, J+1 ) 01040 W12 = T( J+1, J+2 ) 01041 W22 = T( J+2, J+2 ) 01042 U1 = T( J+1, J ) 01043 U2 = T( J+2, J ) 01044 ELSE 01045 W21 = T( J+1, J+1 ) 01046 W11 = T( J+2, J+1 ) 01047 W22 = T( J+1, J+2 ) 01048 W12 = T( J+2, J+2 ) 01049 U2 = T( J+1, J ) 01050 U1 = T( J+2, J ) 01051 END IF 01052 * 01053 * Swap columns if nec. 01054 * 01055 IF( ABS( W12 ).GT.ABS( W11 ) ) THEN 01056 ILPIVT = .TRUE. 01057 TEMP = W12 01058 TEMP2 = W22 01059 W12 = W11 01060 W22 = W21 01061 W11 = TEMP 01062 W21 = TEMP2 01063 END IF 01064 * 01065 * LU-factor 01066 * 01067 TEMP = W21 / W11 01068 U2 = U2 - TEMP*U1 01069 W22 = W22 - TEMP*W12 01070 W21 = ZERO 01071 * 01072 * Compute SCALE 01073 * 01074 SCALE = ONE 01075 IF( ABS( W22 ).LT.SAFMIN ) THEN 01076 SCALE = ZERO 01077 U2 = ONE 01078 U1 = -W12 / W11 01079 GO TO 250 01080 END IF 01081 IF( ABS( W22 ).LT.ABS( U2 ) ) 01082 $ SCALE = ABS( W22 / U2 ) 01083 IF( ABS( W11 ).LT.ABS( U1 ) ) 01084 $ SCALE = MIN( SCALE, ABS( W11 / U1 ) ) 01085 * 01086 * Solve 01087 * 01088 U2 = ( SCALE*U2 ) / W22 01089 U1 = ( SCALE*U1-W12*U2 ) / W11 01090 * 01091 250 CONTINUE 01092 IF( ILPIVT ) THEN 01093 TEMP = U2 01094 U2 = U1 01095 U1 = TEMP 01096 END IF 01097 * 01098 * Compute Householder Vector 01099 * 01100 T1 = SQRT( SCALE**2+U1**2+U2**2 ) 01101 TAU = ONE + SCALE / T1 01102 VS = -ONE / ( SCALE+T1 ) 01103 V( 1 ) = ONE 01104 V( 2 ) = VS*U1 01105 V( 3 ) = VS*U2 01106 * 01107 * Apply transformations from the right. 01108 * 01109 DO 260 JR = IFRSTM, MIN( J+3, ILAST ) 01110 TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* 01111 $ H( JR, J+2 ) ) 01112 H( JR, J ) = H( JR, J ) - TEMP 01113 H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) 01114 H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) 01115 260 CONTINUE 01116 DO 270 JR = IFRSTM, J + 2 01117 TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* 01118 $ T( JR, J+2 ) ) 01119 T( JR, J ) = T( JR, J ) - TEMP 01120 T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) 01121 T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) 01122 270 CONTINUE 01123 IF( ILZ ) THEN 01124 DO 280 JR = 1, N 01125 TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* 01126 $ Z( JR, J+2 ) ) 01127 Z( JR, J ) = Z( JR, J ) - TEMP 01128 Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) 01129 Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) 01130 280 CONTINUE 01131 END IF 01132 T( J+1, J ) = ZERO 01133 T( J+2, J ) = ZERO 01134 290 CONTINUE 01135 * 01136 * Last elements: Use Givens rotations 01137 * 01138 * Rotations from the left 01139 * 01140 J = ILAST - 1 01141 TEMP = H( J, J-1 ) 01142 CALL SLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) 01143 H( J+1, J-1 ) = ZERO 01144 * 01145 DO 300 JC = J, ILASTM 01146 TEMP = C*H( J, JC ) + S*H( J+1, JC ) 01147 H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) 01148 H( J, JC ) = TEMP 01149 TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) 01150 T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) 01151 T( J, JC ) = TEMP2 01152 300 CONTINUE 01153 IF( ILQ ) THEN 01154 DO 310 JR = 1, N 01155 TEMP = C*Q( JR, J ) + S*Q( JR, J+1 ) 01156 Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 ) 01157 Q( JR, J ) = TEMP 01158 310 CONTINUE 01159 END IF 01160 * 01161 * Rotations from the right. 01162 * 01163 TEMP = T( J+1, J+1 ) 01164 CALL SLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) 01165 T( J+1, J ) = ZERO 01166 * 01167 DO 320 JR = IFRSTM, ILAST 01168 TEMP = C*H( JR, J+1 ) + S*H( JR, J ) 01169 H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) 01170 H( JR, J+1 ) = TEMP 01171 320 CONTINUE 01172 DO 330 JR = IFRSTM, ILAST - 1 01173 TEMP = C*T( JR, J+1 ) + S*T( JR, J ) 01174 T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) 01175 T( JR, J+1 ) = TEMP 01176 330 CONTINUE 01177 IF( ILZ ) THEN 01178 DO 340 JR = 1, N 01179 TEMP = C*Z( JR, J+1 ) + S*Z( JR, J ) 01180 Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J ) 01181 Z( JR, J+1 ) = TEMP 01182 340 CONTINUE 01183 END IF 01184 * 01185 * End of Double-Shift code 01186 * 01187 END IF 01188 * 01189 GO TO 350 01190 * 01191 * End of iteration loop 01192 * 01193 350 CONTINUE 01194 360 CONTINUE 01195 * 01196 * Drop-through = non-convergence 01197 * 01198 INFO = ILAST 01199 GO TO 420 01200 * 01201 * Successful completion of all QZ steps 01202 * 01203 380 CONTINUE 01204 * 01205 * Set Eigenvalues 1:ILO-1 01206 * 01207 DO 410 J = 1, ILO - 1 01208 IF( T( J, J ).LT.ZERO ) THEN 01209 IF( ILSCHR ) THEN 01210 DO 390 JR = 1, J 01211 H( JR, J ) = -H( JR, J ) 01212 T( JR, J ) = -T( JR, J ) 01213 390 CONTINUE 01214 ELSE 01215 H( J, J ) = -H( J, J ) 01216 T( J, J ) = -T( J, J ) 01217 END IF 01218 IF( ILZ ) THEN 01219 DO 400 JR = 1, N 01220 Z( JR, J ) = -Z( JR, J ) 01221 400 CONTINUE 01222 END IF 01223 END IF 01224 ALPHAR( J ) = H( J, J ) 01225 ALPHAI( J ) = ZERO 01226 BETA( J ) = T( J, J ) 01227 410 CONTINUE 01228 * 01229 * Normal Termination 01230 * 01231 INFO = 0 01232 * 01233 * Exit (other than argument error) -- return optimal workspace size 01234 * 01235 420 CONTINUE 01236 WORK( 1 ) = REAL( N ) 01237 RETURN 01238 * 01239 * End of SHGEQZ 01240 * 01241 END
1.7.3 
