LAPACK 3.3.1
Linear Algebra PACKage

ztgsen.f

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