LAPACK: SRC/sggev.f Source File

Go to the documentation of this file.
00001       SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
00002      $                  BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
00003 *
00004 *  -- LAPACK driver routine (version 3.2) --
00005 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00006 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00007 *     November 2006
00008 *
00009 *     .. Scalar Arguments ..
00010       CHARACTER          JOBVL, JOBVR
00011       INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
00012 *     ..
00013 *     .. Array Arguments ..
00014       REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
00015      $                   B( LDB, * ), BETA( * ), VL( LDVL, * ),
00016      $                   VR( LDVR, * ), WORK( * )
00017 *     ..
00018 *
00019 *  Purpose
00020 *  =======
00021 *
00022 *  SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
00023 *  the generalized eigenvalues, and optionally, the left and/or right
00024 *  generalized eigenvectors.
00025 *
00026 *  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
00027 *  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
00028 *  singular. It is usually represented as the pair (alpha,beta), as
00029 *  there is a reasonable interpretation for beta=0, and even for both
00030 *  being zero.
00031 *
00032 *  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
00033 *  of (A,B) satisfies
00034 *
00035 *                   A * v(j) = lambda(j) * B * v(j).
00036 *
00037 *  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
00038 *  of (A,B) satisfies
00039 *
00040 *                   u(j)**H * A  = lambda(j) * u(j)**H * B .
00041 *
00042 *  where u(j)**H is the conjugate-transpose of u(j).
00043 *
00044 *
00045 *  Arguments
00046 *  =========
00047 *
00048 *  JOBVL   (input) CHARACTER*1
00049 *          = 'N':  do not compute the left generalized eigenvectors;
00050 *          = 'V':  compute the left generalized eigenvectors.
00051 *
00052 *  JOBVR   (input) CHARACTER*1
00053 *          = 'N':  do not compute the right generalized eigenvectors;
00054 *          = 'V':  compute the right generalized eigenvectors.
00055 *
00056 *  N       (input) INTEGER
00057 *          The order of the matrices A, B, VL, and VR.  N >= 0.
00058 *
00059 *  A       (input/output) REAL array, dimension (LDA, N)
00060 *          On entry, the matrix A in the pair (A,B).
00061 *          On exit, A has been overwritten.
00062 *
00063 *  LDA     (input) INTEGER
00064 *          The leading dimension of A.  LDA >= max(1,N).
00065 *
00066 *  B       (input/output) REAL array, dimension (LDB, N)
00067 *          On entry, the matrix B in the pair (A,B).
00068 *          On exit, B has been overwritten.
00069 *
00070 *  LDB     (input) INTEGER
00071 *          The leading dimension of B.  LDB >= max(1,N).
00072 *
00073 *  ALPHAR  (output) REAL array, dimension (N)
00074 *  ALPHAI  (output) REAL array, dimension (N)
00075 *  BETA    (output) REAL array, dimension (N)
00076 *          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
00077 *          be the generalized eigenvalues.  If ALPHAI(j) is zero, then
00078 *          the j-th eigenvalue is real; if positive, then the j-th and
00079 *          (j+1)-st eigenvalues are a complex conjugate pair, with
00080 *          ALPHAI(j+1) negative.
00081 *
00082 *          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
00083 *          may easily over- or underflow, and BETA(j) may even be zero.
00084 *          Thus, the user should avoid naively computing the ratio
00085 *          alpha/beta.  However, ALPHAR and ALPHAI will be always less
00086 *          than and usually comparable with norm(A) in magnitude, and
00087 *          BETA always less than and usually comparable with norm(B).
00088 *
00089 *  VL      (output) REAL array, dimension (LDVL,N)
00090 *          If JOBVL = 'V', the left eigenvectors u(j) are stored one
00091 *          after another in the columns of VL, in the same order as
00092 *          their eigenvalues. If the j-th eigenvalue is real, then
00093 *          u(j) = VL(:,j), the j-th column of VL. If the j-th and
00094 *          (j+1)-th eigenvalues form a complex conjugate pair, then
00095 *          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
00096 *          Each eigenvector is scaled so the largest component has
00097 *          abs(real part)+abs(imag. part)=1.
00098 *          Not referenced if JOBVL = 'N'.
00099 *
00100 *  LDVL    (input) INTEGER
00101 *          The leading dimension of the matrix VL. LDVL >= 1, and
00102 *          if JOBVL = 'V', LDVL >= N.
00103 *
00104 *  VR      (output) REAL array, dimension (LDVR,N)
00105 *          If JOBVR = 'V', the right eigenvectors v(j) are stored one
00106 *          after another in the columns of VR, in the same order as
00107 *          their eigenvalues. If the j-th eigenvalue is real, then
00108 *          v(j) = VR(:,j), the j-th column of VR. If the j-th and
00109 *          (j+1)-th eigenvalues form a complex conjugate pair, then
00110 *          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
00111 *          Each eigenvector is scaled so the largest component has
00112 *          abs(real part)+abs(imag. part)=1.
00113 *          Not referenced if JOBVR = 'N'.
00114 *
00115 *  LDVR    (input) INTEGER
00116 *          The leading dimension of the matrix VR. LDVR >= 1, and
00117 *          if JOBVR = 'V', LDVR >= N.
00118 *
00119 *  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))
00120 *          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
00121 *
00122 *  LWORK   (input) INTEGER
00123 *          The dimension of the array WORK.  LWORK >= max(1,8*N).
00124 *          For good performance, LWORK must generally be larger.
00125 *
00126 *          If LWORK = -1, then a workspace query is assumed; the routine
00127 *          only calculates the optimal size of the WORK array, returns
00128 *          this value as the first entry of the WORK array, and no error
00129 *          message related to LWORK is issued by XERBLA.
00130 *
00131 *  INFO    (output) INTEGER
00132 *          = 0:  successful exit
00133 *          < 0:  if INFO = -i, the i-th argument had an illegal value.
00134 *          = 1,...,N:
00135 *                The QZ iteration failed.  No eigenvectors have been
00136 *                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
00137 *                should be correct for j=INFO+1,...,N.
00138 *          > N:  =N+1: other than QZ iteration failed in SHGEQZ.
00139 *                =N+2: error return from STGEVC.
00140 *
00141 *  =====================================================================
00142 *
00143 *     .. Parameters ..
00144       REAL               ZERO, ONE
00145       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
00146 *     ..
00147 *     .. Local Scalars ..
00148       LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
00149       CHARACTER          CHTEMP
00150       INTEGER            ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
00151      $                   IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK,
00152      $                   MINWRK
00153       REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
00154      $                   SMLNUM, TEMP
00155 *     ..
00156 *     .. Local Arrays ..
00157       LOGICAL            LDUMMA( 1 )
00158 *     ..
00159 *     .. External Subroutines ..
00160       EXTERNAL           SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
00161      $                   SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGEVC,
00162      $                   XERBLA
00163 *     ..
00164 *     .. External Functions ..
00165       LOGICAL            LSAME
00166       INTEGER            ILAENV
00167       REAL               SLAMCH, SLANGE
00168       EXTERNAL           LSAME, ILAENV, SLAMCH, SLANGE
00169 *     ..
00170 *     .. Intrinsic Functions ..
00171       INTRINSIC          ABS, MAX, SQRT
00172 *     ..
00173 *     .. Executable Statements ..
00174 *
00175 *     Decode the input arguments
00176 *
00177       IF( LSAME( JOBVL, 'N' ) ) THEN
00178          IJOBVL = 1
00179          ILVL = .FALSE.
00180       ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
00181          IJOBVL = 2
00182          ILVL = .TRUE.
00183       ELSE
00184          IJOBVL = -1
00185          ILVL = .FALSE.
00186       END IF
00187 *
00188       IF( LSAME( JOBVR, 'N' ) ) THEN
00189          IJOBVR = 1
00190          ILVR = .FALSE.
00191       ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
00192          IJOBVR = 2
00193          ILVR = .TRUE.
00194       ELSE
00195          IJOBVR = -1
00196          ILVR = .FALSE.
00197       END IF
00198       ILV = ILVL .OR. ILVR
00199 *
00200 *     Test the input arguments
00201 *
00202       INFO = 0
00203       LQUERY = ( LWORK.EQ.-1 )
00204       IF( IJOBVL.LE.0 ) THEN
00205          INFO = -1
00206       ELSE IF( IJOBVR.LE.0 ) THEN
00207          INFO = -2
00208       ELSE IF( N.LT.0 ) THEN
00209          INFO = -3
00210       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
00211          INFO = -5
00212       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
00213          INFO = -7
00214       ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
00215          INFO = -12
00216       ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
00217          INFO = -14
00218       END IF
00219 *
00220 *     Compute workspace
00221 *      (Note: Comments in the code beginning "Workspace:" describe the
00222 *       minimal amount of workspace needed at that point in the code,
00223 *       as well as the preferred amount for good performance.
00224 *       NB refers to the optimal block size for the immediately
00225 *       following subroutine, as returned by ILAENV. The workspace is
00226 *       computed assuming ILO = 1 and IHI = N, the worst case.)
00227 *
00228       IF( INFO.EQ.0 ) THEN
00229          MINWRK = MAX( 1, 8*N )
00230          MAXWRK = MAX( 1, N*( 7 +
00231      $                 ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) ) )
00232          MAXWRK = MAX( MAXWRK, N*( 7 +
00233      $                 ILAENV( 1, 'SORMQR', ' ', N, 1, N, 0 ) ) )
00234          IF( ILVL ) THEN
00235             MAXWRK = MAX( MAXWRK, N*( 7 +
00236      $                 ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) ) )
00237          END IF
00238          WORK( 1 ) = MAXWRK
00239 *
00240          IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
00241      $      INFO = -16
00242       END IF
00243 *
00244       IF( INFO.NE.0 ) THEN
00245          CALL XERBLA( 'SGGEV ', -INFO )
00246          RETURN
00247       ELSE IF( LQUERY ) THEN
00248          RETURN
00249       END IF
00250 *
00251 *     Quick return if possible
00252 *
00253       IF( N.EQ.0 )
00254      $   RETURN
00255 *
00256 *     Get machine constants
00257 *
00258       EPS = SLAMCH( 'P' )
00259       SMLNUM = SLAMCH( 'S' )
00260       BIGNUM = ONE / SMLNUM
00261       CALL SLABAD( SMLNUM, BIGNUM )
00262       SMLNUM = SQRT( SMLNUM ) / EPS
00263       BIGNUM = ONE / SMLNUM
00264 *
00265 *     Scale A if max element outside range [SMLNUM,BIGNUM]
00266 *
00267       ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
00268       ILASCL = .FALSE.
00269       IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
00270          ANRMTO = SMLNUM
00271          ILASCL = .TRUE.
00272       ELSE IF( ANRM.GT.BIGNUM ) THEN
00273          ANRMTO = BIGNUM
00274          ILASCL = .TRUE.
00275       END IF
00276       IF( ILASCL )
00277      $   CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
00278 *
00279 *     Scale B if max element outside range [SMLNUM,BIGNUM]
00280 *
00281       BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
00282       ILBSCL = .FALSE.
00283       IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
00284          BNRMTO = SMLNUM
00285          ILBSCL = .TRUE.
00286       ELSE IF( BNRM.GT.BIGNUM ) THEN
00287          BNRMTO = BIGNUM
00288          ILBSCL = .TRUE.
00289       END IF
00290       IF( ILBSCL )
00291      $   CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
00292 *
00293 *     Permute the matrices A, B to isolate eigenvalues if possible
00294 *     (Workspace: need 6*N)
00295 *
00296       ILEFT = 1
00297       IRIGHT = N + 1
00298       IWRK = IRIGHT + N
00299       CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
00300      $             WORK( IRIGHT ), WORK( IWRK ), IERR )
00301 *
00302 *     Reduce B to triangular form (QR decomposition of B)
00303 *     (Workspace: need N, prefer N*NB)
00304 *
00305       IROWS = IHI + 1 - ILO
00306       IF( ILV ) THEN
00307          ICOLS = N + 1 - ILO
00308       ELSE
00309          ICOLS = IROWS
00310       END IF
00311       ITAU = IWRK
00312       IWRK = ITAU + IROWS
00313       CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
00314      $             WORK( IWRK ), LWORK+1-IWRK, IERR )
00315 *
00316 *     Apply the orthogonal transformation to matrix A
00317 *     (Workspace: need N, prefer N*NB)
00318 *
00319       CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
00320      $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
00321      $             LWORK+1-IWRK, IERR )
00322 *
00323 *     Initialize VL
00324 *     (Workspace: need N, prefer N*NB)
00325 *
00326       IF( ILVL ) THEN
00327          CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
00328          IF( IROWS.GT.1 ) THEN
00329             CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
00330      $                   VL( ILO+1, ILO ), LDVL )
00331          END IF
00332          CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
00333      $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
00334       END IF
00335 *
00336 *     Initialize VR
00337 *
00338       IF( ILVR )
00339      $   CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
00340 *
00341 *     Reduce to generalized Hessenberg form
00342 *     (Workspace: none needed)
00343 *
00344       IF( ILV ) THEN
00345 *
00346 *        Eigenvectors requested -- work on whole matrix.
00347 *
00348          CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
00349      $                LDVL, VR, LDVR, IERR )
00350       ELSE
00351          CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
00352      $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
00353       END IF
00354 *
00355 *     Perform QZ algorithm (Compute eigenvalues, and optionally, the
00356 *     Schur forms and Schur vectors)
00357 *     (Workspace: need N)
00358 *
00359       IWRK = ITAU
00360       IF( ILV ) THEN
00361          CHTEMP = 'S'
00362       ELSE
00363          CHTEMP = 'E'
00364       END IF
00365       CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
00366      $             ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
00367      $             WORK( IWRK ), LWORK+1-IWRK, IERR )
00368       IF( IERR.NE.0 ) THEN
00369          IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
00370             INFO = IERR
00371          ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
00372             INFO = IERR - N
00373          ELSE
00374             INFO = N + 1
00375          END IF
00376          GO TO 110
00377       END IF
00378 *
00379 *     Compute Eigenvectors
00380 *     (Workspace: need 6*N)
00381 *
00382       IF( ILV ) THEN
00383          IF( ILVL ) THEN
00384             IF( ILVR ) THEN
00385                CHTEMP = 'B'
00386             ELSE
00387                CHTEMP = 'L'
00388             END IF
00389          ELSE
00390             CHTEMP = 'R'
00391          END IF
00392          CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
00393      $                VR, LDVR, N, IN, WORK( IWRK ), IERR )
00394          IF( IERR.NE.0 ) THEN
00395             INFO = N + 2
00396             GO TO 110
00397          END IF
00398 *
00399 *        Undo balancing on VL and VR and normalization
00400 *        (Workspace: none needed)
00401 *
00402          IF( ILVL ) THEN
00403             CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
00404      $                   WORK( IRIGHT ), N, VL, LDVL, IERR )
00405             DO 50 JC = 1, N
00406                IF( ALPHAI( JC ).LT.ZERO )
00407      $            GO TO 50
00408                TEMP = ZERO
00409                IF( ALPHAI( JC ).EQ.ZERO ) THEN
00410                   DO 10 JR = 1, N
00411                      TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
00412    10             CONTINUE
00413                ELSE
00414                   DO 20 JR = 1, N
00415                      TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
00416      $                      ABS( VL( JR, JC+1 ) ) )
00417    20             CONTINUE
00418                END IF
00419                IF( TEMP.LT.SMLNUM )
00420      $            GO TO 50
00421                TEMP = ONE / TEMP
00422                IF( ALPHAI( JC ).EQ.ZERO ) THEN
00423                   DO 30 JR = 1, N
00424                      VL( JR, JC ) = VL( JR, JC )*TEMP
00425    30             CONTINUE
00426                ELSE
00427                   DO 40 JR = 1, N
00428                      VL( JR, JC ) = VL( JR, JC )*TEMP
00429                      VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
00430    40             CONTINUE
00431                END IF
00432    50       CONTINUE
00433          END IF
00434          IF( ILVR ) THEN
00435             CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
00436      $                   WORK( IRIGHT ), N, VR, LDVR, IERR )
00437             DO 100 JC = 1, N
00438                IF( ALPHAI( JC ).LT.ZERO )
00439      $            GO TO 100
00440                TEMP = ZERO
00441                IF( ALPHAI( JC ).EQ.ZERO ) THEN
00442                   DO 60 JR = 1, N
00443                      TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
00444    60             CONTINUE
00445                ELSE
00446                   DO 70 JR = 1, N
00447                      TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
00448      $                      ABS( VR( JR, JC+1 ) ) )
00449    70             CONTINUE
00450                END IF
00451                IF( TEMP.LT.SMLNUM )
00452      $            GO TO 100
00453                TEMP = ONE / TEMP
00454                IF( ALPHAI( JC ).EQ.ZERO ) THEN
00455                   DO 80 JR = 1, N
00456                      VR( JR, JC ) = VR( JR, JC )*TEMP
00457    80             CONTINUE
00458                ELSE
00459                   DO 90 JR = 1, N
00460                      VR( JR, JC ) = VR( JR, JC )*TEMP
00461                      VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
00462    90             CONTINUE
00463                END IF
00464   100       CONTINUE
00465          END IF
00466 *
00467 *        End of eigenvector calculation
00468 *
00469       END IF
00470 *
00471 *     Undo scaling if necessary
00472 *
00473       IF( ILASCL ) THEN
00474          CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
00475          CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
00476       END IF
00477 *
00478       IF( ILBSCL ) THEN
00479          CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
00480       END IF
00481 *
00482   110 CONTINUE
00483 *
00484       WORK( 1 ) = MAXWRK
00485 *
00486       RETURN
00487 *
00488 *     End of SGGEV
00489 *
00490       END