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.3.1) --
6 * -- LAPACK is a software package provided by Univ. of Tennessee, --
7 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
8 * -- April 2011 --
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**H * (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**H*(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**H 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**H, then the
210 * reordered generalized Schur form of (C, D) is given by
211 *
212 * (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H,
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**H, In1) ]
235 * [ kron(In2, B11) -kron(B22**H, In1) ].
236 *
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
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
2 $ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF,
3 $ WORK, LWORK, IWORK, LIWORK, INFO )
4 *
5 * -- LAPACK routine (version 3.3.1) --
6 * -- LAPACK is a software package provided by Univ. of Tennessee, --
7 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
8 * -- April 2011 --
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**H * (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**H*(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**H 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**H, then the
210 * reordered generalized Schur form of (C, D) is given by
211 *
212 * (C, D) = (Q*U)*(U**H *(A, B)*W)*(Z*W)**H,
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**H, In1) ]
235 * [ kron(In2, B11) -kron(B22**H, In1) ].
236 *
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
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