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