326 SUBROUTINE zggesx( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA,
327 $ B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR,
328 $ LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK,
329 $ IWORK, LIWORK, BWORK, INFO )
336 CHARACTER JOBVSL, JOBVSR, SENSE, SORT
337 INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
343 DOUBLE PRECISION RCONDE( 2 ), RCONDV( 2 ), RWORK( * )
344 COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ),
345 $ beta( * ), vsl( ldvsl, * ), vsr( ldvsr, * ),
356 DOUBLE PRECISION ZERO, ONE
357 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0 )
358 COMPLEX*16 CZERO, CONE
359 parameter( czero = ( 0.0d+0, 0.0d+0 ),
360 $ cone = ( 1.0d+0, 0.0d+0 ) )
363 LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
364 $ LQUERY, WANTSB, WANTSE, WANTSN, WANTST, WANTSV
365 INTEGER I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR,
366 $ ileft, ilo, iright, irows, irwrk, itau, iwrk,
367 $ liwmin, lwrk, maxwrk, minwrk
368 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
372 DOUBLE PRECISION DIF( 2 )
382 DOUBLE PRECISION DLAMCH, ZLANGE
383 EXTERNAL lsame, ilaenv, dlamch, zlange
392 IF( lsame( jobvsl,
'N' ) )
THEN
395 ELSE IF( lsame( jobvsl,
'V' ) )
THEN
403 IF( lsame( jobvsr,
'N' ) )
THEN
406 ELSE IF( lsame( jobvsr,
'V' ) )
THEN
414 wantst = lsame( sort,
'S' )
415 wantsn = lsame( sense,
'N' )
416 wantse = lsame( sense,
'E' )
417 wantsv = lsame( sense,
'V' )
418 wantsb = lsame( sense,
'B' )
419 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 )
422 ELSE IF( wantse )
THEN
424 ELSE IF( wantsv )
THEN
426 ELSE IF( wantsb )
THEN
433 IF( ijobvl.LE.0 )
THEN
435 ELSE IF( ijobvr.LE.0 )
THEN
437 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.lsame( sort,
'N' ) ) )
THEN
439 ELSE IF( .NOT.( wantsn .OR. wantse .OR. wantsv .OR. wantsb ) .OR.
440 $ ( .NOT.wantst .AND. .NOT.wantsn ) )
THEN
442 ELSE IF( n.LT.0 )
THEN
444 ELSE IF( lda.LT.max( 1, n ) )
THEN
446 ELSE IF( ldb.LT.max( 1, n ) )
THEN
448 ELSE IF( ldvsl.LT.1 .OR. ( ilvsl .AND. ldvsl.LT.n ) )
THEN
450 ELSE IF( ldvsr.LT.1 .OR. ( ilvsr .AND. ldvsr.LT.n ) )
THEN
464 maxwrk = n*(1 + ilaenv( 1,
'ZGEQRF',
' ', n, 1, n, 0 ) )
465 maxwrk = max( maxwrk, n*( 1 +
466 $ ilaenv( 1,
'ZUNMQR',
' ', n, 1, n, -1 ) ) )
468 maxwrk = max( maxwrk, n*( 1 +
469 $ ilaenv( 1,
'ZUNGQR',
' ', n, 1, n, -1 ) ) )
473 $ lwrk = max( lwrk, n*n/2 )
480 IF( wantsn .OR. n.EQ.0 )
THEN
487 IF( lwork.LT.minwrk .AND. .NOT.lquery )
THEN
489 ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery)
THEN
495 CALL xerbla(
'ZGGESX', -info )
497 ELSE IF (lquery)
THEN
511 smlnum = dlamch(
'S' )
512 bignum = one / smlnum
513 CALL dlabad( smlnum, bignum )
514 smlnum = sqrt( smlnum ) / eps
515 bignum = one / smlnum
519 anrm = zlange(
'M', n, n, a, lda, rwork )
521 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
524 ELSE IF( anrm.GT.bignum )
THEN
529 $
CALL zlascl(
'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr )
533 bnrm = zlange(
'M', n, n, b, ldb, rwork )
535 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
538 ELSE IF( bnrm.GT.bignum )
THEN
543 $
CALL zlascl(
'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr )
551 CALL zggbal(
'P', n, a, lda, b, ldb, ilo, ihi, rwork( ileft ),
552 $ rwork( iright ), rwork( irwrk ), ierr )
557 irows = ihi + 1 - ilo
561 CALL zgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ),
562 $ work( iwrk ), lwork+1-iwrk, ierr )
567 CALL zunmqr(
'L',
'C', irows, icols, irows, b( ilo, ilo ), ldb,
568 $ work( itau ), a( ilo, ilo ), lda, work( iwrk ),
569 $ lwork+1-iwrk, ierr )
575 CALL zlaset(
'Full', n, n, czero, cone, vsl, ldvsl )
576 IF( irows.GT.1 )
THEN
577 CALL zlacpy(
'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,
578 $ vsl( ilo+1, ilo ), ldvsl )
580 CALL zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,
581 $ work( itau ), work( iwrk ), lwork+1-iwrk, ierr )
587 $
CALL zlaset(
'Full', n, n, czero, cone, vsr, ldvsr )
592 CALL zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,
593 $ ldvsl, vsr, ldvsr, ierr )
602 CALL zhgeqz(
'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,
603 $ alpha, beta, vsl, ldvsl, vsr, ldvsr, work( iwrk ),
604 $ lwork+1-iwrk, rwork( irwrk ), ierr )
606 IF( ierr.GT.0 .AND. ierr.LE.n )
THEN
608 ELSE IF( ierr.GT.n .AND. ierr.LE.2*n )
THEN
624 $
CALL zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
626 $
CALL zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
631 bwork( i ) = selctg( alpha( i ), beta( i ) )
639 CALL ztgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,
640 $ alpha, beta, vsl, ldvsl, vsr, ldvsr, sdim, pl, pr,
641 $ dif, work( iwrk ), lwork-iwrk+1, iwork, liwork,
645 $ maxwrk = max( maxwrk, 2*sdim*( n-sdim ) )
646 IF( ierr.EQ.-21 )
THEN
652 IF( ijob.EQ.1 .OR. ijob.EQ.4 )
THEN
656 IF( ijob.EQ.2 .OR. ijob.EQ.4 )
THEN
657 rcondv( 1 ) = dif( 1 )
658 rcondv( 2 ) = dif( 2 )
670 $
CALL zggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
671 $ rwork( iright ), n, vsl, ldvsl, ierr )
674 $
CALL zggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
675 $ rwork( iright ), n, vsr, ldvsr, ierr )
680 CALL zlascl(
'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr )
681 CALL zlascl(
'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr )
685 CALL zlascl(
'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr )
686 CALL zlascl(
'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr )
696 cursl = selctg( alpha( i ), beta( i ) )
699 IF( cursl .AND. .NOT.lastsl )
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
ZGGBAL
subroutine zggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
ZGGBAK
subroutine zhgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
ZHGEQZ
subroutine zggesx(JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO)
ZGGESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine ztgsen(IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO)
ZTGSEN
subroutine zungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
ZUNGQR
subroutine zgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
ZGGHRD
subroutine zunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMQR
subroutine zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.