![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b ZTGSEN 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download ZTGSEN + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztgsen.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztgsen.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztgsen.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, 00022 * ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, 00023 * WORK, LWORK, IWORK, LIWORK, INFO ) 00024 * 00025 * .. Scalar Arguments .. 00026 * LOGICAL WANTQ, WANTZ 00027 * INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, 00028 * $ M, N 00029 * DOUBLE PRECISION PL, PR 00030 * .. 00031 * .. Array Arguments .. 00032 * LOGICAL SELECT( * ) 00033 * INTEGER IWORK( * ) 00034 * DOUBLE PRECISION DIF( * ) 00035 * COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), 00036 * $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) 00037 * .. 00038 * 00039 * 00040 *> \par Purpose: 00041 * ============= 00042 *> 00043 *> \verbatim 00044 *> 00045 *> ZTGSEN reorders the generalized Schur decomposition of a complex 00046 *> matrix pair (A, B) (in terms of an unitary equivalence trans- 00047 *> formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues 00048 *> appears in the leading diagonal blocks of the pair (A,B). The leading 00049 *> columns of Q and Z form unitary bases of the corresponding left and 00050 *> right eigenspaces (deflating subspaces). (A, B) must be in 00051 *> generalized Schur canonical form, that is, A and B are both upper 00052 *> triangular. 00053 *> 00054 *> ZTGSEN also computes the generalized eigenvalues 00055 *> 00056 *> w(j)= ALPHA(j) / BETA(j) 00057 *> 00058 *> of the reordered matrix pair (A, B). 00059 *> 00060 *> Optionally, the routine computes estimates of reciprocal condition 00061 *> numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), 00062 *> (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) 00063 *> between the matrix pairs (A11, B11) and (A22,B22) that correspond to 00064 *> the selected cluster and the eigenvalues outside the cluster, resp., 00065 *> and norms of "projections" onto left and right eigenspaces w.r.t. 00066 *> the selected cluster in the (1,1)-block. 00067 *> 00068 *> \endverbatim 00069 * 00070 * Arguments: 00071 * ========== 00072 * 00073 *> \param[in] IJOB 00074 *> \verbatim 00075 *> IJOB is integer 00076 *> Specifies whether condition numbers are required for the 00077 *> cluster of eigenvalues (PL and PR) or the deflating subspaces 00078 *> (Difu and Difl): 00079 *> =0: Only reorder w.r.t. SELECT. No extras. 00080 *> =1: Reciprocal of norms of "projections" onto left and right 00081 *> eigenspaces w.r.t. the selected cluster (PL and PR). 00082 *> =2: Upper bounds on Difu and Difl. F-norm-based estimate 00083 *> (DIF(1:2)). 00084 *> =3: Estimate of Difu and Difl. 1-norm-based estimate 00085 *> (DIF(1:2)). 00086 *> About 5 times as expensive as IJOB = 2. 00087 *> =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic 00088 *> version to get it all. 00089 *> =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) 00090 *> \endverbatim 00091 *> 00092 *> \param[in] WANTQ 00093 *> \verbatim 00094 *> WANTQ is LOGICAL 00095 *> .TRUE. : update the left transformation matrix Q; 00096 *> .FALSE.: do not update Q. 00097 *> \endverbatim 00098 *> 00099 *> \param[in] WANTZ 00100 *> \verbatim 00101 *> WANTZ is LOGICAL 00102 *> .TRUE. : update the right transformation matrix Z; 00103 *> .FALSE.: do not update Z. 00104 *> \endverbatim 00105 *> 00106 *> \param[in] SELECT 00107 *> \verbatim 00108 *> SELECT is LOGICAL array, dimension (N) 00109 *> SELECT specifies the eigenvalues in the selected cluster. To 00110 *> select an eigenvalue w(j), SELECT(j) must be set to 00111 *> .TRUE.. 00112 *> \endverbatim 00113 *> 00114 *> \param[in] N 00115 *> \verbatim 00116 *> N is INTEGER 00117 *> The order of the matrices A and B. N >= 0. 00118 *> \endverbatim 00119 *> 00120 *> \param[in,out] A 00121 *> \verbatim 00122 *> A is COMPLEX*16 array, dimension(LDA,N) 00123 *> On entry, the upper triangular matrix A, in generalized 00124 *> Schur canonical form. 00125 *> On exit, A is overwritten by the reordered matrix A. 00126 *> \endverbatim 00127 *> 00128 *> \param[in] LDA 00129 *> \verbatim 00130 *> LDA is INTEGER 00131 *> The leading dimension of the array A. LDA >= max(1,N). 00132 *> \endverbatim 00133 *> 00134 *> \param[in,out] B 00135 *> \verbatim 00136 *> B is COMPLEX*16 array, dimension(LDB,N) 00137 *> On entry, the upper triangular matrix B, in generalized 00138 *> Schur canonical form. 00139 *> On exit, B is overwritten by the reordered matrix B. 00140 *> \endverbatim 00141 *> 00142 *> \param[in] LDB 00143 *> \verbatim 00144 *> LDB is INTEGER 00145 *> The leading dimension of the array B. LDB >= max(1,N). 00146 *> \endverbatim 00147 *> 00148 *> \param[out] ALPHA 00149 *> \verbatim 00150 *> ALPHA is COMPLEX*16 array, dimension (N) 00151 *> \endverbatim 00152 *> 00153 *> \param[out] BETA 00154 *> \verbatim 00155 *> BETA is COMPLEX*16 array, dimension (N) 00156 *> 00157 *> The diagonal elements of A and B, respectively, 00158 *> when the pair (A,B) has been reduced to generalized Schur 00159 *> form. ALPHA(i)/BETA(i) i=1,...,N are the generalized 00160 *> eigenvalues. 00161 *> \endverbatim 00162 *> 00163 *> \param[in,out] Q 00164 *> \verbatim 00165 *> Q is COMPLEX*16 array, dimension (LDQ,N) 00166 *> On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. 00167 *> On exit, Q has been postmultiplied by the left unitary 00168 *> transformation matrix which reorder (A, B); The leading M 00169 *> columns of Q form orthonormal bases for the specified pair of 00170 *> left eigenspaces (deflating subspaces). 00171 *> If WANTQ = .FALSE., Q is not referenced. 00172 *> \endverbatim 00173 *> 00174 *> \param[in] LDQ 00175 *> \verbatim 00176 *> LDQ is INTEGER 00177 *> The leading dimension of the array Q. LDQ >= 1. 00178 *> If WANTQ = .TRUE., LDQ >= N. 00179 *> \endverbatim 00180 *> 00181 *> \param[in,out] Z 00182 *> \verbatim 00183 *> Z is COMPLEX*16 array, dimension (LDZ,N) 00184 *> On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. 00185 *> On exit, Z has been postmultiplied by the left unitary 00186 *> transformation matrix which reorder (A, B); The leading M 00187 *> columns of Z form orthonormal bases for the specified pair of 00188 *> left eigenspaces (deflating subspaces). 00189 *> If WANTZ = .FALSE., Z is not referenced. 00190 *> \endverbatim 00191 *> 00192 *> \param[in] LDZ 00193 *> \verbatim 00194 *> LDZ is INTEGER 00195 *> The leading dimension of the array Z. LDZ >= 1. 00196 *> If WANTZ = .TRUE., LDZ >= N. 00197 *> \endverbatim 00198 *> 00199 *> \param[out] M 00200 *> \verbatim 00201 *> M is INTEGER 00202 *> The dimension of the specified pair of left and right 00203 *> eigenspaces, (deflating subspaces) 0 <= M <= N. 00204 *> \endverbatim 00205 *> 00206 *> \param[out] PL 00207 *> \verbatim 00208 *> PL is DOUBLE PRECISION 00209 *> \endverbatim 00210 *> 00211 *> \param[out] PR 00212 *> \verbatim 00213 *> PR is DOUBLE PRECISION 00214 *> 00215 *> If IJOB = 1, 4 or 5, PL, PR are lower bounds on the 00216 *> reciprocal of the norm of "projections" onto left and right 00217 *> eigenspace with respect to the selected cluster. 00218 *> 0 < PL, PR <= 1. 00219 *> If M = 0 or M = N, PL = PR = 1. 00220 *> If IJOB = 0, 2 or 3 PL, PR are not referenced. 00221 *> \endverbatim 00222 *> 00223 *> \param[out] DIF 00224 *> \verbatim 00225 *> DIF is DOUBLE PRECISION array, dimension (2). 00226 *> If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. 00227 *> If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on 00228 *> Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based 00229 *> estimates of Difu and Difl, computed using reversed 00230 *> communication with ZLACN2. 00231 *> If M = 0 or N, DIF(1:2) = F-norm([A, B]). 00232 *> If IJOB = 0 or 1, DIF is not referenced. 00233 *> \endverbatim 00234 *> 00235 *> \param[out] WORK 00236 *> \verbatim 00237 *> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) 00238 *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 00239 *> \endverbatim 00240 *> 00241 *> \param[in] LWORK 00242 *> \verbatim 00243 *> LWORK is INTEGER 00244 *> The dimension of the array WORK. LWORK >= 1 00245 *> If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) 00246 *> If IJOB = 3 or 5, LWORK >= 4*M*(N-M) 00247 *> 00248 *> If LWORK = -1, then a workspace query is assumed; the routine 00249 *> only calculates the optimal size of the WORK array, returns 00250 *> this value as the first entry of the WORK array, and no error 00251 *> message related to LWORK is issued by XERBLA. 00252 *> \endverbatim 00253 *> 00254 *> \param[out] IWORK 00255 *> \verbatim 00256 *> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) 00257 *> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. 00258 *> \endverbatim 00259 *> 00260 *> \param[in] LIWORK 00261 *> \verbatim 00262 *> LIWORK is INTEGER 00263 *> The dimension of the array IWORK. LIWORK >= 1. 00264 *> If IJOB = 1, 2 or 4, LIWORK >= N+2; 00265 *> If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M)); 00266 *> 00267 *> If LIWORK = -1, then a workspace query is assumed; the 00268 *> routine only calculates the optimal size of the IWORK array, 00269 *> returns this value as the first entry of the IWORK array, and 00270 *> no error message related to LIWORK is issued by XERBLA. 00271 *> \endverbatim 00272 *> 00273 *> \param[out] INFO 00274 *> \verbatim 00275 *> INFO is INTEGER 00276 *> =0: Successful exit. 00277 *> <0: If INFO = -i, the i-th argument had an illegal value. 00278 *> =1: Reordering of (A, B) failed because the transformed 00279 *> matrix pair (A, B) would be too far from generalized 00280 *> Schur form; the problem is very ill-conditioned. 00281 *> (A, B) may have been partially reordered. 00282 *> If requested, 0 is returned in DIF(*), PL and PR. 00283 *> \endverbatim 00284 * 00285 * Authors: 00286 * ======== 00287 * 00288 *> \author Univ. of Tennessee 00289 *> \author Univ. of California Berkeley 00290 *> \author Univ. of Colorado Denver 00291 *> \author NAG Ltd. 00292 * 00293 *> \date November 2011 00294 * 00295 *> \ingroup complex16OTHERcomputational 00296 * 00297 *> \par Further Details: 00298 * ===================== 00299 *> 00300 *> \verbatim 00301 *> 00302 *> ZTGSEN first collects the selected eigenvalues by computing unitary 00303 *> U and W that move them to the top left corner of (A, B). In other 00304 *> words, the selected eigenvalues are the eigenvalues of (A11, B11) in 00305 *> 00306 *> U**H*(A, B)*W = (A11 A12) (B11 B12) n1 00307 *> ( 0 A22),( 0 B22) n2 00308 *> n1 n2 n1 n2 00309 *> 00310 *> where N = n1+n2 and U**H means the conjugate transpose of U. The first 00311 *> n1 columns of U and W span the specified pair of left and right 00312 *> eigenspaces (deflating subspaces) of (A, B). 00313 *> 00314 *> If (A, B) has been obtained from the generalized real Schur 00315 *> decomposition of a matrix pair (C, D) = Q*(A, B)*Z**H, then the 00316 *> reordered generalized Schur form of (C, D) is given by 00317 *> 00318 *> (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H, 00319 *> 00320 *> and the first n1 columns of Q*U and Z*W span the corresponding 00321 *> deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). 00322 *> 00323 *> Note that if the selected eigenvalue is sufficiently ill-conditioned, 00324 *> then its value may differ significantly from its value before 00325 *> reordering. 00326 *> 00327 *> The reciprocal condition numbers of the left and right eigenspaces 00328 *> spanned by the first n1 columns of U and W (or Q*U and Z*W) may 00329 *> be returned in DIF(1:2), corresponding to Difu and Difl, resp. 00330 *> 00331 *> The Difu and Difl are defined as: 00332 *> 00333 *> Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) 00334 *> and 00335 *> Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], 00336 *> 00337 *> where sigma-min(Zu) is the smallest singular value of the 00338 *> (2*n1*n2)-by-(2*n1*n2) matrix 00339 *> 00340 *> Zu = [ kron(In2, A11) -kron(A22**H, In1) ] 00341 *> [ kron(In2, B11) -kron(B22**H, In1) ]. 00342 *> 00343 *> Here, Inx is the identity matrix of size nx and A22**H is the 00344 *> conjugate transpose of A22. kron(X, Y) is the Kronecker product between 00345 *> the matrices X and Y. 00346 *> 00347 *> When DIF(2) is small, small changes in (A, B) can cause large changes 00348 *> in the deflating subspace. An approximate (asymptotic) bound on the 00349 *> maximum angular error in the computed deflating subspaces is 00350 *> 00351 *> EPS * norm((A, B)) / DIF(2), 00352 *> 00353 *> where EPS is the machine precision. 00354 *> 00355 *> The reciprocal norm of the projectors on the left and right 00356 *> eigenspaces associated with (A11, B11) may be returned in PL and PR. 00357 *> They are computed as follows. First we compute L and R so that 00358 *> P*(A, B)*Q is block diagonal, where 00359 *> 00360 *> P = ( I -L ) n1 Q = ( I R ) n1 00361 *> ( 0 I ) n2 and ( 0 I ) n2 00362 *> n1 n2 n1 n2 00363 *> 00364 *> and (L, R) is the solution to the generalized Sylvester equation 00365 *> 00366 *> A11*R - L*A22 = -A12 00367 *> B11*R - L*B22 = -B12 00368 *> 00369 *> Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). 00370 *> An approximate (asymptotic) bound on the average absolute error of 00371 *> the selected eigenvalues is 00372 *> 00373 *> EPS * norm((A, B)) / PL. 00374 *> 00375 *> There are also global error bounds which valid for perturbations up 00376 *> to a certain restriction: A lower bound (x) on the smallest 00377 *> F-norm(E,F) for which an eigenvalue of (A11, B11) may move and 00378 *> coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), 00379 *> (i.e. (A + E, B + F), is 00380 *> 00381 *> x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). 00382 *> 00383 *> An approximate bound on x can be computed from DIF(1:2), PL and PR. 00384 *> 00385 *> If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed 00386 *> (L', R') and unperturbed (L, R) left and right deflating subspaces 00387 *> associated with the selected cluster in the (1,1)-blocks can be 00388 *> bounded as 00389 *> 00390 *> max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) 00391 *> max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) 00392 *> 00393 *> See LAPACK User's Guide section 4.11 or the following references 00394 *> for more information. 00395 *> 00396 *> Note that if the default method for computing the Frobenius-norm- 00397 *> based estimate DIF is not wanted (see ZLATDF), then the parameter 00398 *> IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF 00399 *> (IJOB = 2 will be used)). See ZTGSYL for more details. 00400 *> \endverbatim 00401 * 00402 *> \par Contributors: 00403 * ================== 00404 *> 00405 *> Bo Kagstrom and Peter Poromaa, Department of Computing Science, 00406 *> Umea University, S-901 87 Umea, Sweden. 00407 * 00408 *> \par References: 00409 * ================ 00410 *> 00411 *> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the 00412 *> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in 00413 *> M.S. Moonen et al (eds), Linear Algebra for Large Scale and 00414 *> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. 00415 *> \n 00416 *> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified 00417 *> Eigenvalues of a Regular Matrix Pair (A, B) and Condition 00418 *> Estimation: Theory, Algorithms and Software, Report 00419 *> UMINF - 94.04, Department of Computing Science, Umea University, 00420 *> S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. 00421 *> To appear in Numerical Algorithms, 1996. 00422 *> \n 00423 *> [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software 00424 *> for Solving the Generalized Sylvester Equation and Estimating the 00425 *> Separation between Regular Matrix Pairs, Report UMINF - 93.23, 00426 *> Department of Computing Science, Umea University, S-901 87 Umea, 00427 *> Sweden, December 1993, Revised April 1994, Also as LAPACK working 00428 *> Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, 00429 *> 1996. 00430 *> 00431 * ===================================================================== 00432 SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, 00433 $ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, 00434 $ WORK, LWORK, IWORK, LIWORK, INFO ) 00435 * 00436 * -- LAPACK computational routine (version 3.4.0) -- 00437 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00438 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00439 * November 2011 00440 * 00441 * .. Scalar Arguments .. 00442 LOGICAL WANTQ, WANTZ 00443 INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, 00444 $ M, N 00445 DOUBLE PRECISION PL, PR 00446 * .. 00447 * .. Array Arguments .. 00448 LOGICAL SELECT( * ) 00449 INTEGER IWORK( * ) 00450 DOUBLE PRECISION DIF( * ) 00451 COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), 00452 $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) 00453 * .. 00454 * 00455 * ===================================================================== 00456 * 00457 * .. Parameters .. 00458 INTEGER IDIFJB 00459 PARAMETER ( IDIFJB = 3 ) 00460 DOUBLE PRECISION ZERO, ONE 00461 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 00462 * .. 00463 * .. Local Scalars .. 00464 LOGICAL LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP 00465 INTEGER I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2, 00466 $ N1, N2 00467 DOUBLE PRECISION DSCALE, DSUM, RDSCAL, SAFMIN 00468 COMPLEX*16 TEMP1, TEMP2 00469 * .. 00470 * .. Local Arrays .. 00471 INTEGER ISAVE( 3 ) 00472 * .. 00473 * .. External Subroutines .. 00474 EXTERNAL XERBLA, ZLACN2, ZLACPY, ZLASSQ, ZSCAL, ZTGEXC, 00475 $ ZTGSYL 00476 * .. 00477 * .. Intrinsic Functions .. 00478 INTRINSIC ABS, DCMPLX, DCONJG, MAX, SQRT 00479 * .. 00480 * .. External Functions .. 00481 DOUBLE PRECISION DLAMCH 00482 EXTERNAL DLAMCH 00483 * .. 00484 * .. Executable Statements .. 00485 * 00486 * Decode and test the input parameters 00487 * 00488 INFO = 0 00489 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 00490 * 00491 IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN 00492 INFO = -1 00493 ELSE IF( N.LT.0 ) THEN 00494 INFO = -5 00495 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 00496 INFO = -7 00497 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 00498 INFO = -9 00499 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN 00500 INFO = -13 00501 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 00502 INFO = -15 00503 END IF 00504 * 00505 IF( INFO.NE.0 ) THEN 00506 CALL XERBLA( 'ZTGSEN', -INFO ) 00507 RETURN 00508 END IF 00509 * 00510 IERR = 0 00511 * 00512 WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 00513 WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 00514 WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 00515 WANTD = WANTD1 .OR. WANTD2 00516 * 00517 * Set M to the dimension of the specified pair of deflating 00518 * subspaces. 00519 * 00520 M = 0 00521 DO 10 K = 1, N 00522 ALPHA( K ) = A( K, K ) 00523 BETA( K ) = B( K, K ) 00524 IF( K.LT.N ) THEN 00525 IF( SELECT( K ) ) 00526 $ M = M + 1 00527 ELSE 00528 IF( SELECT( N ) ) 00529 $ M = M + 1 00530 END IF 00531 10 CONTINUE 00532 * 00533 IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN 00534 LWMIN = MAX( 1, 2*M*( N-M ) ) 00535 LIWMIN = MAX( 1, N+2 ) 00536 ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN 00537 LWMIN = MAX( 1, 4*M*( N-M ) ) 00538 LIWMIN = MAX( 1, 2*M*( N-M ), N+2 ) 00539 ELSE 00540 LWMIN = 1 00541 LIWMIN = 1 00542 END IF 00543 * 00544 WORK( 1 ) = LWMIN 00545 IWORK( 1 ) = LIWMIN 00546 * 00547 IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 00548 INFO = -21 00549 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 00550 INFO = -23 00551 END IF 00552 * 00553 IF( INFO.NE.0 ) THEN 00554 CALL XERBLA( 'ZTGSEN', -INFO ) 00555 RETURN 00556 ELSE IF( LQUERY ) THEN 00557 RETURN 00558 END IF 00559 * 00560 * Quick return if possible. 00561 * 00562 IF( M.EQ.N .OR. M.EQ.0 ) THEN 00563 IF( WANTP ) THEN 00564 PL = ONE 00565 PR = ONE 00566 END IF 00567 IF( WANTD ) THEN 00568 DSCALE = ZERO 00569 DSUM = ONE 00570 DO 20 I = 1, N 00571 CALL ZLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) 00572 CALL ZLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) 00573 20 CONTINUE 00574 DIF( 1 ) = DSCALE*SQRT( DSUM ) 00575 DIF( 2 ) = DIF( 1 ) 00576 END IF 00577 GO TO 70 00578 END IF 00579 * 00580 * Get machine constant 00581 * 00582 SAFMIN = DLAMCH( 'S' ) 00583 * 00584 * Collect the selected blocks at the top-left corner of (A, B). 00585 * 00586 KS = 0 00587 DO 30 K = 1, N 00588 SWAP = SELECT( K ) 00589 IF( SWAP ) THEN 00590 KS = KS + 1 00591 * 00592 * Swap the K-th block to position KS. Compute unitary Q 00593 * and Z that will swap adjacent diagonal blocks in (A, B). 00594 * 00595 IF( K.NE.KS ) 00596 $ CALL ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, 00597 $ LDZ, K, KS, IERR ) 00598 * 00599 IF( IERR.GT.0 ) THEN 00600 * 00601 * Swap is rejected: exit. 00602 * 00603 INFO = 1 00604 IF( WANTP ) THEN 00605 PL = ZERO 00606 PR = ZERO 00607 END IF 00608 IF( WANTD ) THEN 00609 DIF( 1 ) = ZERO 00610 DIF( 2 ) = ZERO 00611 END IF 00612 GO TO 70 00613 END IF 00614 END IF 00615 30 CONTINUE 00616 IF( WANTP ) THEN 00617 * 00618 * Solve generalized Sylvester equation for R and L: 00619 * A11 * R - L * A22 = A12 00620 * B11 * R - L * B22 = B12 00621 * 00622 N1 = M 00623 N2 = N - M 00624 I = N1 + 1 00625 CALL ZLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) 00626 CALL ZLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), 00627 $ N1 ) 00628 IJB = 0 00629 CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, 00630 $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, 00631 $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), 00632 $ LWORK-2*N1*N2, IWORK, IERR ) 00633 * 00634 * Estimate the reciprocal of norms of "projections" onto 00635 * left and right eigenspaces 00636 * 00637 RDSCAL = ZERO 00638 DSUM = ONE 00639 CALL ZLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) 00640 PL = RDSCAL*SQRT( DSUM ) 00641 IF( PL.EQ.ZERO ) THEN 00642 PL = ONE 00643 ELSE 00644 PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) 00645 END IF 00646 RDSCAL = ZERO 00647 DSUM = ONE 00648 CALL ZLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) 00649 PR = RDSCAL*SQRT( DSUM ) 00650 IF( PR.EQ.ZERO ) THEN 00651 PR = ONE 00652 ELSE 00653 PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) 00654 END IF 00655 END IF 00656 IF( WANTD ) THEN 00657 * 00658 * Compute estimates Difu and Difl. 00659 * 00660 IF( WANTD1 ) THEN 00661 N1 = M 00662 N2 = N - M 00663 I = N1 + 1 00664 IJB = IDIFJB 00665 * 00666 * Frobenius norm-based Difu estimate. 00667 * 00668 CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, 00669 $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), 00670 $ N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), 00671 $ LWORK-2*N1*N2, IWORK, IERR ) 00672 * 00673 * Frobenius norm-based Difl estimate. 00674 * 00675 CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, 00676 $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), 00677 $ N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ), 00678 $ LWORK-2*N1*N2, IWORK, IERR ) 00679 ELSE 00680 * 00681 * Compute 1-norm-based estimates of Difu and Difl using 00682 * reversed communication with ZLACN2. In each step a 00683 * generalized Sylvester equation or a transposed variant 00684 * is solved. 00685 * 00686 KASE = 0 00687 N1 = M 00688 N2 = N - M 00689 I = N1 + 1 00690 IJB = 0 00691 MN2 = 2*N1*N2 00692 * 00693 * 1-norm-based estimate of Difu. 00694 * 00695 40 CONTINUE 00696 CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE, 00697 $ ISAVE ) 00698 IF( KASE.NE.0 ) THEN 00699 IF( KASE.EQ.1 ) THEN 00700 * 00701 * Solve generalized Sylvester equation 00702 * 00703 CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, 00704 $ WORK, N1, B, LDB, B( I, I ), LDB, 00705 $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), 00706 $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, 00707 $ IERR ) 00708 ELSE 00709 * 00710 * Solve the transposed variant. 00711 * 00712 CALL ZTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA, 00713 $ WORK, N1, B, LDB, B( I, I ), LDB, 00714 $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), 00715 $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, 00716 $ IERR ) 00717 END IF 00718 GO TO 40 00719 END IF 00720 DIF( 1 ) = DSCALE / DIF( 1 ) 00721 * 00722 * 1-norm-based estimate of Difl. 00723 * 00724 50 CONTINUE 00725 CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE, 00726 $ ISAVE ) 00727 IF( KASE.NE.0 ) THEN 00728 IF( KASE.EQ.1 ) THEN 00729 * 00730 * Solve generalized Sylvester equation 00731 * 00732 CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, 00733 $ WORK, N2, B( I, I ), LDB, B, LDB, 00734 $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), 00735 $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, 00736 $ IERR ) 00737 ELSE 00738 * 00739 * Solve the transposed variant. 00740 * 00741 CALL ZTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA, 00742 $ WORK, N2, B, LDB, B( I, I ), LDB, 00743 $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), 00744 $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, 00745 $ IERR ) 00746 END IF 00747 GO TO 50 00748 END IF 00749 DIF( 2 ) = DSCALE / DIF( 2 ) 00750 END IF 00751 END IF 00752 * 00753 * If B(K,K) is complex, make it real and positive (normalization 00754 * of the generalized Schur form) and Store the generalized 00755 * eigenvalues of reordered pair (A, B) 00756 * 00757 DO 60 K = 1, N 00758 DSCALE = ABS( B( K, K ) ) 00759 IF( DSCALE.GT.SAFMIN ) THEN 00760 TEMP1 = DCONJG( B( K, K ) / DSCALE ) 00761 TEMP2 = B( K, K ) / DSCALE 00762 B( K, K ) = DSCALE 00763 CALL ZSCAL( N-K, TEMP1, B( K, K+1 ), LDB ) 00764 CALL ZSCAL( N-K+1, TEMP1, A( K, K ), LDA ) 00765 IF( WANTQ ) 00766 $ CALL ZSCAL( N, TEMP2, Q( 1, K ), 1 ) 00767 ELSE 00768 B( K, K ) = DCMPLX( ZERO, ZERO ) 00769 END IF 00770 * 00771 ALPHA( K ) = A( K, K ) 00772 BETA( K ) = B( K, K ) 00773 * 00774 60 CONTINUE 00775 * 00776 70 CONTINUE 00777 * 00778 WORK( 1 ) = LWMIN 00779 IWORK( 1 ) = LIWMIN 00780 * 00781 RETURN 00782 * 00783 * End of ZTGSEN 00784 * 00785 END