Annotation of rpl/lapack/lapack/ztgsen.f, revision 1.9
1.1 bertrand 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: *
1.9 ! bertrand 5: * -- LAPACK routine (version 3.3.1) --
1.1 bertrand 6: * -- LAPACK is a software package provided by Univ. of Tennessee, --
7: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.9 ! bertrand 8: * -- April 2011 --
1.1 bertrand 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-
1.9 ! bertrand 31: * formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues
1.1 bertrand 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))
1.5 bertrand 158: * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
1.1 bertrand 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))
1.5 bertrand 171: * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
1.1 bertrand 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: *
1.9 ! bertrand 200: * U**H*(A, B)*W = (A11 A12) (B11 B12) n1
1.1 bertrand 201: * ( 0 A22),( 0 B22) n2
202: * n1 n2 n1 n2
203: *
1.9 ! bertrand 204: * where N = n1+n2 and U**H means the conjugate transpose of U. The first
1.1 bertrand 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
1.9 ! bertrand 209: * decomposition of a matrix pair (C, D) = Q*(A, B)*Z**H, then the
1.1 bertrand 210: * reordered generalized Schur form of (C, D) is given by
211: *
1.9 ! bertrand 212: * (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H,
1.1 bertrand 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: *
1.9 ! bertrand 234: * Zu = [ kron(In2, A11) -kron(A22**H, In1) ]
! 235: * [ kron(In2, B11) -kron(B22**H, In1) ].
1.1 bertrand 236: *
1.9 ! bertrand 237: * Here, Inx is the identity matrix of size nx and A22**H is the
! 238: * conjugate transpose of A22. kron(X, Y) is the Kronecker product between
1.1 bertrand 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
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ztgsen.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack