![]() ![]() | ![]() |
Mise à jour de lapack vers la version 3.3.0.
1: SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, 2: $ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, 3: $ WORK, LWORK, IWORK, LIWORK, INFO ) 4: * 5: * -- LAPACK routine (version 3.2.2) -- 6: * -- LAPACK is a software package provided by Univ. of Tennessee, -- 7: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 8: * January 2007 9: * 10: * Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. 11: * 12: * .. Scalar Arguments .. 13: LOGICAL WANTQ, WANTZ 14: INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, 15: $ M, N 16: DOUBLE PRECISION PL, PR 17: * .. 18: * .. Array Arguments .. 19: LOGICAL SELECT( * ) 20: INTEGER IWORK( * ) 21: DOUBLE PRECISION DIF( * ) 22: COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), 23: $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) 24: * .. 25: * 26: * Purpose 27: * ======= 28: * 29: * ZTGSEN reorders the generalized Schur decomposition of a complex 30: * matrix pair (A, B) (in terms of an unitary equivalence trans- 31: * formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues 32: * appears in the leading diagonal blocks of the pair (A,B). The leading 33: * columns of Q and Z form unitary bases of the corresponding left and 34: * right eigenspaces (deflating subspaces). (A, B) must be in 35: * generalized Schur canonical form, that is, A and B are both upper 36: * triangular. 37: * 38: * ZTGSEN also computes the generalized eigenvalues 39: * 40: * w(j)= ALPHA(j) / BETA(j) 41: * 42: * of the reordered matrix pair (A, B). 43: * 44: * Optionally, the routine computes estimates of reciprocal condition 45: * numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), 46: * (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) 47: * between the matrix pairs (A11, B11) and (A22,B22) that correspond to 48: * the selected cluster and the eigenvalues outside the cluster, resp., 49: * and norms of "projections" onto left and right eigenspaces w.r.t. 50: * the selected cluster in the (1,1)-block. 51: * 52: * 53: * Arguments 54: * ========= 55: * 56: * IJOB (input) integer 57: * Specifies whether condition numbers are required for the 58: * cluster of eigenvalues (PL and PR) or the deflating subspaces 59: * (Difu and Difl): 60: * =0: Only reorder w.r.t. SELECT. No extras. 61: * =1: Reciprocal of norms of "projections" onto left and right 62: * eigenspaces w.r.t. the selected cluster (PL and PR). 63: * =2: Upper bounds on Difu and Difl. F-norm-based estimate 64: * (DIF(1:2)). 65: * =3: Estimate of Difu and Difl. 1-norm-based estimate 66: * (DIF(1:2)). 67: * About 5 times as expensive as IJOB = 2. 68: * =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic 69: * version to get it all. 70: * =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) 71: * 72: * WANTQ (input) LOGICAL 73: * .TRUE. : update the left transformation matrix Q; 74: * .FALSE.: do not update Q. 75: * 76: * WANTZ (input) LOGICAL 77: * .TRUE. : update the right transformation matrix Z; 78: * .FALSE.: do not update Z. 79: * 80: * SELECT (input) LOGICAL array, dimension (N) 81: * SELECT specifies the eigenvalues in the selected cluster. To 82: * select an eigenvalue w(j), SELECT(j) must be set to 83: * .TRUE.. 84: * 85: * N (input) INTEGER 86: * The order of the matrices A and B. N >= 0. 87: * 88: * A (input/output) COMPLEX*16 array, dimension(LDA,N) 89: * On entry, the upper triangular matrix A, in generalized 90: * Schur canonical form. 91: * On exit, A is overwritten by the reordered matrix A. 92: * 93: * LDA (input) INTEGER 94: * The leading dimension of the array A. LDA >= max(1,N). 95: * 96: * B (input/output) COMPLEX*16 array, dimension(LDB,N) 97: * On entry, the upper triangular matrix B, in generalized 98: * Schur canonical form. 99: * On exit, B is overwritten by the reordered matrix B. 100: * 101: * LDB (input) INTEGER 102: * The leading dimension of the array B. LDB >= max(1,N). 103: * 104: * ALPHA (output) COMPLEX*16 array, dimension (N) 105: * BETA (output) COMPLEX*16 array, dimension (N) 106: * The diagonal elements of A and B, respectively, 107: * when the pair (A,B) has been reduced to generalized Schur 108: * form. ALPHA(i)/BETA(i) i=1,...,N are the generalized 109: * eigenvalues. 110: * 111: * Q (input/output) COMPLEX*16 array, dimension (LDQ,N) 112: * On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. 113: * On exit, Q has been postmultiplied by the left unitary 114: * transformation matrix which reorder (A, B); The leading M 115: * columns of Q form orthonormal bases for the specified pair of 116: * left eigenspaces (deflating subspaces). 117: * If WANTQ = .FALSE., Q is not referenced. 118: * 119: * LDQ (input) INTEGER 120: * The leading dimension of the array Q. LDQ >= 1. 121: * If WANTQ = .TRUE., LDQ >= N. 122: * 123: * Z (input/output) COMPLEX*16 array, dimension (LDZ,N) 124: * On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. 125: * On exit, Z has been postmultiplied by the left unitary 126: * transformation matrix which reorder (A, B); The leading M 127: * columns of Z form orthonormal bases for the specified pair of 128: * left eigenspaces (deflating subspaces). 129: * If WANTZ = .FALSE., Z is not referenced. 130: * 131: * LDZ (input) INTEGER 132: * The leading dimension of the array Z. LDZ >= 1. 133: * If WANTZ = .TRUE., LDZ >= N. 134: * 135: * M (output) INTEGER 136: * The dimension of the specified pair of left and right 137: * eigenspaces, (deflating subspaces) 0 <= M <= N. 138: * 139: * PL (output) DOUBLE PRECISION 140: * PR (output) DOUBLE PRECISION 141: * If IJOB = 1, 4 or 5, PL, PR are lower bounds on the 142: * reciprocal of the norm of "projections" onto left and right 143: * eigenspace with respect to the selected cluster. 144: * 0 < PL, PR <= 1. 145: * If M = 0 or M = N, PL = PR = 1. 146: * If IJOB = 0, 2 or 3 PL, PR are not referenced. 147: * 148: * DIF (output) DOUBLE PRECISION array, dimension (2). 149: * If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. 150: * If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on 151: * Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based 152: * estimates of Difu and Difl, computed using reversed 153: * communication with ZLACN2. 154: * If M = 0 or N, DIF(1:2) = F-norm([A, B]). 155: * If IJOB = 0 or 1, DIF is not referenced. 156: * 157: * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) 158: * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 159: * 160: * LWORK (input) INTEGER 161: * The dimension of the array WORK. LWORK >= 1 162: * If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) 163: * If IJOB = 3 or 5, LWORK >= 4*M*(N-M) 164: * 165: * If LWORK = -1, then a workspace query is assumed; the routine 166: * only calculates the optimal size of the WORK array, returns 167: * this value as the first entry of the WORK array, and no error 168: * message related to LWORK is issued by XERBLA. 169: * 170: * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) 171: * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. 172: * 173: * LIWORK (input) INTEGER 174: * The dimension of the array IWORK. LIWORK >= 1. 175: * If IJOB = 1, 2 or 4, LIWORK >= N+2; 176: * If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M)); 177: * 178: * If LIWORK = -1, then a workspace query is assumed; the 179: * routine only calculates the optimal size of the IWORK array, 180: * returns this value as the first entry of the IWORK array, and 181: * no error message related to LIWORK is issued by XERBLA. 182: * 183: * INFO (output) INTEGER 184: * =0: Successful exit. 185: * <0: If INFO = -i, the i-th argument had an illegal value. 186: * =1: Reordering of (A, B) failed because the transformed 187: * matrix pair (A, B) would be too far from generalized 188: * Schur form; the problem is very ill-conditioned. 189: * (A, B) may have been partially reordered. 190: * If requested, 0 is returned in DIF(*), PL and PR. 191: * 192: * 193: * Further Details 194: * =============== 195: * 196: * ZTGSEN first collects the selected eigenvalues by computing unitary 197: * U and W that move them to the top left corner of (A, B). In other 198: * words, the selected eigenvalues are the eigenvalues of (A11, B11) in 199: * 200: * U'*(A, B)*W = (A11 A12) (B11 B12) n1 201: * ( 0 A22),( 0 B22) n2 202: * n1 n2 n1 n2 203: * 204: * where N = n1+n2 and U' means the conjugate transpose of U. The first 205: * n1 columns of U and W span the specified pair of left and right 206: * eigenspaces (deflating subspaces) of (A, B). 207: * 208: * If (A, B) has been obtained from the generalized real Schur 209: * decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the 210: * reordered generalized Schur form of (C, D) is given by 211: * 212: * (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', 213: * 214: * and the first n1 columns of Q*U and Z*W span the corresponding 215: * deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). 216: * 217: * Note that if the selected eigenvalue is sufficiently ill-conditioned, 218: * then its value may differ significantly from its value before 219: * reordering. 220: * 221: * The reciprocal condition numbers of the left and right eigenspaces 222: * spanned by the first n1 columns of U and W (or Q*U and Z*W) may 223: * be returned in DIF(1:2), corresponding to Difu and Difl, resp. 224: * 225: * The Difu and Difl are defined as: 226: * 227: * Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) 228: * and 229: * Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], 230: * 231: * where sigma-min(Zu) is the smallest singular value of the 232: * (2*n1*n2)-by-(2*n1*n2) matrix 233: * 234: * Zu = [ kron(In2, A11) -kron(A22', In1) ] 235: * [ kron(In2, B11) -kron(B22', In1) ]. 236: * 237: * Here, Inx is the identity matrix of size nx and A22' is the 238: * transpose of A22. kron(X, Y) is the Kronecker product between 239: * the matrices X and Y. 240: * 241: * When DIF(2) is small, small changes in (A, B) can cause large changes 242: * in the deflating subspace. An approximate (asymptotic) bound on the 243: * maximum angular error in the computed deflating subspaces is 244: * 245: * EPS * norm((A, B)) / DIF(2), 246: * 247: * where EPS is the machine precision. 248: * 249: * The reciprocal norm of the projectors on the left and right 250: * eigenspaces associated with (A11, B11) may be returned in PL and PR. 251: * They are computed as follows. First we compute L and R so that 252: * P*(A, B)*Q is block diagonal, where 253: * 254: * P = ( I -L ) n1 Q = ( I R ) n1 255: * ( 0 I ) n2 and ( 0 I ) n2 256: * n1 n2 n1 n2 257: * 258: * and (L, R) is the solution to the generalized Sylvester equation 259: * 260: * A11*R - L*A22 = -A12 261: * B11*R - L*B22 = -B12 262: * 263: * Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). 264: * An approximate (asymptotic) bound on the average absolute error of 265: * the selected eigenvalues is 266: * 267: * EPS * norm((A, B)) / PL. 268: * 269: * There are also global error bounds which valid for perturbations up 270: * to a certain restriction: A lower bound (x) on the smallest 271: * F-norm(E,F) for which an eigenvalue of (A11, B11) may move and 272: * coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), 273: * (i.e. (A + E, B + F), is 274: * 275: * x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). 276: * 277: * An approximate bound on x can be computed from DIF(1:2), PL and PR. 278: * 279: * If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed 280: * (L', R') and unperturbed (L, R) left and right deflating subspaces 281: * associated with the selected cluster in the (1,1)-blocks can be 282: * bounded as 283: * 284: * max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) 285: * max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) 286: * 287: * See LAPACK User's Guide section 4.11 or the following references 288: * for more information. 289: * 290: * Note that if the default method for computing the Frobenius-norm- 291: * based estimate DIF is not wanted (see ZLATDF), then the parameter 292: * IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF 293: * (IJOB = 2 will be used)). See ZTGSYL for more details. 294: * 295: * Based on contributions by 296: * Bo Kagstrom and Peter Poromaa, Department of Computing Science, 297: * Umea University, S-901 87 Umea, Sweden. 298: * 299: * References 300: * ========== 301: * 302: * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the 303: * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in 304: * M.S. Moonen et al (eds), Linear Algebra for Large Scale and 305: * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. 306: * 307: * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified 308: * Eigenvalues of a Regular Matrix Pair (A, B) and Condition 309: * Estimation: Theory, Algorithms and Software, Report 310: * UMINF - 94.04, Department of Computing Science, Umea University, 311: * S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. 312: * To appear in Numerical Algorithms, 1996. 313: * 314: * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software 315: * for Solving the Generalized Sylvester Equation and Estimating the 316: * Separation between Regular Matrix Pairs, Report UMINF - 93.23, 317: * Department of Computing Science, Umea University, S-901 87 Umea, 318: * Sweden, December 1993, Revised April 1994, Also as LAPACK working 319: * Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, 320: * 1996. 321: * 322: * ===================================================================== 323: * 324: * .. Parameters .. 325: INTEGER IDIFJB 326: PARAMETER ( IDIFJB = 3 ) 327: DOUBLE PRECISION ZERO, ONE 328: PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 329: * .. 330: * .. Local Scalars .. 331: LOGICAL LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP 332: INTEGER I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2, 333: $ N1, N2 334: DOUBLE PRECISION DSCALE, DSUM, RDSCAL, SAFMIN 335: COMPLEX*16 TEMP1, TEMP2 336: * .. 337: * .. Local Arrays .. 338: INTEGER ISAVE( 3 ) 339: * .. 340: * .. External Subroutines .. 341: EXTERNAL XERBLA, ZLACN2, ZLACPY, ZLASSQ, ZSCAL, ZTGEXC, 342: $ ZTGSYL 343: * .. 344: * .. Intrinsic Functions .. 345: INTRINSIC ABS, DCMPLX, DCONJG, MAX, SQRT 346: * .. 347: * .. External Functions .. 348: DOUBLE PRECISION DLAMCH 349: EXTERNAL DLAMCH 350: * .. 351: * .. Executable Statements .. 352: * 353: * Decode and test the input parameters 354: * 355: INFO = 0 356: LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) 357: * 358: IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN 359: INFO = -1 360: ELSE IF( N.LT.0 ) THEN 361: INFO = -5 362: ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 363: INFO = -7 364: ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 365: INFO = -9 366: ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN 367: INFO = -13 368: ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN 369: INFO = -15 370: END IF 371: * 372: IF( INFO.NE.0 ) THEN 373: CALL XERBLA( 'ZTGSEN', -INFO ) 374: RETURN 375: END IF 376: * 377: IERR = 0 378: * 379: WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 380: WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 381: WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 382: WANTD = WANTD1 .OR. WANTD2 383: * 384: * Set M to the dimension of the specified pair of deflating 385: * subspaces. 386: * 387: M = 0 388: DO 10 K = 1, N 389: ALPHA( K ) = A( K, K ) 390: BETA( K ) = B( K, K ) 391: IF( K.LT.N ) THEN 392: IF( SELECT( K ) ) 393: $ M = M + 1 394: ELSE 395: IF( SELECT( N ) ) 396: $ M = M + 1 397: END IF 398: 10 CONTINUE 399: * 400: IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN 401: LWMIN = MAX( 1, 2*M*( N-M ) ) 402: LIWMIN = MAX( 1, N+2 ) 403: ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN 404: LWMIN = MAX( 1, 4*M*( N-M ) ) 405: LIWMIN = MAX( 1, 2*M*( N-M ), N+2 ) 406: ELSE 407: LWMIN = 1 408: LIWMIN = 1 409: END IF 410: * 411: WORK( 1 ) = LWMIN 412: IWORK( 1 ) = LIWMIN 413: * 414: IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN 415: INFO = -21 416: ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN 417: INFO = -23 418: END IF 419: * 420: IF( INFO.NE.0 ) THEN 421: CALL XERBLA( 'ZTGSEN', -INFO ) 422: RETURN 423: ELSE IF( LQUERY ) THEN 424: RETURN 425: END IF 426: * 427: * Quick return if possible. 428: * 429: IF( M.EQ.N .OR. M.EQ.0 ) THEN 430: IF( WANTP ) THEN 431: PL = ONE 432: PR = ONE 433: END IF 434: IF( WANTD ) THEN 435: DSCALE = ZERO 436: DSUM = ONE 437: DO 20 I = 1, N 438: CALL ZLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) 439: CALL ZLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) 440: 20 CONTINUE 441: DIF( 1 ) = DSCALE*SQRT( DSUM ) 442: DIF( 2 ) = DIF( 1 ) 443: END IF 444: GO TO 70 445: END IF 446: * 447: * Get machine constant 448: * 449: SAFMIN = DLAMCH( 'S' ) 450: * 451: * Collect the selected blocks at the top-left corner of (A, B). 452: * 453: KS = 0 454: DO 30 K = 1, N 455: SWAP = SELECT( K ) 456: IF( SWAP ) THEN 457: KS = KS + 1 458: * 459: * Swap the K-th block to position KS. Compute unitary Q 460: * and Z that will swap adjacent diagonal blocks in (A, B). 461: * 462: IF( K.NE.KS ) 463: $ CALL ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, 464: $ LDZ, K, KS, IERR ) 465: * 466: IF( IERR.GT.0 ) THEN 467: * 468: * Swap is rejected: exit. 469: * 470: INFO = 1 471: IF( WANTP ) THEN 472: PL = ZERO 473: PR = ZERO 474: END IF 475: IF( WANTD ) THEN 476: DIF( 1 ) = ZERO 477: DIF( 2 ) = ZERO 478: END IF 479: GO TO 70 480: END IF 481: END IF 482: 30 CONTINUE 483: IF( WANTP ) THEN 484: * 485: * Solve generalized Sylvester equation for R and L: 486: * A11 * R - L * A22 = A12 487: * B11 * R - L * B22 = B12 488: * 489: N1 = M 490: N2 = N - M 491: I = N1 + 1 492: CALL ZLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) 493: CALL ZLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), 494: $ N1 ) 495: IJB = 0 496: CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, 497: $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, 498: $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), 499: $ LWORK-2*N1*N2, IWORK, IERR ) 500: * 501: * Estimate the reciprocal of norms of "projections" onto 502: * left and right eigenspaces 503: * 504: RDSCAL = ZERO 505: DSUM = ONE 506: CALL ZLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) 507: PL = RDSCAL*SQRT( DSUM ) 508: IF( PL.EQ.ZERO ) THEN 509: PL = ONE 510: ELSE 511: PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) 512: END IF 513: RDSCAL = ZERO 514: DSUM = ONE 515: CALL ZLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) 516: PR = RDSCAL*SQRT( DSUM ) 517: IF( PR.EQ.ZERO ) THEN 518: PR = ONE 519: ELSE 520: PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) 521: END IF 522: END IF 523: IF( WANTD ) THEN 524: * 525: * Compute estimates Difu and Difl. 526: * 527: IF( WANTD1 ) THEN 528: N1 = M 529: N2 = N - M 530: I = N1 + 1 531: IJB = IDIFJB 532: * 533: * Frobenius norm-based Difu estimate. 534: * 535: CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, 536: $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), 537: $ N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), 538: $ LWORK-2*N1*N2, IWORK, IERR ) 539: * 540: * Frobenius norm-based Difl estimate. 541: * 542: CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, 543: $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), 544: $ N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ), 545: $ LWORK-2*N1*N2, IWORK, IERR ) 546: ELSE 547: * 548: * Compute 1-norm-based estimates of Difu and Difl using 549: * reversed communication with ZLACN2. In each step a 550: * generalized Sylvester equation or a transposed variant 551: * is solved. 552: * 553: KASE = 0 554: N1 = M 555: N2 = N - M 556: I = N1 + 1 557: IJB = 0 558: MN2 = 2*N1*N2 559: * 560: * 1-norm-based estimate of Difu. 561: * 562: 40 CONTINUE 563: CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE, 564: $ ISAVE ) 565: IF( KASE.NE.0 ) THEN 566: IF( KASE.EQ.1 ) THEN 567: * 568: * Solve generalized Sylvester equation 569: * 570: CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, 571: $ WORK, N1, B, LDB, B( I, I ), LDB, 572: $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), 573: $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, 574: $ IERR ) 575: ELSE 576: * 577: * Solve the transposed variant. 578: * 579: CALL ZTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA, 580: $ WORK, N1, B, LDB, B( I, I ), LDB, 581: $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), 582: $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, 583: $ IERR ) 584: END IF 585: GO TO 40 586: END IF 587: DIF( 1 ) = DSCALE / DIF( 1 ) 588: * 589: * 1-norm-based estimate of Difl. 590: * 591: 50 CONTINUE 592: CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE, 593: $ ISAVE ) 594: IF( KASE.NE.0 ) THEN 595: IF( KASE.EQ.1 ) THEN 596: * 597: * Solve generalized Sylvester equation 598: * 599: CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, 600: $ WORK, N2, B( I, I ), LDB, B, LDB, 601: $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), 602: $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, 603: $ IERR ) 604: ELSE 605: * 606: * Solve the transposed variant. 607: * 608: CALL ZTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA, 609: $ WORK, N2, B, LDB, B( I, I ), LDB, 610: $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), 611: $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, 612: $ IERR ) 613: END IF 614: GO TO 50 615: END IF 616: DIF( 2 ) = DSCALE / DIF( 2 ) 617: END IF 618: END IF 619: * 620: * If B(K,K) is complex, make it real and positive (normalization 621: * of the generalized Schur form) and Store the generalized 622: * eigenvalues of reordered pair (A, B) 623: * 624: DO 60 K = 1, N 625: DSCALE = ABS( B( K, K ) ) 626: IF( DSCALE.GT.SAFMIN ) THEN 627: TEMP1 = DCONJG( B( K, K ) / DSCALE ) 628: TEMP2 = B( K, K ) / DSCALE 629: B( K, K ) = DSCALE 630: CALL ZSCAL( N-K, TEMP1, B( K, K+1 ), LDB ) 631: CALL ZSCAL( N-K+1, TEMP1, A( K, K ), LDA ) 632: IF( WANTQ ) 633: $ CALL ZSCAL( N, TEMP2, Q( 1, K ), 1 ) 634: ELSE 635: B( K, K ) = DCMPLX( ZERO, ZERO ) 636: END IF 637: * 638: ALPHA( K ) = A( K, K ) 639: BETA( K ) = B( K, K ) 640: * 641: 60 CONTINUE 642: * 643: 70 CONTINUE 644: * 645: WORK( 1 ) = LWMIN 646: IWORK( 1 ) = LIWMIN 647: * 648: RETURN 649: * 650: * End of ZTGSEN 651: * 652: END