SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, $ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, $ WORK, LWORK, IWORK, LIWORK, INFO ) * * -- LAPACK routine (version 3.1.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * * Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. * * .. Scalar Arguments .. LOGICAL WANTQ, WANTZ INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, $ M, N REAL PL, PR * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) REAL DIF( * ) COMPLEX A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * CTGSEN reorders the generalized Schur decomposition of a complex * matrix pair (A, B) (in terms of an unitary equivalence trans- * formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues * appears in the leading diagonal blocks of the pair (A,B). The leading * columns of Q and Z form unitary bases of the corresponding left and * right eigenspaces (deflating subspaces). (A, B) must be in * generalized Schur canonical form, that is, A and B are both upper * triangular. * * CTGSEN also computes the generalized eigenvalues * * w(j)= ALPHA(j) / BETA(j) * * of the reordered matrix pair (A, B). * * Optionally, the routine computes estimates of reciprocal condition * numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), * (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) * between the matrix pairs (A11, B11) and (A22,B22) that correspond to * the selected cluster and the eigenvalues outside the cluster, resp., * and norms of "projections" onto left and right eigenspaces w.r.t. * the selected cluster in the (1,1)-block. * * * Arguments * ========= * * IJOB (input) integer * Specifies whether condition numbers are required for the * cluster of eigenvalues (PL and PR) or the deflating subspaces * (Difu and Difl): * =0: Only reorder w.r.t. SELECT. No extras. * =1: Reciprocal of norms of "projections" onto left and right * eigenspaces w.r.t. the selected cluster (PL and PR). * =2: Upper bounds on Difu and Difl. F-norm-based estimate * (DIF(1:2)). * =3: Estimate of Difu and Difl. 1-norm-based estimate * (DIF(1:2)). * About 5 times as expensive as IJOB = 2. * =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic * version to get it all. * =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) * * WANTQ (input) LOGICAL * .TRUE. : update the left transformation matrix Q; * .FALSE.: do not update Q. * * WANTZ (input) LOGICAL * .TRUE. : update the right transformation matrix Z; * .FALSE.: do not update Z. * * SELECT (input) LOGICAL array, dimension (N) * SELECT specifies the eigenvalues in the selected cluster. To * select an eigenvalue w(j), SELECT(j) must be set to * .TRUE.. * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * A (input/output) COMPLEX array, dimension(LDA,N) * On entry, the upper triangular matrix A, in generalized * Schur canonical form. * On exit, A is overwritten by the reordered matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) COMPLEX array, dimension(LDB,N) * On entry, the upper triangular matrix B, in generalized * Schur canonical form. * On exit, B is overwritten by the reordered matrix B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * ALPHA (output) COMPLEX array, dimension (N) * BETA (output) COMPLEX array, dimension (N) * The diagonal elements of A and B, respectively, * when the pair (A,B) has been reduced to generalized Schur * form. ALPHA(i)/BETA(i) i=1,...,N are the generalized * eigenvalues. * * Q (input/output) COMPLEX array, dimension (LDQ,N) * On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. * On exit, Q has been postmultiplied by the left unitary * transformation matrix which reorder (A, B); The leading M * columns of Q form orthonormal bases for the specified pair of * left eigenspaces (deflating subspaces). * If WANTQ = .FALSE., Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If WANTQ = .TRUE., LDQ >= N. * * Z (input/output) COMPLEX array, dimension (LDZ,N) * On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. * On exit, Z has been postmultiplied by the left unitary * transformation matrix which reorder (A, B); The leading M * columns of Z form orthonormal bases for the specified pair of * left eigenspaces (deflating subspaces). * If WANTZ = .FALSE., Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. * If WANTZ = .TRUE., LDZ >= N. * * M (output) INTEGER * The dimension of the specified pair of left and right * eigenspaces, (deflating subspaces) 0 <= M <= N. * * PL (output) REAL * PR (output) REAL * If IJOB = 1, 4 or 5, PL, PR are lower bounds on the * reciprocal of the norm of "projections" onto left and right * eigenspace with respect to the selected cluster. * 0 < PL, PR <= 1. * If M = 0 or M = N, PL = PR = 1. * If IJOB = 0, 2 or 3 PL, PR are not referenced. * * DIF (output) REAL array, dimension (2). * If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. * If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on * Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based * estimates of Difu and Difl, computed using reversed * communication with CLACN2. * If M = 0 or N, DIF(1:2) = F-norm([A, B]). * If IJOB = 0 or 1, DIF is not referenced. * * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) * IF IJOB = 0, WORK is not referenced. Otherwise, * on exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= 1 * If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) * If IJOB = 3 or 5, LWORK >= 4*M*(N-M) * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) * IF IJOB = 0, IWORK is not referenced. Otherwise, * on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. * * LIWORK (input) INTEGER * The dimension of the array IWORK. LIWORK >= 1. * If IJOB = 1, 2 or 4, LIWORK >= N+2; * If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M)); * * If LIWORK = -1, then a workspace query is assumed; the * routine only calculates the optimal size of the IWORK array, * returns this value as the first entry of the IWORK array, and * no error message related to LIWORK is issued by XERBLA. * * INFO (output) INTEGER * =0: Successful exit. * <0: If INFO = -i, the i-th argument had an illegal value. * =1: Reordering of (A, B) failed because the transformed * matrix pair (A, B) would be too far from generalized * Schur form; the problem is very ill-conditioned. * (A, B) may have been partially reordered. * If requested, 0 is returned in DIF(*), PL and PR. * * * Further Details * =============== * * CTGSEN first collects the selected eigenvalues by computing unitary * U and W that move them to the top left corner of (A, B). In other * words, the selected eigenvalues are the eigenvalues of (A11, B11) in * * U'*(A, B)*W = (A11 A12) (B11 B12) n1 * ( 0 A22),( 0 B22) n2 * n1 n2 n1 n2 * * where N = n1+n2 and U' means the conjugate transpose of U. The first * n1 columns of U and W span the specified pair of left and right * eigenspaces (deflating subspaces) of (A, B). * * If (A, B) has been obtained from the generalized real Schur * decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the * reordered generalized Schur form of (C, D) is given by * * (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', * * and the first n1 columns of Q*U and Z*W span the corresponding * deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). * * Note that if the selected eigenvalue is sufficiently ill-conditioned, * then its value may differ significantly from its value before * reordering. * * The reciprocal condition numbers of the left and right eigenspaces * spanned by the first n1 columns of U and W (or Q*U and Z*W) may * be returned in DIF(1:2), corresponding to Difu and Difl, resp. * * The Difu and Difl are defined as: * * Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) * and * Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], * * where sigma-min(Zu) is the smallest singular value of the * (2*n1*n2)-by-(2*n1*n2) matrix * * Zu = [ kron(In2, A11) -kron(A22', In1) ] * [ kron(In2, B11) -kron(B22', In1) ]. * * Here, Inx is the identity matrix of size nx and A22' is the * transpose of A22. kron(X, Y) is the Kronecker product between * the matrices X and Y. * * When DIF(2) is small, small changes in (A, B) can cause large changes * in the deflating subspace. An approximate (asymptotic) bound on the * maximum angular error in the computed deflating subspaces is * * EPS * norm((A, B)) / DIF(2), * * where EPS is the machine precision. * * The reciprocal norm of the projectors on the left and right * eigenspaces associated with (A11, B11) may be returned in PL and PR. * They are computed as follows. First we compute L and R so that * P*(A, B)*Q is block diagonal, where * * P = ( I -L ) n1 Q = ( I R ) n1 * ( 0 I ) n2 and ( 0 I ) n2 * n1 n2 n1 n2 * * and (L, R) is the solution to the generalized Sylvester equation * * A11*R - L*A22 = -A12 * B11*R - L*B22 = -B12 * * Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). * An approximate (asymptotic) bound on the average absolute error of * the selected eigenvalues is * * EPS * norm((A, B)) / PL. * * There are also global error bounds which valid for perturbations up * to a certain restriction: A lower bound (x) on the smallest * F-norm(E,F) for which an eigenvalue of (A11, B11) may move and * coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), * (i.e. (A + E, B + F), is * * x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). * * An approximate bound on x can be computed from DIF(1:2), PL and PR. * * If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed * (L', R') and unperturbed (L, R) left and right deflating subspaces * associated with the selected cluster in the (1,1)-blocks can be * bounded as * * max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) * max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) * * See LAPACK User's Guide section 4.11 or the following references * for more information. * * Note that if the default method for computing the Frobenius-norm- * based estimate DIF is not wanted (see CLATDF), then the parameter * IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF * (IJOB = 2 will be used)). See CTGSYL for more details. * * Based on contributions by * Bo Kagstrom and Peter Poromaa, Department of Computing Science, * Umea University, S-901 87 Umea, Sweden. * * References * ========== * * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in * M.S. Moonen et al (eds), Linear Algebra for Large Scale and * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. * * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified * Eigenvalues of a Regular Matrix Pair (A, B) and Condition * Estimation: Theory, Algorithms and Software, Report * UMINF - 94.04, Department of Computing Science, Umea University, * S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. * To appear in Numerical Algorithms, 1996. * * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software * for Solving the Generalized Sylvester Equation and Estimating the * Separation between Regular Matrix Pairs, Report UMINF - 93.23, * Department of Computing Science, Umea University, S-901 87 Umea, * Sweden, December 1993, Revised April 1994, Also as LAPACK working * Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, * 1996. * * ===================================================================== * * .. Parameters .. INTEGER IDIFJB PARAMETER ( IDIFJB = 3 ) REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP INTEGER I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2, $ N1, N2 REAL DSCALE, DSUM, RDSCAL, SAFMIN COMPLEX TEMP1, TEMP2 * .. * .. Local Arrays .. INTEGER ISAVE( 3 ) * .. * .. External Subroutines .. REAL SLAMCH EXTERNAL CLACN2, CLACPY, CLASSQ, CSCAL, CTGEXC, CTGSYL, $ SLAMCH, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, CMPLX, CONJG, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * INFO = 0 LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -13 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -15 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTGSEN', -INFO ) RETURN END IF * IERR = 0 * WANTP = IJOB.EQ.1 .OR. IJOB.GE.4 WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4 WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5 WANTD = WANTD1 .OR. WANTD2 * * Set M to the dimension of the specified pair of deflating * subspaces. * M = 0 DO 10 K = 1, N ALPHA( K ) = A( K, K ) BETA( K ) = B( K, K ) IF( K.LT.N ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE IF( SELECT( N ) ) $ M = M + 1 END IF 10 CONTINUE * IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN LWMIN = MAX( 1, 2*M*(N-M) ) LIWMIN = MAX( 1, N+2 ) ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN LWMIN = MAX( 1, 4*M*(N-M) ) LIWMIN = MAX( 1, 2*M*(N-M), N+2 ) ELSE LWMIN = 1 LIWMIN = 1 END IF * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN INFO = -21 ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN INFO = -23 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTGSEN', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTP ) THEN PL = ONE PR = ONE END IF IF( WANTD ) THEN DSCALE = ZERO DSUM = ONE DO 20 I = 1, N CALL CLASSQ( N, A( 1, I ), 1, DSCALE, DSUM ) CALL CLASSQ( N, B( 1, I ), 1, DSCALE, DSUM ) 20 CONTINUE DIF( 1 ) = DSCALE*SQRT( DSUM ) DIF( 2 ) = DIF( 1 ) END IF GO TO 70 END IF * * Get machine constant * SAFMIN = SLAMCH( 'S' ) * * Collect the selected blocks at the top-left corner of (A, B). * KS = 0 DO 30 K = 1, N SWAP = SELECT( K ) IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. Compute unitary Q * and Z that will swap adjacent diagonal blocks in (A, B). * IF( K.NE.KS ) $ CALL CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, K, KS, IERR ) * IF( IERR.GT.0 ) THEN * * Swap is rejected: exit. * INFO = 1 IF( WANTP ) THEN PL = ZERO PR = ZERO END IF IF( WANTD ) THEN DIF( 1 ) = ZERO DIF( 2 ) = ZERO END IF GO TO 70 END IF END IF 30 CONTINUE IF( WANTP ) THEN * * Solve generalized Sylvester equation for R and L: * A11 * R - L * A22 = A12 * B11 * R - L * B22 = B12 * N1 = M N2 = N - M I = N1 + 1 CALL CLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 ) CALL CLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ), $ N1 ) IJB = 0 CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1, $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Estimate the reciprocal of norms of "projections" onto * left and right eigenspaces * RDSCAL = ZERO DSUM = ONE CALL CLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM ) PL = RDSCAL*SQRT( DSUM ) IF( PL.EQ.ZERO ) THEN PL = ONE ELSE PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) ) END IF RDSCAL = ZERO DSUM = ONE CALL CLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM ) PR = RDSCAL*SQRT( DSUM ) IF( PR.EQ.ZERO ) THEN PR = ONE ELSE PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) ) END IF END IF IF( WANTD ) THEN * * Compute estimates Difu and Difl. * IF( WANTD1 ) THEN N1 = M N2 = N - M I = N1 + 1 IJB = IDIFJB * * Frobenius norm-based Difu estimate. * CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK, $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), $ N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) * * Frobenius norm-based Difl estimate. * CALL CTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK, $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ), $ N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ), $ LWORK-2*N1*N2, IWORK, IERR ) ELSE * * Compute 1-norm-based estimates of Difu and Difl using * reversed communication with CLACN2. In each step a * generalized Sylvester equation or a transposed variant * is solved. * KASE = 0 N1 = M N2 = N - M I = N1 + 1 IJB = 0 MN2 = 2*N1*N2 * * 1-norm-based estimate of Difu. * 40 CONTINUE CALL CLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE, $ ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation * CALL CTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL CTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA, $ WORK, N1, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 40 END IF DIF( 1 ) = DSCALE / DIF( 1 ) * * 1-norm-based estimate of Difl. * 50 CONTINUE CALL CLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE, $ ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve generalized Sylvester equation * CALL CTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B( I, I ), LDB, B, LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) ELSE * * Solve the transposed variant. * CALL CTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA, $ WORK, N2, B, LDB, B( I, I ), LDB, $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ), $ WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK, $ IERR ) END IF GO TO 50 END IF DIF( 2 ) = DSCALE / DIF( 2 ) END IF END IF * * If B(K,K) is complex, make it real and positive (normalization * of the generalized Schur form) and Store the generalized * eigenvalues of reordered pair (A, B) * DO 60 K = 1, N DSCALE = ABS( B( K, K ) ) IF( DSCALE.GT.SAFMIN ) THEN TEMP1 = CONJG( B( K, K ) / DSCALE ) TEMP2 = B( K, K ) / DSCALE B( K, K ) = DSCALE CALL CSCAL( N-K, TEMP1, B( K, K+1 ), LDB ) CALL CSCAL( N-K+1, TEMP1, A( K, K ), LDA ) IF( WANTQ ) $ CALL CSCAL( N, TEMP2, Q( 1, K ), 1 ) ELSE B( K, K ) = CMPLX( ZERO, ZERO ) END IF * ALPHA( K ) = A( K, K ) BETA( K ) = B( K, K ) * 60 CONTINUE * 70 CONTINUE * WORK( 1 ) = LWMIN IWORK( 1 ) = LIWMIN * RETURN * * End of CTGSEN * END