226 SUBROUTINE dgegs( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR,
227 $ alphai, beta, vsl, ldvsl, vsr, ldvsr, work,
236 CHARACTER JOBVSL, JOBVSR
237 INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
240 DOUBLE PRECISION A( lda, * ), ALPHAI( * ), ALPHAR( * ),
241 $ b( ldb, * ), beta( * ), vsl( ldvsl, * ),
242 $ vsr( ldvsr, * ), work( * )
248 DOUBLE PRECISION ZERO, ONE
249 parameter( zero = 0.0d0, one = 1.0d0 )
252 LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY
253 INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
254 $ iright, irows, itau, iwork, lopt, lwkmin,
255 $ lwkopt, nb, nb1, nb2, nb3
256 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
266 DOUBLE PRECISION DLAMCH, DLANGE
267 EXTERNAL lsame, ilaenv, dlamch, dlange
276 IF( lsame( jobvsl,
'N' ) )
THEN
279 ELSE IF( lsame( jobvsl,
'V' ) )
THEN
287 IF( lsame( jobvsr,
'N' ) )
THEN
290 ELSE IF( lsame( jobvsr,
'V' ) )
THEN
300 lwkmin = max( 4*n, 1 )
303 lquery = ( lwork.EQ.-1 )
305 IF( ijobvl.LE.0 )
THEN
307 ELSE IF( ijobvr.LE.0 )
THEN
309 ELSE IF( n.LT.0 )
THEN
311 ELSE IF( lda.LT.max( 1, n ) )
THEN
313 ELSE IF( ldb.LT.max( 1, n ) )
THEN
315 ELSE IF( ldvsl.LT.1 .OR. ( ilvsl .AND. ldvsl.LT.n ) )
THEN
317 ELSE IF( ldvsr.LT.1 .OR. ( ilvsr .AND. ldvsr.LT.n ) )
THEN
319 ELSE IF( lwork.LT.lwkmin .AND. .NOT.lquery )
THEN
324 nb1 = ilaenv( 1,
'DGEQRF',
' ', n, n, -1, -1 )
325 nb2 = ilaenv( 1,
'DORMQR',
' ', n, n, n, -1 )
326 nb3 = ilaenv( 1,
'DORGQR',
' ', n, n, n, -1 )
327 nb = max( nb1, nb2, nb3 )
328 lopt = 2*n + n*( nb+1 )
333 CALL
xerbla(
'DGEGS ', -info )
335 ELSE IF( lquery )
THEN
346 eps = dlamch(
'E' )*dlamch(
'B' )
347 safmin = dlamch(
'S' )
348 smlnum = n*safmin / eps
349 bignum = one / smlnum
353 anrm = dlange(
'M', n, n, a, lda, work )
355 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
358 ELSE IF( anrm.GT.bignum )
THEN
364 CALL
dlascl(
'G', -1, -1, anrm, anrmto, n, n, a, lda, iinfo )
365 IF( iinfo.NE.0 )
THEN
373 bnrm = dlange(
'M', n, n, b, ldb, work )
375 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
378 ELSE IF( bnrm.GT.bignum )
THEN
384 CALL
dlascl(
'G', -1, -1, bnrm, bnrmto, n, n, b, ldb, iinfo )
385 IF( iinfo.NE.0 )
THEN
398 CALL
dggbal(
'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ),
399 $ work( iright ), work( iwork ), iinfo )
400 IF( iinfo.NE.0 )
THEN
409 irows = ihi + 1 - ilo
413 CALL
dgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
414 $ work( iwork ), lwork+1-iwork, iinfo )
416 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
417 IF( iinfo.NE.0 )
THEN
422 CALL
dormqr(
'L',
'T', irows, icols, irows, b( ilo, ilo ), ldb,
423 $ work( itau ), a( ilo, ilo ), lda, work( iwork ),
424 $ lwork+1-iwork, iinfo )
426 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
427 IF( iinfo.NE.0 )
THEN
433 CALL
dlaset(
'Full', n, n, zero, one, vsl, ldvsl )
434 CALL
dlacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
435 $ vsl( ilo+1, ilo ), ldvsl )
436 CALL
dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,
437 $ work( itau ), work( iwork ), lwork+1-iwork,
440 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
441 IF( iinfo.NE.0 )
THEN
448 $ CALL
dlaset(
'Full', n, n, zero, one, vsr, ldvsr )
452 CALL
dgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,
453 $ ldvsl, vsr, ldvsr, iinfo )
454 IF( iinfo.NE.0 )
THEN
464 CALL
dhgeqz(
'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,
465 $ alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr,
466 $ work( iwork ), lwork+1-iwork, iinfo )
468 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
469 IF( iinfo.NE.0 )
THEN
470 IF( iinfo.GT.0 .AND. iinfo.LE.n )
THEN
472 ELSE IF( iinfo.GT.n .AND. iinfo.LE.2*n )
THEN
483 CALL
dggbak(
'P',
'L', n, ilo, ihi, work( ileft ),
484 $ work( iright ), n, vsl, ldvsl, iinfo )
485 IF( iinfo.NE.0 )
THEN
491 CALL
dggbak(
'P',
'R', n, ilo, ihi, work( ileft ),
492 $ work( iright ), n, vsr, ldvsr, iinfo )
493 IF( iinfo.NE.0 )
THEN
502 CALL
dlascl(
'H', -1, -1, anrmto, anrm, n, n, a, lda, iinfo )
503 IF( iinfo.NE.0 )
THEN
507 CALL
dlascl(
'G', -1, -1, anrmto, anrm, n, 1, alphar, n,
509 IF( iinfo.NE.0 )
THEN
513 CALL
dlascl(
'G', -1, -1, anrmto, anrm, n, 1, alphai, n,
515 IF( iinfo.NE.0 )
THEN
522 CALL
dlascl(
'U', -1, -1, bnrmto, bnrm, n, n, b, ldb, iinfo )
523 IF( iinfo.NE.0 )
THEN
527 CALL
dlascl(
'G', -1, -1, bnrmto, bnrm, n, 1, beta, n, iinfo )
528 IF( iinfo.NE.0 )
THEN
subroutine dgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
DGGHRD
subroutine dgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
DGEQRF
subroutine dormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
DORMQR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dgegs(JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO)
DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
subroutine dlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine dorgqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
DORGQR
subroutine dhgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO)
DHGEQZ
subroutine dggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
DGGBAK
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
DGGBAL